Merge pull request #3697 from input-output-hk/KtorZ/CO-409/fix-withConfigurations-logging

[CO-409] Fix `withConfigurations` usage of `WithLogger` ==> Allow pure logger to be used.

Author: KtorZ

generator/app/VerificationBench.hs

@@ -38,7 +38,7 @@ import           Pos.Generator.Block (BlockGenParams (..), TxGenParams (..),
                      genBlocks)
 import           Pos.Launcher.Configuration (ConfigurationOptions (..),
                      HasConfigurations, defaultConfigurationOptions,
-                     withConfigurationsM)
+                     withConfigurations)
 import           Pos.Util.CompileInfo (withCompileInfo)
 import           Pos.Util.Log.LoggerConfig (defaultInteractiveConfiguration)
 import           Pos.Util.Util (realTime)
@@ -183,7 +183,7 @@ readBlocks path = do
 
 main :: IO ()
 main = do
-    setupLogging "generator" loggerConfig
+    setupLogging "verification-bench" loggerConfig
     args <- Opts.execParser
         $ Opts.info
             (benchArgsParser <**> Opts.helper)
@@ -198,7 +198,7 @@ main = do
             , cfoSystemStart = Just (Timestamp startTime)
             }
     withCompileInfo $
-        withConfigurationsM "verification-bench" Nothing Nothing False cfo $ \ !genesisConfig !_ !txpConfig !_ -> do
+        withConfigurations Nothing Nothing False cfo $ \ !genesisConfig !_ !txpConfig !_ -> do
             let genesisConfig' = genesisConfig
                     { configProtocolConstants =
                         (configProtocolConstants genesisConfig) { pcK = baK args }

generator/bench/Bench/Pos/Criterion/Block/Logic.hs

@@ -38,9 +38,11 @@ import           Pos.Generator.Block (BlockGenParams (..), TxGenParams (..),
                      genBlockNoApply, genBlocks, mkBlockGenContext)
 import           Pos.Launcher.Configuration (ConfigurationOptions (..),
                      HasConfigurations, defaultConfigurationOptions,
-                     withConfigurationsM)
+                     withConfigurations)
 import           Pos.Util.CompileInfo (withCompileInfo)
+import           Pos.Util.Log.LoggerConfig (defaultInteractiveConfiguration)
 import           Pos.Util.Util (realTime)
