module OrgStat.Logging
(
Severity (..)
, initLogging
, logDebug
, logInfo
, logNotice
, logWarning
, logError
, logMessage
) where
import Universum
import Control.Concurrent.MVar (modifyMVar_, withMVar)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Fmt (fmt, padRightF, (+|), (|+), (|++|))
import Fmt.Time (dateDashF, hmsF, subsecondF, tzNameF)
import System.Console.ANSI (Color (Blue, Green, Magenta, Red, Yellow), ColorIntensity (Vivid),
ConsoleLayer (Foreground), SGR (Reset, SetColor), setSGRCode)
import System.IO.Unsafe (unsafePerformIO)
data Severity
= Debug
| Info
| Notice
| Warning
| Error
deriving (Eq, Ord, Show)
data LogInternalState = LogInternalState
{ lisMinSeverity :: Severity
} deriving Show
{-# NOINLINE loggingState #-}
loggingState :: MVar LogInternalState
loggingState = unsafePerformIO $ newMVar $ LogInternalState Debug
initLogging :: Severity -> IO ()
initLogging sev = modifyMVar_ loggingState $ const $ pure $ LogInternalState sev
colorizer :: Severity -> Text -> Text
colorizer pr s =
let (before, after) = table pr
in toText before <> s <> toText after
where
table :: Severity -> (String, String)
table severity = case severity of
Error -> (setColor Red , reset)
Debug -> (setColor Green , reset)
Notice -> (setColor Magenta , reset)
Warning -> (setColor Yellow , reset)
Info -> (setColor Blue , reset)
where
setColor color = setSGRCode [SetColor Foreground Vivid color]
reset = setSGRCode [Reset]
centiUtcTimeF :: UTCTime -> Text
centiUtcTimeF t =
dateDashF t |+ " " +| hmsF t |++| centiSecondF t |+ " " +| tzNameF t |+ ""
where
centiSecondF = padRightF 3 '0' . T.take 3 . fmt . subsecondF
logMessage
:: (MonadIO m)
=> Severity
-> Text
-> m ()
logMessage severity msg =
liftIO $ withMVar loggingState $ \LogInternalState{..} -> do
time <- liftIO $ getCurrentTime
let text = format time
when (severity >= lisMinSeverity) $ putStrLn text
where
format time = mconcat
[ colorizer severity $ "[" <> show severity <> "]"
, " ["
, centiUtcTimeF time
, "] "
, msg
]
logDebug, logInfo, logNotice, logWarning, logError
:: MonadIO m
=> Text -> m ()
logDebug = logMessage Debug
logInfo = logMessage Info
logNotice = logMessage Notice
logWarning = logMessage Warning
logError = logMessage Error