logger fixed

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:

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

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 HBS2.System.Logger.Simple.Class
-import Data.Foldable
+
+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)
+data LoggerEntry =
-loggers = unsafePerformIO (newIORef Nothing)
+  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 program
-  void $ atomicModifyIORef' loggers $ \case
+  lo <- readIORef loggers <&> IntMap.elems
-    Nothing -> (Just set, Just set)
+  for_ lo (flushLogStr . view loggerSet)
-    Just s  -> (Just s, Just s)
-  program
-  withLogger flushLogStr
 
-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
+  lo <- liftIO $ readIORef loggers <&> IntMap.lookup (logKey @a)
-  forM_ lo f
+  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
+debug = log @DEBUG
-  liftIO $ withLogger $ \set -> pushLogStrLn set (toLogStr s)
 
+warn :: (MonadIO m, ToLogStr a) => a -> m ()
+warn = log @WARN
 
-instance {-# OVERLAPPABLE #-} Pretty a => ToLogStr a where
+err :: (MonadIO m, ToLogStr a) => a -> m ()
-  toLogStr p = toLogStr (show (pretty p))
+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)

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
+

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
 

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
+  coo <- async $ do
-    replicateConcurrently_ 1000 do
+    withSimpleLogger do
-      debug $ "DEBUG" <+> pretty 1000
+      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