+import           Pos.Util.Wlog (Severity (Debug), setupLogging)
 
 import           Test.Pos.Block.Logic.Emulation (runEmulation, sudoLiftIO)
 import           Test.Pos.Block.Logic.Mode (BlockTestContext, BlockTestMode,
@@ -220,14 +222,16 @@ verifyHeaderBenchmark !genesisConfig !secretKeys !tp = env (runBlockTestMode gen
 
 runBenchmark :: IO ()
 runBenchmark = do
+    let loggerConfig = defaultInteractiveConfiguration Debug
+    setupLogging "verifyBenchmark" loggerConfig
     startTime <- realTime
     let cfo = defaultConfigurationOptions
             { cfoFilePath = "../lib/configuration.yaml"
             , cfoKey = "bench-validation"
             , cfoSystemStart = Just (Timestamp startTime)
             }
     withCompileInfo
-        $ withConfigurationsM "verifyBenchmark" Nothing Nothing False cfo
+        $ withConfigurations Nothing Nothing False cfo
         $ \genesisConfig _ txpConfig _ -> do
             let tp = TestParams
                     { _tpStartTime = Timestamp (convertUnit startTime)

lib/src/Pos/Launcher/Configuration.hs

@@ -23,7 +23,6 @@ module Pos.Launcher.Configuration
 
        -- Exposed mostly for testing.
        , readAssetLockedSrcAddrs
-       , withConfigurationsM
        ) where
 
 import           Universum
@@ -53,8 +52,7 @@ import           Pos.Core.Conc (currentTime)
 import           Pos.Core.Slotting (Timestamp (..))
 import           Pos.Util.AssertMode (inAssertMode)
 import           Pos.Util.Config (parseYamlConfig)
-import           Pos.Util.Wlog (LoggerName, WithLogger, askLoggerName, logInfo,
-                     usingLoggerName)
+import           Pos.Util.Wlog (WithLogger, logInfo)
 
 import           Pos.Chain.Block
 import           Pos.Chain.Delegation
@@ -174,17 +172,16 @@ instance Default ConfigurationOptions where
 
 -- | Parse some big yaml file to 'MultiConfiguration' and then use the
 -- configuration at a given key.
-withConfigurationsM
-    :: forall m r. (MonadThrow m, MonadIO m)
-    => LoggerName
-    -> Maybe AssetLockPath
+withConfigurations
+    :: (WithLogger m, MonadThrow m, MonadIO m)
+    => Maybe AssetLockPath
     -> Maybe FilePath
     -> Bool
     -> ConfigurationOptions
     -> (HasConfigurations => Genesis.Config -> WalletConfiguration -> TxpConfiguration -> NtpConfiguration -> m r)
     -> m r
-withConfigurationsM logName mAssetLockPath dumpGenesisPath dumpConfig cfo act = do
-    logInfo' ("using configurations: " <> show cfo)
+withConfigurations mAssetLockPath dumpGenesisPath dumpConfig cfo act = do
+    logInfo ("using configurations: " <> show cfo)
     cfg <- parseYamlConfig (cfoFilePath cfo) (cfoKey cfo)
     assetLock <- case mAssetLockPath of
         Nothing -> pure mempty
@@ -201,7 +198,7 @@ withConfigurationsM logName mAssetLockPath dumpGenesisPath dumpConfig cfo act =
         withBlockConfiguration (ccBlock cfg) $
         withNodeConfiguration (ccNode cfg) $ do
             let txpConfig = addAssetLock assetLock $ ccTxp cfg
-            liftIO . usingLoggerName logName $ printInfoOnStart
+            printInfoOnStart
                 dumpGenesisPath
                 dumpConfig
                 (configGenesisData genesisConfig)
@@ -211,28 +208,6 @@ withConfigurationsM logName mAssetLockPath dumpGenesisPath dumpConfig cfo act =
                 txpConfig
             act genesisConfig (ccWallet cfg) txpConfig (ccNtp cfg)
 
-    where
-    logInfo' :: Text -> m ()
-    logInfo' = liftIO . usingLoggerName logName . logInfo
-
-withConfigurations
-    :: (WithLogger m, MonadThrow m, MonadIO m)
-    => Maybe AssetLockPath
-    -> Maybe FilePath
-    -> Bool
-    -> ConfigurationOptions
-    -> (HasConfigurations => Genesis.Config-> WalletConfiguration -> TxpConfiguration -> NtpConfiguration -> m r)
-    -> m r
-withConfigurations mAssetLockPath dumpGenesisPath dumpConfig cfo act = do
-    loggerName <- askLoggerName
-    withConfigurationsM
-        loggerName
-        mAssetLockPath
-        dumpGenesisPath
-        dumpConfig
-        cfo
-        act
-
 addAssetLock :: Set Address -> TxpConfiguration -> TxpConfiguration
 addAssetLock bset tcfg =
     tcfg { tcAssetLockedSrcAddrs = Set.union (tcAssetLockedSrcAddrs tcfg) bset }

lib/test/Test/Pos/Launcher/ConfigurationSpec.hs

@@ -9,15 +9,15 @@ import           Test.Hspec (Spec, describe, it, shouldSatisfy)
 
 import           Pos.Core.Slotting (Timestamp (..))
 import           Pos.Launcher.Configuration (ConfigurationOptions (..),
-                     defaultConfigurationOptions, withConfigurationsM)
+                     defaultConfigurationOptions, withConfigurations)
 import           Pos.Util.Config (ConfigurationException)
 import           Pos.Util.Wlog (setupTestLogging)
 
 spec :: Spec
 spec = describe "Pos.Launcher.Configuration" $ do
-    describe "withConfigurationsM" $ do
+    describe "withConfigurations" $ do
         it "should parse `lib/configuration.yaml` file" $ do
-            liftIO $ setupTestLogging
+            liftIO setupTestLogging
             startTime <- Timestamp . round . (* 1000000) <$> liftIO getPOSIXTime
             let cfo = defaultConfigurationOptions
                         { cfoFilePath = "./configuration.yaml"
@@ -26,6 +26,6 @@ spec = describe "Pos.Launcher.Configuration" $ do
             let catchFn :: ConfigurationException -> IO (Maybe ConfigurationException)
                 catchFn e = return $ Just e
             res  <- liftIO $ catch
-                (withConfigurationsM "test" Nothing Nothing False cfo (\_ _ _ _ -> return Nothing))
+                (withConfigurations Nothing Nothing False cfo (\_ _ _ _ -> return Nothing))
                 catchFn
             res `shouldSatisfy` isNothing

util/src/Pos/Util/Wlog/Compatibility.hs

@@ -32,6 +32,7 @@ module Pos.Util.Wlog.Compatibility
            -- * Named Pure logging
          , NamedPureLogger (..)
          , launchNamedPureLog
+         , usingNamedPureLogger
          , runNamedPureLog
            -- * reimplementations
          , removeAllHandlers
@@ -219,6 +220,8 @@ instance Monad m => CanLog (NamedPureLogger m) where
         NamedPureLogger $ dispatchMessage name sev msg
 instance MFunctor NamedPureLogger where
     hoist f = NamedPureLogger . hoist (hoist f) . runNamedPureLogger
+instance MonadIO m => MonadIO (NamedPureLogger m) where
+    liftIO = lift . liftIO
 
 runNamedPureLog
     :: (Monad m, HasLoggerName m)