reduced noise in log

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

@@ -20,6 +20,7 @@ module HBS2.System.Logger.Simple
   , logPrefix
   , SetLoggerEntry
   , module HBS2.System.Logger.Simple.Class
+  , ToLogStr(..)
   ) where
 
 import HBS2.System.Logger.Simple.Class

hbs2-peer/app/PeerMain.hs

@@ -123,6 +123,7 @@ data PeerWhiteListKey
 data PeerStorageKey
 data PeerAcceptAnnounceKey
 data PeerTraceKey
+data PeerTrace1Key
 data PeerProxyFetchKey
 
 data AcceptAnnounce = AcceptAnnounceAll
@@ -138,6 +139,9 @@ instance Pretty AcceptAnnounce where
 instance HasCfgKey PeerTraceKey FeatureSwitch where
   key = "trace"
 
+instance HasCfgKey PeerTrace1Key FeatureSwitch where
+  key = "trace1"
+
 instance HasCfgKey PeerListenKey (Maybe String) where
   key = "listen"
 
@@ -211,6 +215,7 @@ main = do
   setLogging @NOTICE noticePrefix
 
   setLoggingOff @TRACE
+  setLoggingOff @TRACE1
 
   withSimpleLogger runCLI
 
@@ -459,6 +464,7 @@ runPeer opts = U.handle (\e -> myException e
   let keyConf = cfgValue @PeerKeyFileKey conf
   let storConf = cfgValue @PeerStorageKey conf <&> StoragePrefix
   let traceConf = cfgValue @PeerTraceKey conf :: FeatureSwitch
+  let trace1Conf = cfgValue @PeerTrace1Key conf :: FeatureSwitch
 
   let listenSa = view listenOn opts <|> listenConf <|> Just defListenUDP
   let rpcSa = view listenRpc opts <|> rpcConf <|> Just defRpcUDP
@@ -469,10 +475,14 @@ runPeer opts = U.handle (\e -> myException e
   debug $ "storage prefix:" <+> pretty pref
 
   debug $ pretty "trace: " <+> pretty (show traceConf)
+  debug $ pretty "trace1: " <+> pretty (show trace1Conf)
 
   when (traceConf == FeatureOn) do
     setLogging @TRACE tracePrefix
 
+  when (trace1Conf == FeatureOn) do
+    setLogging @TRACE1 tracePrefix
+
   let bls = cfgValue @PeerBlackListKey conf :: Set String
   let whs = cfgValue @PeerWhiteListKey conf :: Set String
   let toKeys xs = Set.fromList

hbs2-peer/app/PeerTypes.hs

@@ -30,6 +30,7 @@ import HBS2.System.Logger.Simple
 import Brains
 import PeerConfig
 
+import Prelude hiding (log)
 import Data.Foldable (for_)
 import Control.Concurrent.Async
 import Control.Concurrent.STM
@@ -482,3 +483,14 @@ instance (ForGossip e p (PeerM e IO)) => HasGossip e p (PeerM e IO) where
 instance (ForGossip e p (ResponseM e m), HasGossip e p m) => HasGossip e p (ResponseM e m) where
   gossip = lift . gossip
 
+
+data TRACE1
+
+instance HasLogLevel TRACE1 where
+  type instance LogLevel TRACE1 = 101
+
+trace1 :: (MonadIO m, ToLogStr a) => a -> m ()
+trace1 = log @TRACE1
+
+
+

hbs2-peer/app/ProxyMessaging.hs

@@ -19,6 +19,8 @@ import HBS2.Net.Messaging.TCP
 
 import HBS2.System.Logger.Simple
 
+import PeerTypes
+
 import Crypto.Saltine.Class as SCl
 import Crypto.Saltine.Core.Box qualified as Encrypt
 
@@ -142,10 +144,10 @@ sendToProxyMessaging bus t@(To whom) proto msg = do
     mencKey <- liftIO $ _proxy_getEncryptionKey bus whom
     cf <- case mencKey of
         Nothing -> do
-            trace $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom
+            trace1 $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom
             pure id
         Just k -> do
-            trace $ "ENCRYPTION SEND: sending encrypted message to" <+> pretty whom <+> "with key" <+> viaShow k
+            trace1 $ "ENCRYPTION SEND: sending encrypted message to" <+> pretty whom <+> "with key" <+> viaShow k
             boxAfterNMLazy k <$> liftIO Encrypt.newNonce
     sendToPlainProxyMessaging bus t proto (cf msg)
 
@@ -177,7 +179,7 @@ receiveFromProxyMessaging bus _ = liftIO do
       dfm = \whom msg -> liftIO $ _proxy_getEncryptionKey bus whom >>= \case
 
           Nothing -> do
-              trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom
+              trace1 $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom
               liftIO $ _proxy_sendBeginEncryptionExchange bus whom
               pure (Just msg)
 
@@ -189,23 +191,23 @@ receiveFromProxyMessaging bus _ = liftIO do
 
                 liftIO $ _proxy_sendResetEncryptionKeys bus whom
 
-                trace $ "ENCRYPTION RECEIVE: got plain message. clearing key of" <+> pretty whom
+                trace1 $ "ENCRYPTION RECEIVE: got plain message. clearing key of" <+> pretty whom
                 pure msg
                 )) $
             do
               trace $ "ENCRYPTION RECEIVE: we have a key to decode from" <+> pretty whom <+> ":" <+> viaShow k
               case ((extractNonce . cs) msg) of
                   Nothing -> do
-                      trace $ "ENCRYPTION RECEIVE: can not extract nonce from" <+> pretty whom <+> "message" <+> viaShow msg
+                      trace1 $ "ENCRYPTION RECEIVE: can not extract nonce from" <+> pretty whom <+> "message" <+> viaShow msg
                       fail ""
 
                   Just (nonce, msg') ->
                       ((MaybeT . pure) (boxOpenAfterNMLazy k nonce msg')
-                          <* (trace $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom)
+                          <* (trace1 $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom)
                       )
                     <|>
                       (do
-                          (trace $ "ENCRYPTION RECEIVE: can not decode message from" <+> pretty whom)
+                          (trace1 $ "ENCRYPTION RECEIVE: can not decode message from" <+> pretty whom)
                           fail ""
 
                           -- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted