lager 0.2.0.0 → 1.0.0.0

raw patch · 4 files changed

+123/−59 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• lager.cabal +1/−1
• lib/Lager.hs +89/−50
• test/Main.hs +28/−8

@@ -1,5 +1,10 @@ # Revision history for lager +## 1.0.0.0 -- 3-26-2026++* finalize API+* test+ ## 0.2.0.0 -- 3-26-2026  * switch to `String` API

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               lager-version:            0.2.0.0+version:            1.0.0.0 synopsis:           Concurrent logging license:            MIT license-file:       LICENSE

@@ -7,8 +7,8 @@ -- -- main = --   'withLager' \"APP\" ['File' 'Info' \"log.txt\"] $ \\l -> do---     'logDebug'   l "Cheers! 🍻"---     'logWarning' l "Warning!"+--     'logDebug' l "Cheers! 🍻"+--     'logWarn'  l "Warning!" -- @ module Lager   ( -- * Logging@@ -18,23 +18,31 @@   , newLagerSTM   , runLager   , drinkLager+  , streamLager+  , extendLager   , logDebug+  , logDebugSTM   , logInfo+  , logInfoSTM   , logNotice-  , logWarning+  , logNoticeSTM+  , logWarn+  , logWarnSTM   , logErr+  , logErrSTM   , logCrit+  , logCritSTM   , logAlert+  , logAlertSTM   , logEmerg-  , logSTM-  , logStream-  , logSub+  , logEmergSTM   , Msg(..)   , -- * Target     Target(..)   , defConsole   , Level(..)-  , defLevelRGB+  , defLevelColor+  , Color(..)   , -- * Exception     LagerException(..)   ) where@@ -105,58 +113,81 @@ checkDrunk :: Lager -> STM () checkDrunk = check <=< readTVar . drunk +-- | Stream log messages+streamLager :: Lager -> (IO Msg -> IO a) -> IO a+streamLager l k = do+  r <- atomically $ throwIfDrunk l *> dupTChan (wc l)+  k  $ atomically $ throwIfDrunk l *> readTChan  r++-- | Extend the logger name+extendLager :: String -> Lager -> Lager+extendLager nm' l = Lager nm'' [] (wc l) [] (drink l) (drunk l)+  where+    nm'' | null nm'    = nm l+         | null (nm l) = nm'+         | otherwise   = nm l <> "|" <> nm'++-- | Log text in IO+lager :: Lager -> Level -> String -> IO ()+lager l lvl' = atomically . lagerSTM l lvl'++-- | Log text in STM+lagerSTM :: Lager -> Level -> String -> STM ()+lagerSTM l lvl' msg = do+  throwIfDrunk l+  writeTChan (wc l) $ Msg lvl' msg (nm l)+ logDebug :: Lager -> String -> IO () logDebug l = lager l Debug +logDebugSTM :: Lager -> String -> STM ()+logDebugSTM l = lagerSTM l Debug+ logInfo :: Lager -> String -> IO () logInfo l = lager l Info +logInfoSTM :: Lager -> String -> STM ()+logInfoSTM l = lagerSTM l Info+ logNotice :: Lager -> String -> IO () logNotice l = lager l Notice -logWarning :: Lager -> String -> IO ()-logWarning l = lager l Warning+logNoticeSTM :: Lager -> String -> STM ()+logNoticeSTM l = lagerSTM l Notice +-- | warning+logWarn :: Lager -> String -> IO ()+logWarn l = lager l Warn++logWarnSTM :: Lager -> String -> STM ()+logWarnSTM l = lagerSTM l Warn++-- | error logErr :: Lager -> String -> IO () logErr l = lager l Err +logErrSTM :: Lager -> String -> STM ()+logErrSTM l = lagerSTM l Err++-- | critical logCrit :: Lager -> String -> IO () logCrit l = lager l Crit +logCritSTM :: Lager -> String -> STM ()+logCritSTM l = lagerSTM l Crit+ logAlert :: Lager -> String -> IO () logAlert l = lager l Alert +logAlertSTM :: Lager -> String -> STM ()+logAlertSTM l = lagerSTM l Alert++-- | emergency logEmerg :: Lager -> String -> IO () logEmerg l = lager l Emerg --- | Log text in IO-lager :: Lager -> Level -> String -> IO ()-lager l lvl' = atomically . logSTM l lvl'---- | Log text in STM-logSTM :: Lager -> Level -> String -> STM ()-logSTM l lvl' msg = do-  throwIfDrunk l-  writeTChan (wc l) $ Msg lvl' msg (nm l)---- | Extend the logger name-logSub :: String -> Lager -> Lager-logSub nm' l = Lager nm'' [] (wc l) [] (drink l) (drunk l)-  where-    nm'' | null nm'    = nm l-         | null (nm l) = nm'-         | otherwise   = nm l <> "|" <> nm'---- | Stream log messages-logStream :: Lager -> (IO Msg -> IO a) -> IO a-logStream l k = do-  r <- atomically $ throwIfDrunk l *> dupTChan (wc l)-  k  $ atomically $ throwIfDrunk l *> readTChan  r--throwIfDrunk :: Lager -> STM ()-throwIfDrunk l = do-  isDrunk <- readTVar $ drunk l-  when isDrunk $ throwSTM LagerDaemonTerminated+logEmergSTM :: Lager -> String -> STM ()+logEmergSTM l = lagerSTM l Emerg  -- | Log level data Level@@ -164,7 +195,7 @@   | Alert   | Crit  -- ^ critcal   | Err   -- ^ error-  | Warning+  | Warn  -- ^ warning   | Notice   | Info   | Debug@@ -180,33 +211,35 @@   Nothing -> id  -- | Default 'Console' color schema-defLevelRGB :: [(Level, Color)]-defLevelRGB =+defLevelColor :: [(Level, Color)]+defLevelColor =   [ (Emerg, Red), (Alert, Red), (Crit, Red), (Err, Red)-  , (Warning, Yellow), (Notice, Green), (Debug, Cyan)+  , (Warn, Yellow), (Notice, Green), (Debug, Cyan)   ]  -- | Log output data Target-  = Console Level [(Level, Color)] -- ^ stdout, optional RGB+  = Console Level [(Level, Color)] -- ^ stdout, color schema   | Journal Level                  -- ^ journald stdout   | File Level FilePath   deriving (Eq, Generic, Show)  -- | Default 'Console' target with 'Info' log level--- and 'defLevelRGB' color schema.+-- and 'defLevelColor' color schema. defConsole :: Target-defConsole = Console Info defLevelRGB+defConsole = Console Info defLevelColor  -- | Run logging daemon runLager :: Lager -> IO ()-runLager l =-  mapConcurrently_ (runTarget l) (zip (tg l) (rc l))-    `finally` atomically (writeTVar (drunk l) True)+runLager l = run `finally` atomically (writeTVar (drunk l) True)+  where+    run = case zip (tg l) (rc l) of+      [] -> atomically $ checkDrink l+      ts -> mapConcurrently_ (runTarget l) ts  runTarget :: Lager -> (Target, TChan Msg) -> IO () runTarget lgr (t, c) = case t of-  Console l m -> runHandle lgr stdout (renderConsoleRGB m) l c+  Console l m -> runHandle lgr stdout (renderConsoleColor m) l c   Journal l -> runHandle lgr stdout renderJournal l c   File l path ->     withFile path WriteMode $ \hndl ->@@ -221,8 +254,8 @@   | null (src msg) = txt msg   | otherwise      = "[" <> src msg <> "] " <> txt msg -renderConsoleRGB :: [(Level, Color)] -> Msg -> String-renderConsoleRGB m msg =+renderConsoleColor :: [(Level, Color)] -> Msg -> String+renderConsoleColor m msg =   T.unpack $   renderLazy $   layoutPretty defaultLayoutOptions $@@ -267,8 +300,14 @@ data LagerException   = LagerDaemonTerminated     -- ^ the daemon is already closed due to 'drinkLager'+    -- or an exception  instance Show LagerException where   show LagerDaemonTerminated = "lager: daemon terminated"  instance Exception LagerException++throwIfDrunk :: Lager -> STM ()+throwIfDrunk l = do+  isDrunk <- readTVar $ drunk l+  when isDrunk $ throwSTM LagerDaemonTerminated

@@ -1,13 +1,33 @@ module Main (main) where +import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad import Lager  main :: IO ()-main = withLager "APP" [Console Debug defLevelRGB, File Info "log.txt"] $ \l -> do-  logNotice l "Hello World!"-  logDebug l "Invisible"-  logErr l "NOO"-  logInfo l "YES"-  logWarning  l "HI"-  let l' = logSub "SUB" l-  logInfo l' "SUB!"+main =+  withLager "APP" [Console Debug defLevelColor] $ \l ->+  streamLager l $ \msgIO ->+  concurrently_ (streaming msgIO) $ do+    logNotice l "Hello World!"+    logDebug l "Invisible"+    logErr l "NOO"+    logInfo l "YES"+    logWarn  l "HI"+    let l' = extendLager "SUB" l+    logInfo l' "SUB!"+    forever $ do+      mapConcurrently_ id+        [ -- logEmerg l "Emergency!"+          logAlert l "Alert!"+        , logCrit l "Critical."+        , logErr l "Error."+        , logWarn l "Warning"+        , logNotice l "Notice"+        , logInfo l "Information"+        , logDebug l "Debugging"+        ]+      threadDelay 1000000+  where+    streaming msgIO = forever $ print =<< msgIO