mirror of https://github.com/voidlizard/hbs2
verbose-debug-log
This commit is contained in:
Dmitry Zuikov
parent
4fd771387b
commit
0ce52cc4ba
|
|
@ -222,3 +222,5 @@ fixme-set "workflow" "wip" "39Fc5R5uXU"
|
|||
fixme-set "assigned" "voidlizard" "39Fc5R5uXU"
|
||||
fixme-set "workflow" "test" "39Fc5R5uXU"
|
||||
fixme-set "workflow" "backlog" "HcrvggGcAs"
|
||||
fixme-set "workflow" "test" "9mDESCSfhG"
|
||||
fixme-set "assigned" "voidlizard" "9mDESCSfhG"
|
||||
|
|
@ -1,6 +1,11 @@
|
|||
|
||||
## 2023-02-25
|
||||
|
||||
FIXME: blocks-wip-inconsistency
|
||||
Иногда показывает blocks.wip не равный 0, когда
|
||||
блоки в действительности скачаны.
|
||||
BlockDownload, PeerTypes
|
||||
|
||||
FIXME: verbose-debug-log
|
||||
Сделать новую секцию для слишком вербозных сообщений.
|
||||
Сделать динамическую установку уровня логгирования пира.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -417,3 +417,4 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
pACBDump = do
|
||||
f <- optional $ strArgument ( metavar "ACB-FILE-INPUT" )
|
||||
pure (runDumpACB f)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue