Squashed commit of the following:

commit ce28d07e466a60336decf27cfb19d589ba7f4009
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Fri Nov 3 19:36:33 2023 +0300

    Fixme

commit 74aad5cf91261a279e5f8f238f9abb5d6b834c8d
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Fri Nov 3 19:35:48 2023 +0300

    PR edit

commit aa391ccdb3684311ec04905d03d9d6e405427f81
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Fri Nov 3 19:26:50 2023 +0300

    Fix

commit ce99526f417de3c9795cae23307a3503ed5bf3fd
Merge: c25e65ea 88df87a1
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Fri Nov 3 19:03:09 2023 +0300

    Merge remote-tracking branch 'origin/master' into fastpok-file-logger

commit c25e65ea1a7858881746191c554e03752a612e58
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Fri Nov 3 19:01:35 2023 +0300

    Fixme

commit 347f0ef7a54791d6f6d9059c89f0fd1be8529772
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Fri Nov 3 18:59:58 2023 +0300

    PR

commit 0903e591c76774cd9255911e4b1aebdda8f6763d
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Fri Nov 3 17:54:09 2023 +0300

    Add ANSI styles to logger

commit e2e64c3e7118b4304d578b3d4a1adb8e457664a5
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Mon Oct 30 22:57:54 2023 +0300

    Set default logger to stdout

commit 22d437a4e9ab805c86efd0af61cbe29459386d72
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Mon Oct 30 16:14:19 2023 +0300

    Fixme

commit dc8bad7053635ba6899ab1db070486384467bda7
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Mon Oct 30 16:13:03 2023 +0300

    PR

commit c632d70886fc1f6368a39d4eb9d243c5b2c796c9
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Mon Oct 30 16:08:58 2023 +0300

    Reuse logger sets

commit 08aaa6c782b933c4e8ed79857382727ed4b6b4a5
Merge: d3c783bd eab3175d
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Mon Oct 30 16:08:15 2023 +0300

    Merge remote-tracking branch 'origin/master' into fastpok-file-logger

commit d3c783bd0db86ea6f46fb7143e42749d694b4304
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Thu Oct 12 14:01:13 2023 +0300

    test

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
 
 тестируем шифрование на уровне протокола

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

hbs2-core/lib/HBS2/System/Logger/Simple.hs

@@ -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
+  loggers' <- readIORef loggers <&> IntMap.elems
-  for_ lo (flushLogStr . view loggerSet)
+  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 ()
+delLoggerSet :: forall m . MonadIO m => LoggerType -> m ()
-delLogger e =
+delLoggerSet loggerType' = do
-  case view loggerSet <$> e of
+  action <- liftIO $ atomically $ do
-    Nothing -> pure ()
+    loggerSets' <- readTVar loggerSets
-    Just s  -> liftIO $ rmLoggerSet s
+    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 setLoggerEntry = do
-setLogging f = do
-  se <- liftIO $ newStdoutLoggerSet 10000 -- FIXME: ??
-  def <- updateLogger $ f (LoggerEntry se id LoggerNull)
   let key = logKey @a
-  e <- liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.insert key def x, IntMap.lookup key x))
+      dummyLoggerEntry = LoggerEntry id LoggerStdout
-  delLogger e
+      loggerEntry = setLoggerEntry dummyLoggerEntry
-
+      loggerType' = view loggerType loggerEntry
-  where
+  liftIO $ createLoggerSet loggerType'
-    updateLogger e = case view loggerType e of
+  liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.insert key loggerEntry x, ()))
-
-      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 = do
   let key = logKey @a
-  e <- liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.delete key x, IntMap.lookup key x))
+  maybeLoggerEntry <- liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.delete key x, IntMap.lookup key x))
-  delLogger e
+  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)
+  maybeLoggerEntry <- liftIO $ readIORef loggers <&> IntMap.lookup (logKey @a)
-  maybe (pure ()) f lo
+  maybe (pure ()) f maybeLoggerEntry
 
 log :: forall a s m . (MonadIO m, HasLogLevel a, ToLogStr s) => s -> m ()
-log s = liftIO $ withLogger @a
+log s = liftIO $ withLogger @a $ \loggerEntry -> do
-               $ \le -> pushLogStrLn (view loggerSet le)
+  loggerSets' <- readTVarIO loggerSets
-                                     (view loggerTr le (toLogStr s))
+  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 :: (ToLogStr a, MonadIO m) => a -> m ()
-trace :: (MonadIO m, ToLogStr a) => 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 <>)

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 

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