lager (empty) → 0.1.0.0

raw patch · 6 files changed

+371/−0 lines, 6 filesdep +asyncdep +basedep +lager

Dependencies added: async, base, lager, prettyprinter, prettyprinter-ansi-terminal, stm, text

Files

CHANGELOG.md +5/−0
LICENSE +20/−0
README.md +16/−0
lager.cabal +39/−0
lib/Lager.hs +276/−0
test/Main.hs +15/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for lager++## 0.1.0.0 -- 3-26-2026++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2026 dopamane++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ README.md view

@@ -0,0 +1,16 @@+# Concurrent Lager :beer:++```hs+import Lager++main =+  withLager "APP" [defConsole] $ \l -> do+    logDebug   l "Cheers! 🍻"+    logWarning l "Warning!"+```++Build & Docs+```+cabal build+cabal haddock+```

+ lager.cabal view

@@ -0,0 +1,39 @@+cabal-version:      3.0+name:               lager+version:            0.1.0.0+synopsis:           Concurrent logging+license:            MIT+license-file:       LICENSE+author:             dopamane+maintainer:         dwc1295@gmail.com+copyright:          David Cox+category:           Logger+build-type:         Simple+extra-doc-files:    CHANGELOG.md+                    README.md++source-repository head+  type:     git+  location: https://github.com/dopamane/lager++library+  hs-source-dirs:   lib+  default-language: Haskell2010+  ghc-options:      -Wall -O2+  exposed-modules:  Lager+  build-depends:    async+                  , base < 5.0+                  , prettyprinter+                  , prettyprinter-ansi-terminal+                  , stm+                  , text++test-suite test+  hs-source-dirs:   test+  default-language: Haskell2010+  ghc-options:      -Wall -O2 -threaded+  type:             exitcode-stdio-1.0+  main-is:          Main.hs+  build-depends:    async+                  , base+                  , lager

+ lib/Lager.hs view

