verbose-debug-log

.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"
+fixme-set "workflow" "backlog" "HcrvggGcAs"
+fixme-set "workflow" "test" "9mDESCSfhG"
+fixme-set "assigned" "voidlizard" "9mDESCSfhG"

docs/devlog.md

@@ -1,6 +1,11 @@
 
 ## 2023-02-25
 
+FIXME: blocks-wip-inconsistency
+  Иногда показывает blocks.wip не равный 0, когда
+  блоки в действительности скачаны.
+  BlockDownload, PeerTypes
+
 FIXME: verbose-debug-log
   Сделать новую секцию для слишком вербозных сообщений.
   Сделать динамическую установку уровня логгирования пира.

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
 

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
 

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
+            trace $ "new burst: " <+> pretty newBurst
-            debug $ "missed chunks for request" <+> pretty (i,chunksN)
+            trace $ "missed chunks for request" <+> pretty (i,chunksN)
-            debug $ "burst time" <+> pretty burstTime
+            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"
+            trace "HASH NOT MATCH / PEER MAYBE JERK"
-            debug "MAYBE THAT PEER IS 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)

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 @ERROR  errorPrefix
-  setLogging @WARN   (set loggerTr ("[warn] " <>))
+  setLogging @WARN   warnPrefix
-  setLogging @NOTICE (set loggerTr ("[notice] " <>))
+  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 ()
 

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
 

hbs2/Main.hs

@@ -417,3 +417,4 @@ main = join . customExecParser (prefs showHelpOnError) $
     pACBDump = do
       f <- optional $ strArgument ( metavar "ACB-FILE-INPUT" )
       pure (runDumpACB f)
+