voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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
This commit is contained in:
Dmitry Zuikov 2023-11-08 14:43:35 +03:00
parent 002ecf7b3e
commit 1fb6ba8df4
5 changed files with 152 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
docs/devlog.md
View File

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

2
hbs2-core/hbs2-core.cabal
View File

@ -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

138
hbs2-core/lib/HBS2/System/Logger/Simple.hs
View File

@ -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
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
dummyLoggerEntry = LoggerEntry id LoggerStdout
loggerEntry = setLoggerEntry dummyLoggerEntry
loggerType' = view loggerType loggerEntry
liftIO $ createLoggerSet loggerType'
liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.insert key loggerEntry x, ()))
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 <>)

38
hbs2-core/lib/HBS2/System/Logger/Simple/ANSI.hs Normal file
View File

@ -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

15
hbs2-core/test/TestFileLogger.hs
View File

@ -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