From a3fcd26ea12a7ca948d2ea46f068740ec58271e7 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 3 Feb 2023 12:27:55 +0300 Subject: [PATCH] logger fixed --- hbs2-core/hbs2-core.cabal | 1 + hbs2-core/lib/HBS2/Net/Proto/Peer.hs | 5 -- hbs2-core/lib/HBS2/System/Logger/Simple.hs | 88 +++++++++++++++---- .../lib/HBS2/System/Logger/Simple/Class.hs | 37 ++++++++ hbs2-peer/app/PeerMain.hs | 27 +++++- hbs2-tests/test/TestLogger.hs | 16 ++-- 6 files changed, 142 insertions(+), 32 deletions(-) create mode 100644 hbs2-core/lib/HBS2/System/Logger/Simple/Class.hs diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 52dd641b..5f139390 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -98,6 +98,7 @@ library , HBS2.Prelude.Plated , HBS2.Storage , HBS2.System.Logger.Simple + , HBS2.System.Logger.Simple.Class -- other-modules: diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index a6d9e90b..8f15cf4b 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs @@ -64,7 +64,6 @@ sendPing :: forall e m . ( MonadIO m sendPing pip = do nonce <- newNonce @(PeerHandshake e) update nonce (PeerHandshakeKey pip) id - liftIO $ print $ "sendPing" <+> pretty pip <+> pretty (AsBase58 nonce) request pip (PeerPing @e nonce) peerHandShakeProto :: forall e m . ( MonadIO m @@ -87,7 +86,6 @@ peerHandShakeProto = pip <- thatPeer proto -- TODO: взять свои ключи creds <- getCredentials @e - liftIO $ print $ "PING" <+> pretty pip <+> pretty (AsBase58 nonce) -- TODO: подписать нонс let sign = makeSign @e (view peerSignSk creds) nonce @@ -108,14 +106,11 @@ peerHandShakeProto = se' <- find @e (PeerHandshakeKey pip) id maybe1 se' (pure ()) $ \nonce -> do - liftIO $ print $ pretty "PONG" <+> pretty (AsBase58 nonce) let pk = view peerSignKey d let signed = verifySign @e pk sign nonce - liftIO $ print $ "SIGNED: " <+> pretty signed - expire (PeerHandshakeKey pip) update (KnownPeer d) (KnownPeerKey pip) id diff --git a/hbs2-core/lib/HBS2/System/Logger/Simple.hs b/hbs2-core/lib/HBS2/System/Logger/Simple.hs index 688f453f..499640d8 100644 --- a/hbs2-core/lib/HBS2/System/Logger/Simple.hs +++ b/hbs2-core/lib/HBS2/System/Logger/Simple.hs @@ -1,45 +1,95 @@ +{-# Language TemplateHaskell #-} +{-# Language AllowAmbiguousTypes #-} {-# Language UndecidableInstances #-} +{-# Language TypeFamilyDependencies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module HBS2.System.Logger.Simple ( withSimpleLogger , debug + , log + , err + , warn + , notice + , info + , setLogging + , asIs + , loggerTr + , module HBS2.System.Logger.Simple.Class ) where -import Control.Monad -import Data.Foldable +import HBS2.System.Logger.Simple.Class + +import Prelude hiding (log) +import Data.Functor +import Data.Foldable(for_) import Control.Monad.IO.Class import System.Log.FastLogger -import System.Log.FastLogger.LoggerSet import Data.IORef import System.IO.Unsafe import Prettyprinter +import Data.IntMap (IntMap) +import Data.IntMap qualified as IntMap +import Lens.Micro.Platform -loggers :: IORef (Maybe LoggerSet) -loggers = unsafePerformIO (newIORef Nothing) +data LoggerEntry = + LoggerEntry + { _loggerSet :: !LoggerSet + , _loggerTr :: LogStr -> LogStr + } + +makeLenses 'LoggerEntry + +asIs :: a -> a +asIs = id + +{-# OPTIONS_GHC -fno-cse #-} {-# NOINLINE loggers #-} - +loggers :: IORef (IntMap LoggerEntry) +loggers = unsafePerformIO $ newIORef mempty withSimpleLogger :: IO () -> IO () withSimpleLogger program = do - set <- newStdoutLoggerSet 10000 - void $ atomicModifyIORef' loggers $ \case - Nothing -> (Just set, Just set) - Just s -> (Just s, Just s) - program - withLogger flushLogStr + void program + lo <- readIORef loggers <&> IntMap.elems + for_ lo (flushLogStr . view loggerSet) -withLogger :: MonadIO m => (LoggerSet -> m b) -> m () +setLogging :: forall a m . (MonadIO m, HasLogLevel a) + => (LoggerEntry -> LoggerEntry) + -> m () + +setLogging f = do + se <- liftIO $ newStdoutLoggerSet 10000 -- FIXME: ?? + let def = f (LoggerEntry se id) + let key = logKey @a + void $ liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.insert key def x, ())) + +withLogger :: forall a m . (HasLogLevel a, MonadIO m) => (LoggerEntry -> m ()) -> m () withLogger f = do - lo <- liftIO $ readIORef loggers - forM_ lo f + lo <- liftIO $ readIORef loggers <&> IntMap.lookup (logKey @a) + maybe (pure ()) f lo + +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)) debug :: (MonadIO m, ToLogStr a) => a -> m () -debug s = do - liftIO $ withLogger $ \set -> pushLogStrLn set (toLogStr s) +debug = log @DEBUG +warn :: (MonadIO m, ToLogStr a) => a -> m () +warn = log @WARN -instance {-# OVERLAPPABLE #-} Pretty a => ToLogStr a where - toLogStr p = toLogStr (show (pretty p)) +err :: (MonadIO m, ToLogStr a) => a -> m () +err = log @ERROR +notice :: (MonadIO m, ToLogStr a) => a -> m () +notice = log @NOTICE + +info :: (MonadIO m, ToLogStr a) => 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) diff --git a/hbs2-core/lib/HBS2/System/Logger/Simple/Class.hs b/hbs2-core/lib/HBS2/System/Logger/Simple/Class.hs new file mode 100644 index 00000000..aa21b437 --- /dev/null +++ b/hbs2-core/lib/HBS2/System/Logger/Simple/Class.hs @@ -0,0 +1,37 @@ +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +{-# Language TypeFamilyDependencies #-} +module HBS2.System.Logger.Simple.Class where + +import GHC.TypeLits +import Data.Proxy + +class KnownNat (LogLevel p) => HasLogLevel p where + type family LogLevel p = (id :: Nat) | id -> p + + logKey :: Int + logKey = fromIntegral $ natVal (Proxy :: Proxy (LogLevel p)) + +data DEBUG +data INFO +data ERROR +data WARN +data NOTICE + + +instance HasLogLevel DEBUG where + type instance LogLevel DEBUG = 0 + +instance HasLogLevel INFO where + type instance LogLevel INFO = 1 + + +instance HasLogLevel ERROR where + type instance LogLevel ERROR = 2 + +instance HasLogLevel WARN where + type instance LogLevel WARN = 3 + +instance HasLogLevel NOTICE where + type instance LogLevel NOTICE = 4 + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index ff6ee440..2486db47 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -22,7 +22,9 @@ import HBS2.Net.Proto.Sessions import HBS2.OrDie import HBS2.Prelude.Plated import HBS2.Storage.Simple -import HBS2.System.Logger.Simple + +import HBS2.System.Logger.Simple hiding (info) +import HBS2.System.Logger.Simple qualified as Log import RPC import BlockDownload @@ -79,7 +81,18 @@ deriving newtype instance Hashable (SessionKey UDP (BlockChunks UDP)) deriving stock instance Eq (SessionKey UDP (BlockChunks UDP)) main :: IO () -main = join . customExecParser (prefs showHelpOnError) $ +main = do + + setLogging @DEBUG asIs + -- setLogging @INFO asIs + -- setLogging @ERROR asIs + -- setLogging @WARN asIs + -- setLogging @NOTICE asIs + + withSimpleLogger runCLI + +runCLI :: IO () +runCLI = join . customExecParser (prefs showHelpOnError) $ info (helper <*> parser) ( fullDesc <> header "hbs2-peer daemon" @@ -197,7 +210,9 @@ instance ( Monad m -- Вынести в сигнатуру. runPeer :: PeerOpts -> IO () -runPeer opts = Exception.handle myException $ withSimpleLogger do +runPeer opts = Exception.handle myException $ do + + debug "STARTED!" sodiumInit @@ -394,6 +409,12 @@ emitToPeer env k e = liftIO $ withPeerM env (emit k e) withRPC :: String -> RPC UDP -> IO () withRPC saddr cmd = withSimpleLogger do + setLogging @DEBUG asIs + setLogging @INFO asIs + setLogging @ERROR asIs + setLogging @WARN asIs + setLogging @NOTICE asIs + as <- parseAddr (fromString saddr) <&> fmap (PeerUDP . addrAddress) let rpc' = headMay $ L.sortBy (compare `on` addrPriority) as diff --git a/hbs2-tests/test/TestLogger.hs b/hbs2-tests/test/TestLogger.hs index 35f78781..0db738ce 100644 --- a/hbs2-tests/test/TestLogger.hs +++ b/hbs2-tests/test/TestLogger.hs @@ -4,17 +4,23 @@ import HBS2.System.Logger.Simple import Control.Monad import Control.Concurrent.Async +import Lens.Micro.Platform -import System.Log.FastLogger import Prettyprinter +-- import System.Log.FastLogger + main :: IO () main = do - withSimpleLogger do - replicateConcurrently_ 1000 do - debug $ "DEBUG" <+> pretty 1000 - + coo <- async $ do + withSimpleLogger do + setLogging @DEBUG id -- (set loggerTr ("debug: " <>)) + setLogging @INFO id -- (set loggerTr ("info: " <>)) + forConcurrently_ [1..1000] $ \i -> do + debug $ "DEBUG" <+> pretty i + info $ "INFO!" <+> pretty (i*1000) + wait coo