@@ -0,0 +1,276 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Concurrent Lager 🍺+--+-- @+-- import Lager+--+-- main =+--   'withLager' \"APP\" ['File' 'Info' \"log.txt\"] $ \\l -> do+--     'logDebug'   l "Cheers! 🍻"+--     'logWarning' l "Warning!"+-- @+module Lager+  ( -- * Logging+    Lager+  , withLager+  , newLager+  , newLagerSTM+  , runLager+  , drinkLager+  , logDebug+  , logInfo+  , logNotice+  , logWarning+  , logErr+  , logCrit+  , logAlert+  , logEmerg+  , logSTM+  , logStream+  , logSub+  , Msg(..)+  , -- * Target+    Target(..)+  , defConsole+  , Level(..)+  , defLevelRGB+  , -- * Exception+    LagerException(..)+  ) where++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Data.Functor+import Data.Ord+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy    as T+import qualified Data.Text.Lazy.IO as T+import GHC.Generics+import Prettyprinter+import Prettyprinter.Render.Terminal+import System.IO++-- | Logging handle+data Lager = Lager+  { nm :: Text        -- source name+  , tg :: [Target]+  , wc :: TChan Msg   -- write chan+  , rc :: [TChan Msg] -- read chans+  , drink :: TVar Bool+  , drunk :: TVar Bool+  }++-- | Log message+data Msg = Msg+  { lvl :: Level+  , txt :: Text -- ^ message+  , src :: Text -- ^ logger source+  }++-- | Acquire a new handle+newLager :: Text -> [Target] -> IO Lager+newLager nm' = atomically . newLagerSTM nm'++-- | Acquire a new handle in STM+newLagerSTM :: Text -> [Target] -> STM Lager+newLagerSTM nm' tgt' = do+  wc' <- newBroadcastTChan+  Lager nm' tgt' wc'+    <$> replicateM (length tgt') (dupTChan wc')+    <*> newTVar False+    <*> newTVar False++-- | Acquire a 'newLager', concurrently 'runLager',+-- then finally 'drinkLager' if the body terminates+-- or throws an exception.+withLager :: Text -> [Target] -> (Lager -> IO a) -> IO a+withLager nm' tgt' k = do+  l <- newLager nm' tgt'+  either id id+    <$> race (k l `finally` drinkLager l)+             (runLager l >> forever (threadDelay maxBound))++-- | Finish logging. Blocks until all outputs are written by 'runLager'.+drinkLager :: Lager -> IO ()+drinkLager l = do+  atomically $ writeTVar (drink l) True+  atomically $ checkDrunk l++checkDrink :: Lager -> STM ()+checkDrink = check <=< readTVar . drink++checkDrunk :: Lager -> STM ()+checkDrunk = check <=< readTVar . drunk++logDebug :: Lager -> Text -> IO ()+logDebug l = lager l Debug++logInfo :: Lager -> Text -> IO ()+logInfo l = lager l Info++logNotice :: Lager -> Text -> IO ()+logNotice l = lager l Notice++logWarning :: Lager -> Text -> IO ()+logWarning l = lager l Warning++logErr :: Lager -> Text -> IO ()+logErr l = lager l Err++logCrit :: Lager -> Text -> IO ()+logCrit l = lager l Crit++logAlert :: Lager -> Text -> IO ()+logAlert l = lager l Alert++logEmerg :: Lager -> Text -> IO ()+logEmerg l = lager l Emerg++-- | Log text in IO+lager :: Lager -> Level -> Text -> IO ()+lager l lvl' = atomically . logSTM l lvl'++-- | Log text in STM+logSTM :: Lager -> Level -> Text -> STM ()+logSTM l lvl' msg = do+  throwIfDrunk l+  writeTChan (wc l) $ Msg lvl' msg (nm l)++-- | Extend the logger name+logSub :: Text -> Lager -> Lager+logSub nm' l = Lager nm'' [] (wc l) [] (drink l) (drunk l)+  where+    nm'' | T.null nm'    = nm l+         | T.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++-- | Log level+data Level+  = Emerg -- ^ emergency+  | Alert+  | Crit  -- ^ critcal+  | Err   -- ^ error+  | Warning+  | Notice+  | Info+  | Debug+  deriving (Enum, Eq, Generic, Read, Show)++-- | 'Debug' < 'Emerg'+instance Ord Level where+  compare = comparing $ negate . fromEnum++annLevelColor :: Level -> [(Level, Color)] -> Doc AnsiStyle -> Doc AnsiStyle+annLevelColor l m = case lookup l m of+  Just c  -> annotate $ color c+  Nothing -> id++-- | Default 'Console' color schema+defLevelRGB :: [(Level, Color)]+defLevelRGB =+  [ (Emerg, Red), (Alert, Red), (Crit, Red), (Err, Red)+  , (Warning, Yellow), (Notice, Green), (Debug, Cyan)+  ]++-- | Log output+data Target+  = Console Level [(Level, Color)] -- ^ stdout, optional RGB+  | Journal Level                  -- ^ journald stdout+  | File Level FilePath+  deriving (Eq, Generic, Show)++-- | Default 'Console' target with 'Info' log level+-- and 'defLevelRGB' color schema.+defConsole :: Target+defConsole = Console Info defLevelRGB++-- | Run logging daemon+runLager :: Lager -> IO ()+runLager l =+  mapConcurrently_ (runTarget l) (zip (tg l) (rc l))+    `finally` atomically (writeTVar (drunk l) True)++runTarget :: Lager -> (Target, TChan Msg) -> IO ()+runTarget lgr (t, c) = case t of+  Console l m -> runHandle lgr stdout (renderConsoleRGB m) l c+  Journal l -> runHandle lgr stdout renderJournal l c+  File l path ->+    withFile path WriteMode $ \hndl ->+      runHandle lgr hndl renderConsole l c++renderJournal :: Msg -> Text+renderJournal msg =+  "<" <> T.pack (show $ fromEnum $ lvl msg) <> "> " <> renderConsole msg++renderConsole :: Msg -> Text+renderConsole msg+  | T.null (src msg) = txt msg+  | otherwise        = "[" <> src msg <> "] " <> txt msg++renderConsoleRGB :: [(Level, Color)] -> Msg -> Text+renderConsoleRGB m msg =+  renderLazy $+  layoutPretty defaultLayoutOptions $+  annLevelColor (lvl msg) m $+  pretty $+  renderConsole msg++runHandle+  :: Lager+  -> Handle+  -> (Msg -> Text)+  -> Level+  -> TChan Msg+  -> IO ()+runHandle lgr hndl render l c = loop+  where+    loop = join $ atomically $ do+      m <- Just `fmap` readTChan c <|> (checkDrink lgr $> Nothing)+      case m of+        Just a  -> return $ logHandle hndl render l a >> loop+        Nothing -> do+          msgs <- listTChan c+          return $ mapM_ (logHandle hndl render l) msgs++logHandle :: Handle -> (Msg -> Text) -> Level -> Msg -> IO ()+logHandle hndl render l msg+  | not (visible l msg) = return ()+  | otherwise           = T.hPutStrLn hndl $ render msg++listTChan :: TChan a -> STM [a]+listTChan t = loop+  where+    loop = do+      isEmpty <- isEmptyTChan t+      if isEmpty+        then return []+        else (:) <$> readTChan t <*> loop++visible :: Level -> Msg -> Bool+visible lvl' msg = lvl msg >= lvl'++data LagerException+  = LagerDaemonTerminated+    -- ^ the daemon is already closed due to 'drinkLager'++instance Show LagerException where+  show LagerDaemonTerminated = "lager: daemon terminated"++instance Exception LagerException

+ test/Main.hs view

@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++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!"