From 1fb6ba8df46d4024c7e32f2dec66f2acefc010c3 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Wed, 8 Nov 2023 14:43:35 +0300 Subject: [PATCH] Squashed commit of the following: commit ce28d07e466a60336decf27cfb19d589ba7f4009 Author: Vladimir Krutkin Date: Fri Nov 3 19:36:33 2023 +0300 Fixme commit 74aad5cf91261a279e5f8f238f9abb5d6b834c8d Author: Vladimir Krutkin Date: Fri Nov 3 19:35:48 2023 +0300 PR edit commit aa391ccdb3684311ec04905d03d9d6e405427f81 Author: Vladimir Krutkin Date: Fri Nov 3 19:26:50 2023 +0300 Fix commit ce99526f417de3c9795cae23307a3503ed5bf3fd Merge: c25e65ea 88df87a1 Author: Vladimir Krutkin Date: Fri Nov 3 19:03:09 2023 +0300 Merge remote-tracking branch 'origin/master' into fastpok-file-logger commit c25e65ea1a7858881746191c554e03752a612e58 Author: Vladimir Krutkin Date: Fri Nov 3 19:01:35 2023 +0300 Fixme commit 347f0ef7a54791d6f6d9059c89f0fd1be8529772 Author: Vladimir Krutkin Date: Fri Nov 3 18:59:58 2023 +0300 PR commit 0903e591c76774cd9255911e4b1aebdda8f6763d Author: Vladimir Krutkin Date: Fri Nov 3 17:54:09 2023 +0300 Add ANSI styles to logger commit e2e64c3e7118b4304d578b3d4a1adb8e457664a5 Author: Vladimir Krutkin Date: Mon Oct 30 22:57:54 2023 +0300 Set default logger to stdout commit 22d437a4e9ab805c86efd0af61cbe29459386d72 Author: Vladimir Krutkin Date: Mon Oct 30 16:14:19 2023 +0300 Fixme commit dc8bad7053635ba6899ab1db070486384467bda7 Author: Vladimir Krutkin Date: Mon Oct 30 16:13:03 2023 +0300 PR commit c632d70886fc1f6368a39d4eb9d243c5b2c796c9 Author: Vladimir Krutkin Date: Mon Oct 30 16:08:58 2023 +0300 Reuse logger sets commit 08aaa6c782b933c4e8ed79857382727ed4b6b4a5 Merge: d3c783bd eab3175d Author: Vladimir Krutkin Date: Mon Oct 30 16:08:15 2023 +0300 Merge remote-tracking branch 'origin/master' into fastpok-file-logger commit d3c783bd0db86ea6f46fb7143e42749d694b4304 Author: Vladimir Krutkin Date: Thu Oct 12 14:01:13 2023 +0300 test --- docs/devlog.md | 10 ++ hbs2-core/hbs2-core.cabal | 2 + hbs2-core/lib/HBS2/System/Logger/Simple.hs | 142 +++++++++++------- .../lib/HBS2/System/Logger/Simple/ANSI.hs | 38 +++++ hbs2-core/test/TestFileLogger.hs | 15 +- 5 files changed, 152 insertions(+), 55 deletions(-) create mode 100644 hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs diff --git a/docs/devlog.md b/docs/devlog.md index 21beb6a3..5a684112 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -1,3 +1,13 @@ +## 2023-11-03 + +PR: hbs2-file-logger-strikes-again + branch: fastpok-file-logger + commit: aa391ccdb3684311ec04905d03d9d6e405427f81 + Теперь используется один LoggerSet для каждого LoggerType. + Это исправляет ошибку, из-за которой два логгера не могли писать + в один и тот же файл. + Добавлена поддержка ANSI стилей. + ## 2023-10-22 тестируем шифрование на уровне протокола diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 30eb11d0..52974980 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -133,6 +133,7 @@ library , HBS2.Storage.Operations.ByteString , HBS2.Storage.Operations.Missed , HBS2.System.Logger.Simple + , HBS2.System.Logger.Simple.ANSI , HBS2.System.Logger.Simple.Class , HBS2.Net.Dialog.Core , HBS2.Net.Dialog.Client @@ -177,6 +178,7 @@ library , network-simple , network-byte-order , prettyprinter + , prettyprinter-ansi-terminal , mwc-random , random , random-shuffle diff --git a/hbs2-core/lib/HBS2/System/Logger/Simple.hs b/hbs2-core/lib/HBS2/System/Logger/Simple.hs index b2eb43fb..b4584188 100644 --- a/hbs2-core/lib/HBS2/System/Logger/Simple.hs +++ b/hbs2-core/lib/HBS2/System/Logger/Simple.hs @@ -28,7 +28,7 @@ import HBS2.System.Logger.Simple.Class import Prelude hiding (log) import Data.Functor -import Data.Foldable(for_) +import Data.Foldable (for_) import Control.Monad.IO.Class import System.Log.FastLogger import Data.IORef @@ -37,16 +37,19 @@ import Prettyprinter import Data.IntMap (IntMap) import Data.IntMap qualified as IntMap import Lens.Micro.Platform +import Data.Map (Map) +import Data.Map.Strict qualified as Map +import Control.Concurrent.STM data LoggerType = LoggerStdout | LoggerStderr | LoggerFile FilePath | LoggerNull + deriving (Eq, Ord) data LoggerEntry = LoggerEntry - { _loggerSet :: !LoggerSet - , _loggerTr :: LogStr -> LogStr + { _loggerTr :: LogStr -> LogStr , _loggerType :: !LoggerType } @@ -60,19 +63,49 @@ defLog = id loggers :: IORef (IntMap LoggerEntry) loggers = unsafePerformIO $ newIORef mempty +data LoggerSetWrapper = LoggerSetWrapper + { _loggerSet :: LoggerSet, + _loggerSetUsedBy :: Int + } + +makeLenses 'LoggerSetWrapper + +{-# OPTIONS_GHC -fno-cse #-} +{-# NOINLINE loggerSets #-} +loggerSets :: TVar (Map LoggerType LoggerSetWrapper) +loggerSets = unsafePerformIO $ newTVarIO mempty + withSimpleLogger :: IO () -> IO () withSimpleLogger program = do void program - lo <- readIORef loggers <&> IntMap.elems - for_ lo (flushLogStr . view loggerSet) + loggers' <- readIORef loggers <&> IntMap.elems + loggerSets' <- readTVarIO loggerSets + for_ + loggers' + ( \loggerEntry -> do + let loggerType' = view loggerType loggerEntry + let maybeLoggerSet = Map.lookup loggerType' loggerSets' + maybe (pure ()) (flushLogStr . view loggerSet) maybeLoggerSet + ) type SetLoggerEntry = ( LoggerEntry -> LoggerEntry ) -delLogger :: forall m . MonadIO m => Maybe LoggerEntry -> m () -delLogger e = - case view loggerSet <$> e of - Nothing -> pure () - Just s -> liftIO $ rmLoggerSet s +delLoggerSet :: forall m . MonadIO m => LoggerType -> m () +delLoggerSet loggerType' = do + action <- liftIO $ atomically $ do + loggerSets' <- readTVar loggerSets + case Map.lookup loggerType' loggerSets' of + Nothing -> pure $ pure () + Just loggerSet' -> do + let usedBy = view loggerSetUsedBy loggerSet' + if usedBy < 2 + then do + modifyTVar' loggerSets (Map.delete loggerType') + pure $ rmLoggerSet (view loggerSet loggerSet') + else do + modifyTVar' loggerSets (Map.adjust (over loggerSetUsedBy (\x -> x - 1)) loggerType') + pure $ pure () + liftIO action toStderr :: SetLoggerEntry toStderr = set loggerType LoggerStderr @@ -83,77 +116,82 @@ toStdout = set loggerType LoggerStdout toFile :: FilePath -> SetLoggerEntry toFile filePath = set loggerType (LoggerFile filePath) +createLoggerSet :: MonadIO m => LoggerType -> m () +createLoggerSet loggerType' = liftIO $ do + loggerSets' <- readTVarIO loggerSets + if Map.member loggerType' loggerSets' + then + -- Increment `_loggerSetUsedBy` value if logger set of a given type already exist + atomically $ modifyTVar' loggerSets (Map.adjust (over loggerSetUsedBy (+ 1)) loggerType') + else do + -- Otherwise create new logger set + newLoggerSet' <- case loggerType' of + LoggerStdout -> Just <$> newStdoutLoggerSet defaultBufSize + LoggerStderr -> Just <$> newStderrLoggerSet defaultBufSize + LoggerFile f -> Just <$> newFileLoggerSet defaultBufSize f + LoggerNull -> pure Nothing + case newLoggerSet' of + Nothing -> pure () + Just loggerSet' -> + atomically $ modifyTVar' loggerSets (Map.insert loggerType' $ LoggerSetWrapper loggerSet' 0) + setLogging :: forall a m . (MonadIO m, HasLogLevel a) => (LoggerEntry -> LoggerEntry) -> m () - -setLogging f = do - se <- liftIO $ newStdoutLoggerSet 10000 -- FIXME: ?? - def <- updateLogger $ f (LoggerEntry se id LoggerNull) +setLogging setLoggerEntry = do let key = logKey @a - e <- liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.insert key def x, IntMap.lookup key x)) - delLogger e + dummyLoggerEntry = LoggerEntry id LoggerStdout + loggerEntry = setLoggerEntry dummyLoggerEntry + loggerType' = view loggerType loggerEntry + liftIO $ createLoggerSet loggerType' + liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.insert key loggerEntry x, ())) - where - updateLogger e = case view loggerType e of - - LoggerNull -> pure e - - LoggerStderr -> do - delLogger (Just e) - se <- liftIO $ newStderrLoggerSet 10000 -- FIXME: ?? - pure $ set loggerSet se e - - LoggerStdout -> do - delLogger (Just e) - se <- liftIO $ newStdoutLoggerSet 10000 -- FIXME: ?? - pure $ set loggerSet se e - - LoggerFile filePath-> do - delLogger (Just e) - se <- liftIO $ newFileLoggerSet 10000 filePath -- FIXME: ?? - pure $ set loggerSet se e - -setLoggingOff :: forall a m . (MonadIO m, HasLogLevel a) => m () +setLoggingOff :: forall a m. (MonadIO m, HasLogLevel a) => m () setLoggingOff = do let key = logKey @a - e <- liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.delete key x, IntMap.lookup key x)) - delLogger e + maybeLoggerEntry <- liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.delete key x, IntMap.lookup key x)) + case maybeLoggerEntry of + Nothing -> pure () + Just loggerEntry -> do + let loggerType' = view loggerType loggerEntry + delLoggerSet loggerType' withLogger :: forall a m . (HasLogLevel a, MonadIO m) => (LoggerEntry -> m ()) -> m () withLogger f = do - lo <- liftIO $ readIORef loggers <&> IntMap.lookup (logKey @a) - maybe (pure ()) f lo + maybeLoggerEntry <- liftIO $ readIORef loggers <&> IntMap.lookup (logKey @a) + maybe (pure ()) f maybeLoggerEntry log :: forall a s m . (MonadIO m, HasLogLevel a, ToLogStr s) => s -> m () -log s = liftIO $ withLogger @a - $ \le -> pushLogStrLn (view loggerSet le) - (view loggerTr le (toLogStr s)) +log s = liftIO $ withLogger @a $ \loggerEntry -> do + loggerSets' <- readTVarIO loggerSets + let loggerType' = view loggerType loggerEntry + maybeLoggerSet = Map.lookup loggerType' loggerSets' + msg = view loggerTr loggerEntry (toLogStr s) + maybe (pure ()) (\x -> pushLogStrLn (view loggerSet x) msg) maybeLoggerSet - -trace :: (MonadIO m, ToLogStr a) => a -> m () +trace :: (ToLogStr a, MonadIO m) => a -> m () trace = log @TRACE -debug :: (MonadIO m, ToLogStr a) => a -> m () +debug :: (ToLogStr a, MonadIO m) => a -> m () debug = log @DEBUG -warn :: (MonadIO m, ToLogStr a) => a -> m () +warn :: (ToLogStr a, MonadIO m) => a -> m () warn = log @WARN -err :: (MonadIO m, ToLogStr a) => a -> m () +err :: (ToLogStr a, MonadIO m) => a -> m () err = log @ERROR -notice :: (MonadIO m, ToLogStr a) => a -> m () +notice :: (ToLogStr a, MonadIO m) => a -> m () notice = log @NOTICE -info :: (MonadIO m, ToLogStr a) => a -> m () +info :: (ToLogStr a, MonadIO m) => a -> m () info = log @INFO -- instance {-# OVERLAPPABLE #-} Pretty a => ToLogStr a where -- toLogStr p = toLogStr (show (pretty p)) instance {-# OVERLAPPABLE #-} ToLogStr (Doc ann) where - toLogStr p = toLogStr (show p) + toLogStr = toLogStr . show logPrefix :: LogStr -> LoggerEntry-> LoggerEntry logPrefix s = set loggerTr (s <>) diff --git a/hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs b/hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs new file mode 100644 index 00000000..4aa42bed --- /dev/null +++ b/hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module HBS2.System.Logger.Simple.ANSI + ( trace + , debug + , err + , warn + , notice + , info + , AnsiStyle + , ToLogStr(..) + ) where + +import Prettyprinter.Render.Terminal +import HBS2.System.Logger.Simple qualified as Logger +import Control.Monad.IO.Class +import Prettyprinter +import System.Log.FastLogger + +trace :: MonadIO m => Doc AnsiStyle -> m () +trace = Logger.trace @(Doc AnsiStyle) + +debug :: MonadIO m => Doc AnsiStyle -> m () +debug = Logger.debug @(Doc AnsiStyle) + +warn :: MonadIO m => Doc AnsiStyle -> m () +warn = Logger.warn @(Doc AnsiStyle) + +err :: MonadIO m => Doc AnsiStyle -> m () +err = Logger.err @(Doc AnsiStyle) + +notice :: MonadIO m => Doc AnsiStyle -> m () +notice = Logger.notice @(Doc AnsiStyle) + +info :: MonadIO m => Doc AnsiStyle -> m () +info = Logger.info @(Doc AnsiStyle) + +instance ToLogStr (Doc AnsiStyle) where + toLogStr = toLogStr . renderStrict . layoutPretty defaultLayoutOptions \ No newline at end of file diff --git a/hbs2-core/test/TestFileLogger.hs b/hbs2-core/test/TestFileLogger.hs index 65904566..c65a4246 100644 --- a/hbs2-core/test/TestFileLogger.hs +++ b/hbs2-core/test/TestFileLogger.hs @@ -10,14 +10,23 @@ logFile = "/tmp/testFileLogger.log" debugPrefix :: SetLoggerEntry debugPrefix = toFile logFile . logPrefix "[debug] " +warnPrefix :: SetLoggerEntry +warnPrefix = toFile logFile . logPrefix "[warn] " + testFileLogger :: IO () testFileLogger = do - let msg = "Oh hi Mark" + let msg1 = "I did not!" + let msg2 = "Oh hi Mark" setLogging @DEBUG debugPrefix - debug msg + setLogging @WARN warnPrefix + + debug msg1 + warn msg2 + setLoggingOff @DEBUG + setLoggingOff @WARN fileContent <- readFile logFile - assertEqual "write == read" fileContent ("[debug] " <> msg <> "\n") + assertEqual "written == read" fileContent ("[debug] " <> msg1 <> "\n" <> "[warn] " <> msg2 <> "\n") removeFile logFile