module System.Log.SLog
(
SLogT
, SLog
, runSLogT
, simpleLog
, FlushKey
, waitFlush
, MonadSLog(..)
, logD
, logI
, logS
, logW
, logE
, Logger(..)
, Sync(..)
, LogLine(..)
, Severity(..)
, Filter
, anySev
, LogConfig(..)
, defaultLogConfig
, module System.Log.SLog.Format
, defaultLogFormat
, forkSLog
, formatLine
, unsafeUnliftSLogT
)
where
import System.Log.SLog.Format
import Prelude hiding (log)
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Error
import Control.Monad.Cont
import Control.Monad.Base
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import Data.Semigroup
import qualified Data.Map as Map
import Data.Time.LocalTime
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.IO
import System.Console.ANSI
import System.Directory
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.ForkableT.Instances
data Severity
= DEBUG | INFO | SUCCESS | WARNING | ERROR
deriving (Show, Read, Eq, Ord)
class (MonadIO m) => MonadSLog m where
log :: Severity -> T.Text -> m ()
default log :: (MonadTrans t, MonadSLog m) => Severity -> T.Text -> t m ()
log sev = lift . log sev
instance (MonadSLog m) => MonadSLog (StateT s m)
instance (MonadSLog m) => MonadSLog (ReaderT s m)
instance (MonadSLog m, Error e) => MonadSLog (ErrorT e m)
instance (MonadSLog m) => MonadSLog (ContT r m)
instance (MonadSLog m) => MonadSLog (ResourceT m)
defaultLogFormat :: Format
defaultLogFormat = $(format "%d(%F %T) | %s | [%t] %m")
logD :: MonadSLog m => String -> m ()
logD = log DEBUG . T.pack
logS :: MonadSLog m => String -> m ()
logS = log SUCCESS . T.pack
logI :: MonadSLog m => String -> m ()
logI = log INFO . T.pack
logW :: MonadSLog m => String -> m ()
logW = log WARNING . T.pack
logE :: MonadSLog m => String -> m ()
logE = log ERROR . T.pack
sgr :: Severity -> [SGR]
sgr DEBUG = [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid White]
sgr INFO = [SetColor Foreground Vivid White]
sgr SUCCESS = [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Green]
sgr WARNING = [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Yellow]
sgr ERROR = [SetConsoleIntensity BoldIntensity, SetBlinkSpeed SlowBlink, SetColor Foreground Vivid Red]
withSgr :: [SGR] -> T.Text -> T.Text
withSgr sg s = T.concat [T.pack $ setSGRCode sg, s, T.pack $ setSGRCode []]
data Sync
= Sync | Async
deriving (Eq)
data Logger
= FileLogger Sync FilePath
| StdoutLogger Sync
| StderrLogger Sync
| TChanLogger (TChan LogLine)
deriving (Eq)
type Filter = Severity -> Bool
anySev :: Filter
anySev = const True
data LogLine
= LogLine { logSeverity :: Severity
, logMessage :: T.Text
, logTimestamp :: ZonedTime
, logThread :: T.Text
}
data LogConfig
= LogConfig {
ansiColours :: Bool
, loggers :: [(Filter, Logger)]
}
defaultLogConfig :: FilePath -> LogConfig
defaultLogConfig fName
= LogConfig { ansiColours = True
, loggers = [ ((>= INFO), StdoutLogger Sync)
, (anySev, FileLogger Async fName)
]
}
data LoggerInternal
= SyncLoggerInternal Handle (MVar ()) Bool
| AsyncLoggerInternal (TChan T.Text) Bool
| TChanLoggerInternal (TChan LogLine)
data SLogEnv
= SLogEnv {
threadName :: T.Text
, loggerInternals :: [(Filter, LoggerInternal)]
, logColours :: Bool
, logFormat :: Format
}
newtype SLogT m a
= SLogT { unSLogT :: ReaderT SLogEnv (ResourceT m) a }
deriving ( Functor, Monad, MonadIO, Applicative
, MonadThrow )
deriving instance (MonadBase IO m) => MonadBase IO (SLogT m)
deriving instance (MonadBase IO m, MonadThrow m, MonadIO m) => MonadResource (SLogT m)
instance MonadTransControl SLogT where
newtype StT SLogT a = StTSLogT {unStTSLogT :: StT ResourceT a}
liftWith f = SLogT . ReaderT $ \r ->
liftWith $ \lres ->
f $ \(SLogT t) ->
liftM StTSLogT $ lres $ runReaderT t r
restoreT = SLogT . lift . restoreT . liftM unStTSLogT
instance (MonadBaseControl IO m) => MonadBaseControl IO (SLogT m) where
newtype StM (SLogT m) a = StMSLogT { unStMSLogT :: ComposeSt SLogT m a }
liftBaseWith = defaultLiftBaseWith StMSLogT
restoreM = defaultRestoreM unStMSLogT
instance MonadTrans SLogT where
lift = SLogT . lift . lift
type SLog = SLogT IO
newtype FlushKey = FlushKey (TVar Bool)
waitFlush :: FlushKey -> IO ()
waitFlush (FlushKey tvar)
= atomically $ do
b <- readTVar tvar
unless b retry
runSLogT :: (MonadResource m, MonadBaseControl IO m) => LogConfig -> Format -> String -> SLogT m a -> m (a, FlushKey)
runSLogT LogConfig{..} lf tName (SLogT r)
= runResourceT $ do
(_, tvar) <- allocate (newTVarIO False) (\t -> atomically $ writeTVar t True)
runResourceT $ do
internals <- initLoggers loggers
a <- lift $ runReaderT r SLogEnv{ threadName = T.pack tName
, loggerInternals = internals
, logColours = ansiColours
, logFormat = lf }
return (a, FlushKey tvar)
simpleLog :: (MonadResource m, MonadBaseControl IO m) => FilePath -> SLogT m a -> m a
simpleLog fName s = do
tName <- show <$> liftIO myThreadId
(a, fkey) <- runSLogT (defaultLogConfig fName) defaultLogFormat tName s
liftIO $ waitFlush fkey
return a
initLoggers :: (MonadResource m, Applicative m) => [(Filter, Logger)] -> ResourceT (ResourceT m) [(Filter, LoggerInternal)]
initLoggers fls = do
InitState{..} <- liftIO $ aggregateLoggers fls
let stdHandle (Just ini) h = do
_ <- lift $ register (hFlush h)
return [(h, ini, True)]
stdHandle Nothing _ = return []
createHandle (fname, ini) = do
(_, h) <- allocate
(openFile fname AppendMode)
(\h -> hFlush h >> hClose h)
return (h, ini, False)
sout <- stdHandle stdoutInit stdout
serr <- stdHandle stderrInit stderr
files <- lift . mapM createHandle $ Map.toList fileInitMap
let toInternal (h, InitSync f, c) = do
lock <- liftIO $ newMVar ()
return [(f, SyncLoggerInternal h lock c)]
toInternal (h, InitAsync f, c) = do
tchan <- liftIO newTChanIO
_ <- forkCleanUp $ lift . asyncLogger Nothing h tchan
return [(f, AsyncLoggerInternal tchan c)]
toInternal (h, Both fs fa, c) = do
lock <- liftIO $ newMVar ()
tchan <- liftIO newTChanIO
_ <- forkCleanUp $ lift . asyncLogger (Just lock) h tchan
return [(fs, SyncLoggerInternal h lock c), (fa, AsyncLoggerInternal tchan c)]
toInternalTChan (f, tchan) = (f, TChanLoggerInternal tchan)
nonTChan <- join <$> mapM toInternal (sout ++ serr ++ files)
return $ nonTChan ++ map toInternalTChan tchanInit
data InitLogger
= InitSync Filter
| InitAsync Filter
| Both Filter Filter
instance Semigroup InitLogger where
InitSync f <> InitSync f' = InitSync $ liftM2 (||) f f'
InitSync f <> InitAsync f' = Both f f'
InitSync f <> Both f' f'' = Both (liftM2 (||) f f') f''
InitAsync f <> InitSync f' = Both f f'
InitAsync f <> InitAsync f' = InitAsync $ liftM2 (||) f f'
InitAsync f <> Both f' f'' = Both f' (liftM2 (||) f f'')
Both f' f'' <> InitSync f = Both (liftM2 (||) f f') f''
Both f' f'' <> InitAsync f = Both f' (liftM2 (||) f f'')
Both f f' <> Both f'' f''' = Both (liftM2 (||) f f') (liftM2 (||) f'' f''')
canonExist :: String -> IO String
canonExist f = appendFile f "" >> canonicalizePath f
forkCleanUp :: (MonadResource m) =>
(TVar Bool -> ResIO ()) -> ResourceT (ResourceT m) ThreadId
forkCleanUp io = do
(_, exitSignal) <- allocate (newTVarIO False) (\t -> atomically $ writeTVar t True)
st <- lift . liftWith $ \unliftRes -> liftIO . unliftRes . fork $ io exitSignal
lift . restoreT $ return st
data InitState = InitState { fileInitMap :: Map.Map FilePath InitLogger
, stdoutInit :: Maybe InitLogger
, stderrInit :: Maybe InitLogger
, tchanInit :: [(Filter, TChan LogLine)]
}
aggregateLoggers :: [(Filter, Logger)] -> IO InitState
aggregateLoggers fls = execStateT
(mapM_ (uncurry initLogger) fls)
InitState { fileInitMap = Map.empty
, stdoutInit = Nothing
, stderrInit = Nothing
, tchanInit = [] }
where
initLogger :: Filter -> Logger -> StateT InitState IO ()
initLogger f (FileLogger sync fname) = do
trueFname <- liftIO $ canonExist fname
s@InitState{..} <- get
let ini = case sync of ; Sync -> InitSync f ; Async -> InitAsync f
put s { fileInitMap = Map.alter (<> Just ini) trueFname fileInitMap }
initLogger f (StdoutLogger sync) = do
s@InitState{..} <- get
let ini = case sync of ; Sync -> InitSync f ; Async -> InitAsync f
put s { stdoutInit = stdoutInit <> Just ini }
initLogger f (StderrLogger sync) = do
s@InitState{..} <- get
let ini = case sync of ; Sync -> InitSync f ; Async -> InitAsync f
put s { stderrInit = stderrInit <> Just ini }
initLogger f (TChanLogger tchan) =
modify $ \s@InitState{..} -> s { tchanInit = (f, tchan) : tchanInit }
asyncLogger :: Maybe (MVar ()) -> Handle -> TChan T.Text -> TVar Bool -> IO ()
asyncLogger mlock h tchan exitSignal = flip runContT return $
callCC $ \exit -> forever $ do
m <- liftIO . atomically $
(Just <$> readTChan tchan)
`orElse`
(readTVar exitSignal >>= check >> return Nothing)
case m of
Just str -> liftIO $ case mlock of
Nothing -> T.hPutStrLn h str
Just lock -> withMVar lock $ \_ -> T.hPutStrLn h str
Nothing -> do
liftIO $ hFlush h
exit ()
chs :: Bool -> a -> a -> a
chs False a _ = a
chs True _ b = b
logger :: LoggerInternal -> LogLine -> T.Text -> T.Text -> IO ()
logger (AsyncLoggerInternal tchan c) _ ns s = atomically . writeTChan tchan $ chs c ns s
logger (SyncLoggerInternal h lock c) _ ns s = withMVar lock $ \_ -> do
T.hPutStrLn h (chs c ns s)
hFlush h
logger (TChanLoggerInternal tchan) l _ _ = atomically $ writeTChan tchan l
formatLine :: Bool -> Format -> LogLine -> T.Text
formatLine isColour les ll = T.concat $ map (formatLine' ll) les
where
formatLine' LogLine{logMessage} MessageElem = logMessage
formatLine' LogLine{logSeverity} SeverityElem =
let sev = padS 7 . T.pack $ show logSeverity
in if isColour then withSgr (sgr logSeverity) sev else sev
formatLine' _ (StringElem str) = str
formatLine' LogLine{logTimestamp} (DateTimeElem f) = f logTimestamp
formatLine' LogLine{logThread} ThreadElem = logThread
instance (MonadBaseControl IO m, MonadIO m) => Forkable (SLogT m) (SLogT m) where
fork (SLogT (ReaderT f)) = SLogT . ReaderT $ \env ->
fork $ do
tid <- liftIO myThreadId
f env { threadName = T.pack $ show tid }
forkSLog :: (MonadBaseControl IO m, MonadIO m) => String -> SLogT m () -> SLogT m ThreadId
forkSLog tname (SLogT m) = SLogT . local (\e -> e { threadName = T.pack tname }) $ fork m
padS :: Int -> T.Text -> T.Text
padS n t = t `T.append` T.replicate (n T.length t) " "
unsafeUnliftSLogT :: forall m b. (Monad m, MonadBaseControl IO m) =>
((forall a. SLogT m a -> m a) -> SLogT m b) -> SLogT m b
unsafeUnliftSLogT f = do
env <- SLogT ask
let unlift :: SLogT m c -> m c
unlift s = runResourceT $ runReaderT (unSLogT s) env
f unlift
instance (MonadIO m) => MonadSLog (SLogT m) where
log sev s = do
SLogEnv{..} <- SLogT ask
liftIO $ do
timestamp <- getZonedTime
let logLine = LogLine { logMessage = s
, logSeverity = sev
, logTimestamp = timestamp
, logThread = threadName
}
nonColoured = formatLine False logFormat logLine
coloured = if logColours
then formatLine True logFormat logLine
else nonColoured
mapM_ (\(fter, l) -> when (fter sev) $
logger l logLine nonColoured coloured) loggerInternals