From 0ce52cc4baecd2173a4a4a04e578a3eb689d9a88 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sat, 25 Feb 2023 09:15:09 +0300 Subject: [PATCH] verbose-debug-log --- .fixme/log | 4 +- docs/devlog.md | 5 ++ hbs2-core/lib/HBS2/System/Logger/Simple.hs | 21 +++++- .../lib/HBS2/System/Logger/Simple/Class.hs | 14 ++-- hbs2-peer/app/BlockDownload.hs | 24 +++---- hbs2-peer/app/PeerMain.hs | 65 +++++++++++++++++-- hbs2-peer/app/RPC.hs | 10 +++ hbs2/Main.hs | 1 + 8 files changed, 116 insertions(+), 28 deletions(-) diff --git a/.fixme/log b/.fixme/log index d413e4aa..ca03f063 100644 --- a/.fixme/log +++ b/.fixme/log @@ -221,4 +221,6 @@ fixme-set "workflow" "test" "BhME2nDpbd" fixme-set "workflow" "wip" "39Fc5R5uXU" fixme-set "assigned" "voidlizard" "39Fc5R5uXU" fixme-set "workflow" "test" "39Fc5R5uXU" -fixme-set "workflow" "backlog" "HcrvggGcAs" \ No newline at end of file +fixme-set "workflow" "backlog" "HcrvggGcAs" +fixme-set "workflow" "test" "9mDESCSfhG" +fixme-set "assigned" "voidlizard" "9mDESCSfhG" \ No newline at end of file diff --git a/docs/devlog.md b/docs/devlog.md index 02c93397..0b27109d 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -1,6 +1,11 @@ ## 2023-02-25 +FIXME: blocks-wip-inconsistency + Иногда показывает blocks.wip не равный 0, когда + блоки в действительности скачаны. + BlockDownload, PeerTypes + FIXME: verbose-debug-log Сделать новую секцию для слишком вербозных сообщений. Сделать динамическую установку уровня логгирования пира. diff --git a/hbs2-core/lib/HBS2/System/Logger/Simple.hs b/hbs2-core/lib/HBS2/System/Logger/Simple.hs index 5e550c6d..219130f8 100644 --- a/hbs2-core/lib/HBS2/System/Logger/Simple.hs +++ b/hbs2-core/lib/HBS2/System/Logger/Simple.hs @@ -5,6 +5,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module HBS2.System.Logger.Simple ( withSimpleLogger + , trace , debug , log , err @@ -14,6 +15,7 @@ module HBS2.System.Logger.Simple , setLogging, setLoggingOff , defLog , loggerTr + , SetLoggerEntry , module HBS2.System.Logger.Simple.Class ) where @@ -53,6 +55,14 @@ withSimpleLogger program = do lo <- readIORef loggers <&> IntMap.elems for_ lo (flushLogStr . view loggerSet) +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 + setLogging :: forall a m . (MonadIO m, HasLogLevel a) => (LoggerEntry -> LoggerEntry) -> m () @@ -61,13 +71,14 @@ 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, ())) - + e <- liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.insert key def x, IntMap.lookup key x)) + delLogger e setLoggingOff :: forall a m . (MonadIO m, HasLogLevel a) => m () setLoggingOff = do let key = logKey @a - void $ liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.delete key x, IntMap.lookup key x)) + e <- liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.delete key x, IntMap.lookup key x)) + delLogger e withLogger :: forall a m . (HasLogLevel a, MonadIO m) => (LoggerEntry -> m ()) -> m () withLogger f = do @@ -79,6 +90,10 @@ log s = liftIO $ withLogger @a $ \le -> pushLogStrLn (view loggerSet le) (view loggerTr le (toLogStr s)) + +trace :: (MonadIO m, ToLogStr a) => a -> m () +trace = log @TRACE + debug :: (MonadIO m, ToLogStr a) => a -> m () debug = log @DEBUG diff --git a/hbs2-core/lib/HBS2/System/Logger/Simple/Class.hs b/hbs2-core/lib/HBS2/System/Logger/Simple/Class.hs index aa21b437..ae454289 100644 --- a/hbs2-core/lib/HBS2/System/Logger/Simple/Class.hs +++ b/hbs2-core/lib/HBS2/System/Logger/Simple/Class.hs @@ -12,26 +12,28 @@ class KnownNat (LogLevel p) => HasLogLevel p where logKey :: Int logKey = fromIntegral $ natVal (Proxy :: Proxy (LogLevel p)) +data TRACE data DEBUG data INFO data ERROR data WARN data NOTICE +instance HasLogLevel TRACE where + type instance LogLevel TRACE = 1 instance HasLogLevel DEBUG where - type instance LogLevel DEBUG = 0 + type instance LogLevel DEBUG = 2 instance HasLogLevel INFO where - type instance LogLevel INFO = 1 - + type instance LogLevel INFO = 3 instance HasLogLevel ERROR where - type instance LogLevel ERROR = 2 + type instance LogLevel ERROR = 4 instance HasLogLevel WARN where - type instance LogLevel WARN = 3 + type instance LogLevel WARN = 5 instance HasLogLevel NOTICE where - type instance LogLevel NOTICE = 4 + type instance LogLevel NOTICE = 6 diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index 9fc45e29..c0330850 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -240,9 +240,9 @@ downloadFromWithPeer peer thisBkSize h = do liftIO $ atomically $ modifyTVar (view peerErrors pinfo) succ - debug $ "new burst: " <+> pretty newBurst - debug $ "missed chunks for request" <+> pretty (i,chunksN) - debug $ "burst time" <+> pretty burstTime + trace $ "new burst: " <+> pretty newBurst + trace $ "missed chunks for request" <+> pretty (i,chunksN) + trace $ "burst time" <+> pretty burstTime for_ chuchu $ liftIO . atomically . writeTQueue rq @@ -266,11 +266,10 @@ downloadFromWithPeer peer thisBkSize h = do void $ liftIO $ putBlock sto block void $ processBlock h else do - debug "HASH NOT MATCH" - debug "MAYBE THAT PEER IS JERK" + trace "HASH NOT MATCH / PEER MAYBE JERK" else do - debug "RETRY BLOCK DOWNLOADING / ASK FOR MISSED CHUNKS" + trace "RETRY BLOCK DOWNLOADING / ASK FOR MISSED CHUNKS" got <- liftIO $ readTVarIO r <&> IntMap.keysSet let need = IntSet.fromList (fmap fromIntegral chunkNums) @@ -415,7 +414,7 @@ blockDownloadLoop env0 = do fails <- liftIO $ readTVarIO (view peerDownloadFail pinfo) when (fails >= defDownloadFails) do - warn $ "peer" <+> pretty p <+> "has too many failures:" <+> pretty fails + trace $ "peer" <+> pretty p <+> "has too many failures:" <+> pretty fails here <- withDownload env0 $ hasPeerThread p @@ -494,7 +493,7 @@ blockDownloadLoop env0 = do liftIO $ atomically $ writeTVar tinfo alive - debug $ "maintain blocks wip" <+> pretty (Set.size aliveWip) + notice $ "maintain blocks wip" <+> pretty (Set.size aliveWip) withDownload env0 do @@ -537,9 +536,6 @@ peerDownloadLoop peer = do let downBlk = view peerDownloadedBlk pinfo failNum <- liftIO $ readTVarIO downFail - -- FIXME: failNum-to-defaults - let notFailed = failNum < defDownloadFails - -- FIXME: better-avoiding-busyloop -- unless notFailed do -- pause @'Seconds 1 @@ -566,7 +562,7 @@ peerDownloadLoop peer = do let seenTotal = view bsTimes st let wa = min defBlockBanTimeSec (realToFrac (ceiling $ Prelude.logBase 10 (realToFrac (50 * seenTotal)))) void $ liftIO $ async $ withAllStuff (pause wa >> addDownload h) - debug $ "block" <+> pretty h <+> "seen" <+> pretty seenTotal <+> "times" <+> parens (pretty wa) + trace $ "block" <+> pretty h <+> "seen" <+> pretty seenTotal <+> "times" <+> parens (pretty wa) else do liftIO $ atomically $ modifyTVar seenBlocks (HashMap.alter alterSeen h) @@ -574,7 +570,7 @@ peerDownloadLoop peer = do seenTimes <- liftIO $ readTVarIO seenBlocks <&> fromMaybe 0 . HashMap.lookup h when ( seenTimes > 1 ) do - debug $ "ban block" <+> pretty h <+> "for a while" <+> parens (pretty seenTimes) + trace $ "ban block" <+> pretty h <+> "for a while" <+> parens (pretty seenTimes) liftIO $ atomically $ modifyTVar seenBlocks (HashMap.delete h) liftIO $ Cache.insert bannedBlocks h () @@ -586,7 +582,7 @@ peerDownloadLoop peer = do (BlockSizeEvent (_,_,s)) -> do liftIO $ atomically $ writeTQueue blksq (Just s) (NoBlockEvent p) -> do - debug $ "NoBlockEvent" <+> pretty p <+> pretty h + trace $ "NoBlockEvent" <+> pretty p <+> pretty h liftIO $ atomically $ writeTQueue blksq Nothing request peer (GetBlockSize @e h) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 550cbadd..bf24b8e5 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -127,6 +127,7 @@ data RPCOpt = makeLenses 'RPCOpt + data RPCCommand = POKE | ANNOUNCE (Hash HbSync) @@ -134,6 +135,7 @@ data RPCCommand = | CHECK PeerNonce (PeerAddr UDP) (Hash HbSync) | FETCH (Hash HbSync) | PEERS + | SETLOG SetLogging data PeerOpts = PeerOpts @@ -147,17 +149,35 @@ data PeerOpts = makeLenses 'PeerOpts +logPrefix s = set loggerTr (s <>) + +tracePrefix :: SetLoggerEntry +tracePrefix = logPrefix "[trace] " + +debugPrefix :: SetLoggerEntry +debugPrefix = logPrefix "[debug] " + +errorPrefix :: SetLoggerEntry +errorPrefix = logPrefix "[error] " + +warnPrefix :: SetLoggerEntry +warnPrefix = logPrefix "[warn] " + +noticePrefix :: SetLoggerEntry +noticePrefix = logPrefix "[notice] " main :: IO () main = do sodiumInit - setLogging @DEBUG (set loggerTr ("[debug] " <>)) + setLogging @DEBUG debugPrefix setLogging @INFO defLog - setLogging @ERROR (set loggerTr ("[error] " <>)) - setLogging @WARN (set loggerTr ("[warn] " <>)) - setLogging @NOTICE (set loggerTr ("[notice] " <>)) + setLogging @ERROR errorPrefix + setLogging @WARN warnPrefix + setLogging @NOTICE noticePrefix + + setLoggingOff @TRACE withSimpleLogger runCLI @@ -177,6 +197,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ <> command "ping" (info pPing (progDesc "ping another peer")) <> command "fetch" (info pFetch (progDesc "fetch block")) <> command "peers" (info pPeers (progDesc "show known peers")) + <> command "log" (info pLog (progDesc "set logging level")) ) confOpt = strOption ( long "config" <> short 'c' <> help "config" ) @@ -231,10 +252,23 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ rpc <- pRpcCommon pure $ runRpcCommand rpc PEERS + onOff l = + hsubparser ( command "on" (info (pure (l True) ) (progDesc "on") ) ) + <|> hsubparser ( command "off" (info (pure (l False) ) (progDesc "off") ) ) + + pLog = do + rpc <- pRpcCommon + setlog <- SETLOG <$> ( hsubparser ( command "trace" (info (onOff TraceOn) (progDesc "set trace") ) ) + <|> + hsubparser ( command "debug" (info (onOff DebugOn) (progDesc "set debug") ) ) + ) + pure $ runRpcCommand rpc setlog + pInit = do pref <- optional $ strArgument ( metavar "DIR" ) pure $ peerConfigInit pref + myException :: SomeException -> IO () myException e = die ( show e ) >> exitFailure @@ -611,6 +645,23 @@ runPeer opts = Exception.handle myException $ do let k = view peerSignKey pd request who (RPCPeersAnswer @e pa k) + let logLevelAction = \case + DebugOn True -> do + setLogging @DEBUG debugPrefix + debug "DebugOn" + + DebugOn False -> do + debug "DebugOff" + setLoggingOff @DEBUG + + TraceOn True -> do + setLogging @TRACE tracePrefix + trace "TraceOn" + + TraceOn False -> do + trace "TraceOff" + setLoggingOff @TRACE + let arpc = RpcAdapter pokeAction dontHandle annAction @@ -619,6 +670,7 @@ runPeer opts = Exception.handle myException $ do fetchAction peersAction dontHandle + logLevelAction rpc <- async $ runRPC udp1 do runProto @e @@ -720,6 +772,8 @@ withRPC o cmd = do pause @'Seconds 1 exitSuccess + RPCLogLevel{} -> liftIO exitSuccess + _ -> pure () void $ liftIO $ waitAnyCatchCancel [proto] @@ -738,6 +792,8 @@ withRPC o cmd = do (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa ) + dontHandle + runRpcCommand :: RPCOpt -> RPCCommand -> IO () runRpcCommand opt = \case POKE -> withRPC opt RPCPoke @@ -745,6 +801,7 @@ runRpcCommand opt = \case ANNOUNCE h -> withRPC opt (RPCAnnounce h) FETCH h -> withRPC opt (RPCFetch h) PEERS -> withRPC opt RPCPeers + SETLOG s -> withRPC opt (RPCLogLevel s) _ -> pure () diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index a345f7bd..c99bad38 100644 --- a/hbs2-peer/app/RPC.hs +++ b/hbs2-peer/app/RPC.hs @@ -15,6 +15,13 @@ import Data.ByteString.Lazy (ByteString) import Codec.Serialise (serialise,deserialiseOrFail) import Lens.Micro.Platform +data SetLogging = + DebugOn Bool + | TraceOn Bool + deriving (Generic,Eq,Show) + +instance Serialise SetLogging + data RPC e = RPCPoke | RPCPing (PeerAddr e) @@ -24,6 +31,7 @@ data RPC e = | RPCFetch (Hash HbSync) | RPCPeers | RPCPeersAnswer (PeerAddr e) (PubKey 'Sign e) + | RPCLogLevel SetLogging deriving stock (Generic) @@ -54,6 +62,7 @@ data RpcAdapter e m = , rpcOnFetch :: Hash HbSync -> m () , rpcOnPeers :: RPC e -> m () , rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign e) -> m () + , rpcOnLogLevel :: SetLogging -> m () } newtype RpcM m a = RpcM { fromRpcM :: ReaderT RPCEnv m a } @@ -102,4 +111,5 @@ rpcHandler adapter = \case (RPCFetch h) -> rpcOnFetch adapter h p@RPCPeers{} -> rpcOnPeers adapter p (RPCPeersAnswer pa k) -> rpcOnPeersAnswer adapter (pa,k) + (RPCLogLevel l) -> rpcOnLogLevel adapter l diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 4ae1a90b..75753377 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -417,3 +417,4 @@ main = join . customExecParser (prefs showHelpOnError) $ pACBDump = do f <- optional $ strArgument ( metavar "ACB-FILE-INPUT" ) pure (runDumpACB f) +