still more debug output

bench/tx-generator/src/Cardano/Benchmarking/Command.hs

@@ -38,17 +38,16 @@ import qualified Cardano.TxGenerator.Setup.NixService as NixService (getNodeConf
 import           Cardano.TxGenerator.Setup.NodeConfig (NodeConfiguration (..))
 import qualified Cardano.TxGenerator.Setup.NodeConfig as NodeConfig (getGenesisDirectory, mkNodeConfig)
 import           Cardano.TxGenerator.Types (TxGenError (..), TxGenPlutusParams (..), TxGenGovActParams (..))
-import           Cardano.TxGenerator.Utils (putMsg)
+import           Cardano.TxGenerator.Utils (putMsg, putMsgBSL)
 import           Data.Aeson (fromJSON)
 import qualified Data.ByteString.Char8 as BSC (unpack)
-import           Data.ByteString.Lazy as BSL
+import           Data.Either.Combinators (whenLeft)
 import           Data.Either.Extra (eitherToMaybe)
-import           Data.Foldable (for_)
 import           Data.List (genericLength)
 import           Data.Maybe (catMaybes)
 import           Data.Text as T
 import           Data.Text.IO as T
-import           Data.Tuple.Ops (sel4)
+import           Data.Tuple.Ops (sel4, uncurryT)
 import           Options.Applicative as Opt
 import           Ouroboros.Network.NodeToClient (IOManager, withIOManager)
 
@@ -69,7 +68,7 @@ import           Control.Monad.Extra (whenJustM)
 import           Control.Monad.IO.Class (liftIO)
 import qualified Control.Monad.Logger as Logger (LogLine, fromLogStr)
 import qualified Control.Monad.STM as STM (atomically)
-import qualified Data.Foldable as Fold (forM_)
+import qualified Data.Foldable as Fold (foldr1, forM_)
 import qualified Data.List as List (intercalate, unwords)
 import qualified Data.Time.Format as Time (defaultTimeLocale, formatTime)
 import qualified Data.Time.Clock.System as Time (getSystemTime, systemToUTCTime)
@@ -216,40 +215,42 @@ runCommand' iocp = do
                    _ -> pure (finalOpts, consts)
               | otherwise -> pure (finalOpts, consts)
 
-      Prelude.putStrLn $
-          "--> initial options:\n" ++ show opts ++
-        "\n--> final options:\n" ++ show finalOpts'
+      putMsg $ Prelude.unlines
+        [ "--> initial options:"
+        , show opts
+        , "--> final options:"
+        , show finalOpts' ]
 
-      Prelude.putStrLn "quickTestPlutusOrDie"
+      putMsg "quickTestPlutusOrDie"
       quickTestPlutusDataOrDie finalOpts'
 
-      Prelude.putStrLn "debugDumpProposalsPeriodically"
+      putMsg "debugDumpProposalsPeriodically"
       debugDumpProposalsPeriodically finalOpts'
 
       case compileOptions finalOpts' of
         (Right script, logLines) -> do
-          Prelude.putStrLn "before runScript"
+          putMsg "before runScript"
           runScript emptyEnv script consts' >>= handleError . fst
-          Prelude.putStrLn "after runScript"
+          putMsg "after runScript"
           Fold.forM_ logLines \(viewLogLine -> ell) ->
-            Prelude.putStrLn $ "compile (success) log: " <> ell
+            putMsg $ "compile (success) log: " <> ell
         (Left err, logLines) -> do
-          Prelude.putStrLn "compileOptions failed, log dump:"
+          putMsg "compileOptions failed, log dump:"
           Fold.forM_ logLines \(viewLogLine -> ell) ->
-            Prelude.putStrLn $ "compile (failure) log: " <> ell
+            putMsg $ "compile (failure) log: " <> ell
           die $
             "tx-generator:Cardano.Command.runCommand JsonHL: " ++ show err
     Compile file -> do
       putMsg $ "case Compile " <> show file
       o <- parseJSONFile fromJSON file
       case compileOptions o of
         (Right script, logLines) -> do
-          BSL.putStr $ prettyPrint script
+          putMsgBSL $ prettyPrint script
           Fold.forM_ logLines \(viewLogLine -> ell) ->
-            Prelude.putStrLn $ "compile (success) log: " <> ell
+            putMsg $ "compile (success) log: " <> ell
         (Left err, logLines) -> do
           Fold.forM_ logLines \(viewLogLine -> ell) ->
-            Prelude.putStrLn $ "compile (failure) log: " <> ell
+            putMsg $ "compile (failure) log: " <> ell
           die $
             "tx-generator:Cardano.Command.runCommand Compile: " ++ show err
     Selftest doVoting outFile -> do
@@ -296,12 +297,12 @@ signalHandler wkMainTID EnvConsts {..} sigInfo = do
                                , "received signal"
                                , show sigInfo ]
 
-  Prelude.putStrLn labelStr
+  putMsg labelStr
   traceWith' labelStr
   getThreads >>= \case
-    Nothing -> Prelude.putStrLn "no thread list available"
+    Nothing -> putMsg "no thread list available"
     Just threadList ->
-      Prelude.putStrLn $ "thread list: "
+      putMsg $ "thread list: "
                       <> List.intercalate ", " (Prelude.map show threadList)
   STM.atomically (STM.readTVar envThreads) >>= \case
     Nothing
@@ -310,17 +311,17 @@ signalHandler wkMainTID EnvConsts {..} sigInfo = do
       -- this pursues some alternatives.
       | errMsg <- "Signal received before "
                <> "AsyncBenchmarkControl creation."
-      -> do Prelude.putStrLn errMsg
+      -> do putMsg errMsg
             traceWith' errMsg
     Just AsyncBenchmarkControl { .. }
       | errorToThrow <- userError labelStr
       , errMsg <- "Signal received after "
                <> "AsyncBenchmarkControl creation."
-      -> do Prelude.putStrLn errMsg
+      -> do putMsg errMsg
             traceWith' errMsg
             abcFeeder `Async.cancelWith` errorToThrow
             Fold.forM_ abcWorkers \work -> do
-              Prelude.putStrLn . List.unwords $
+              putMsg . List.unwords $
                 [ show $ Async.asyncThreadId work
                 , "(placeholder for add'l info to be retrieved)"]
               work `Async.cancelWith` errorToThrow
@@ -356,45 +357,52 @@ installSignalHandler iocp = STM.atomically $ newEnvConsts iocp Nothing
 #endif
 
 mangleNodeConfig :: Maybe FilePath -> NixServiceOptions -> IO NixServiceOptions
-mangleNodeConfig fp opts = case (NixService.getNodeConfigFile opts, fp) of
-  (_      , Just newFilePath) -> pure $ NixService.setNodeConfigFile opts newFilePath
-  (Just _ , Nothing) -> return opts
-  (Nothing, Nothing) -> die "No node-configFile set"
+mangleNodeConfig fp opts
+  | Just newFilePath <- fp
+  = pure $ NixService.setNodeConfigFile opts newFilePath
+  | Just _ <- NixService.getNodeConfigFile opts
+  = pure opts
+  | otherwise
+  = die "No node-configFile set"
 
 mangleTracerConfig ::  Maybe FilePath -> NixServiceOptions -> NixServiceOptions
-mangleTracerConfig traceSocket opts
-  = opts { _nix_cardanoTracerSocket = traceSocket <> _nix_cardanoTracerSocket opts}
+mangleTracerConfig traceSocket opts@NixServiceOptions {..} =
+  opts { _nix_cardanoTracerSocket = traceSocket <> _nix_cardanoTracerSocket }
 
--- if there's a parsing error wrt. ScriptData, we want to fail early, before the splitting phase
+-- If there's a parsing error wrt. ScriptData, we want to fail early,
+-- before the splitting phase
 quickTestPlutusDataOrDie :: NixServiceOptions -> IO ()
-quickTestPlutusDataOrDie NixServiceOptions{_nix_plutus} = do
-  for_ files test
-  Prelude.putStrLn $
-    "--> success: quickTestPlutusDataOrDie " ++ show files
+quickTestPlutusDataOrDie NixServiceOptions{..}
+  | Just PlutusOn {..} <- _nix_plutus
+  , files@(_:_) <- catMaybes [plutusDatum, plutusRedeemer]
+  = do Fold.forM_ files \file -> do
+         whenLeftM (readScriptData file) \err -> do
+           die $ fname <> "(" <> file <> "): " <> show err
+       putMsg $ pfx <> show files
+  | otherwise
+  = putMsg $ pfx <> "(PlutusOff case)"
   where
-    test file =
-      readScriptData file >>= \case
-        Left err -> die $ "quickTestPlutusDataOrDie (" ++ file ++ "): " ++ show err
-        Right{}  -> pure ()
-
-    files = case _nix_plutus of
-      Just PlutusOn{plutusDatum, plutusRedeemer}  -> catMaybes [plutusDatum, plutusRedeemer]
-      _ -> []
+    fname = "quickTestPlutusDataOrDie "
+    pfx = "--> success: " <> fname
+    whenLeftM me f = do
+      e <- me
+      whenLeft e f
 
 commandParser :: Parser Command
-commandParser
-  = subparser (
-       cmdParser "json" jsonCmd "Run a generic benchmarking script."
-    <> cmdParser "json_highlevel" jsonHLCmd "Run the tx-generator using a flat config."
-    <> cmdParser "compile" compileCmd "Compile flat-options to benchmarking script."
-    <> cmdParser "selftest" selfTestCmd "Run a built-in selftest."
-    <> cmdParser "version" versionCmd "Show the tx-generator version"
-       )
+commandParser = subparser . Fold.foldr1 (<>) $ uncurryT cmdParser <$>
+  [ ("json", jsonCmd, "Run a generic benchmarking script.")
+  , ("json_highlevel", jsonHLCmd, "Run the tx-generator using a flat config.")
+  , ("compile", compileCmd, "Compile flat-options to benchmarking script.")
+  , ("selftest", selfTestCmd, "Run a built-in selftest.")
+  , ("version", versionCmd, "Show the tx-generator version")]
  where
-  cmdParser cmd parser description = command cmd $ info (parser <**> helper) $ progDesc description
+  cmdParser :: String -> Parser Command -> String -> Mod CommandFields Command
+  cmdParser cmd parser description =
+    command cmd $ info (parser <**> helper) $ progDesc description
 
   filePath :: String -> Parser String
-  filePath helpMsg = strArgument (metavar "FILE" <> completer (bashCompleter "file") <> help helpMsg)
+  filePath helpMsg = strArgument $
+    metavar "FILE" <> completer (bashCompleter "file") <> help helpMsg
 
   jsonCmd :: Parser Command
   jsonCmd = Json <$> filePath "low-level benchmarking script"

bench/tx-generator/src/Cardano/Benchmarking/Compiler.hs

@@ -28,9 +28,7 @@ import           Prelude
 import           Control.Monad
 import           Control.Monad.Extra
 import           Control.Monad.Logger (LogLine, WriterLoggingT (..))
-import qualified Control.Monad.Logger as Logger (runWriterLoggingT)
--- import           Control.Monad.Logger.Prefix (LogPrefixT (..))
--- import qualified Control.Monad.Logger.Prefix as Logger (prefixLogs)
+import qualified Control.Monad.Logger as Logger (logDebugN, runWriterLoggingT)
 import           Control.Monad.Trans.RWS.CPS
 import           Data.Bifunctor (second)
 import           Data.ByteString as BS (ByteString)
@@ -51,7 +49,6 @@ data CompileError where
 -- | Why was `Compiler` originally written to nest this way with `Except` ?
 -- type Compiler a = RWST NixServiceOptions (DList Action) Int (Except CompileError) a
 
--- type CompilerInnerM = LogPrefixT (WriterLoggingT Identity)
 type CompilerInnerM = WriterLoggingT Identity
 type CompilerRWST = RWST NixServiceOptions (DList Action) Int CompilerInnerM
 type Compiler a = ExceptT CompileError CompilerRWST a
@@ -86,7 +83,7 @@ testCompiler nixSvcOpts compilerScript
   = second (, counter, DL.toList actions) status
 
 compileToScript :: Compiler ()
-compileToScript = {- Logger.prefixLogs "compileToScript" <$$> -} do
+compileToScript = do
   traceM "entered, about to initConstants"
   initConstants
   "initConstants" `traceBetween` "askNixOption getNodeConfigFile"
@@ -102,6 +99,9 @@ compileToScript = {- Logger.prefixLogs "compileToScript" <$$> -} do
   "emit StartProtocol" `traceBetween`
     "whenJustM askNixOption txGenGovActParams"
 
+  traceM "scrutinizing askNixOption txGenGovActParams"
+  whenM ((== Nothing) <$> askNixOption txGenGovActParams) do
+    traceM "askNixOption txGenGovActParams == pure Nothing"
   whenJustM (askNixOption txGenGovActParams) \TxGenGovActParams {} -> do
     traceM $ "inside whenJustM askNixOption txGenGovActParams, "
           <> "about to emit ReadDRepKeys"
@@ -138,7 +138,9 @@ mkTraceFuncs scopeTag
   | mkS' <- ((scopeTag <> ": ") <>)
   , traceM <- \(mkS' -> s) -> do
       Debug.traceM s
-      emit . LogMsg $ Text.pack s
+      let s' = Text.pack s
+      lift . lift $ Logger.logDebugN s'
+      emit $ LogMsg s'
   , traceBetween
       <- \f g -> traceM $ "back from " <> f <> " about to " <> g
   = DebugTraceFuncs {..}
@@ -198,11 +200,8 @@ infixr 8 <$$>
 (<$$>) :: (Functor f, Functor g) => (t -> t') -> f (g t) -> f (g t')
 f <$$> x = fmap f <$> x
 
--- infixr 8 <$$$>
--- f <$$$> x = fmap f <$$> x
-
 splittingPhase :: SrcWallet -> Compiler DstWallet
-splittingPhase srcWallet = {- Logger.prefixLogs "splittingPhase" <$$> -} do
+splittingPhase srcWallet = do
   traceM $ "entering for srcWallet = " <> srcWallet
   tx_count <- askNixOption _nix_tx_count
   inputs_per_tx <- askNixOption _nix_inputs_per_tx

bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs

@@ -33,6 +33,7 @@ import           Cardano.Node.Configuration.NodeAddress
 import           Cardano.Prelude
 import           Cardano.TxGenerator.Setup.NixService as Nix (NodeDescription (..))
 import           Cardano.TxGenerator.Types (NumberOfTxs, TPSRate, TxGenError (..))
+import           Cardano.TxGenerator.Utils (disableBuffering, putMsg)
 
 import           Prelude (String)
 
@@ -42,12 +43,13 @@ import qualified Control.Concurrent.STM.TMVar as STM (newEmptyTMVar)
 import qualified Control.Monad.STM as STM (atomically)
 import qualified Data.List as List (unwords)
 import qualified Data.List.NonEmpty as NE
+import           Data.Maybe (fromJust)
 import           Data.Text (pack)
 import qualified Data.Time.Clock as Clock
+import qualified Data.Traversable as Trav (sequence)
 import           Data.Tuple.Extra (secondM)
 import qualified GHC.Conc as Conc (labelThread)
-import qualified GHC.Stack as Stack (currentCallStack)
-import qualified System.IO as IO (hPutStrLn, stderr)
+import qualified GHC.Stack as Stack (callStack, getCallStack)
 
 -- For some reason, stylish-haskell wants to delete this.
 #if MIN_VERSION_base(4,18,0)
@@ -62,7 +64,7 @@ import           Network.Socket (AddrInfo (..), AddrInfoFlag (..), Family (..),
 
 waitBenchmark :: Trace IO (TraceBenchTxSubmit TxId) -> AsyncBenchmarkControl -> ExceptT TxGenError IO ()
 waitBenchmark traceSubmit AsyncBenchmarkControl { .. } = liftIO $ do
-  mapM_ waitCatch $ abcFeeder : abcWorkers
+  mapM_ waitCatch $ abcFeeder `NE.cons` abcWorkers
   traceWith traceSubmit . TraceBenchTxSubSummary =<< abcSummary
 
 lookupNodeAddress :: NodeIPv4Address -> IO AddrInfo
@@ -142,57 +144,70 @@ walletBenchmark
   _era
   count
   txSource
-  = liftIO $ do
+  = liftIO do
+  disableBuffering $ Just "walletBenchmark"
   traceDebug "******* Tx generator, phase 2: pay to recipients *******"
 
-  let numTargets :: Natural = fromIntegral $ NE.length targets
+  let numTargets :: Int = NE.length targets
       lookupTarget :: NodeDescription -> IO (String, AddrInfo)
-      lookupTarget NodeDescription {..} = secondM lookupNodeAddress (ndName, ndAddr)
+      lookupTarget NodeDescription {..} =
+        secondM lookupNodeAddress (ndName, ndAddr)
   remoteAddresses <- forM targets lookupTarget
 
-  traceDebug $ "******* Tx generator, launching Tx peers:  " ++ show (NE.length remoteAddresses) ++ " of them"
+  traceDebug $ "******* Tx generator, launching Tx peers:  " <>
+    show (NE.length remoteAddresses) <> " of them"
 
   startTime <- Clock.getCurrentTime
   tpsThrottle <- newTpsThrottle 32 count tpsRate
 
   txStreamRef <- newMVar $ StreamActive txSource
 
-  reportRefs <- atomically do replicateM (fromIntegral numTargets) STM.newEmptyTMVar
-  let asyncList = zip reportRefs $ NE.toList remoteAddresses
-  abcWorkers <- forM asyncList \(reportRef, remoteInfo@(remoteName, remoteAddrInfo)) -> do
-    let errorHandler = handleTxSubmissionClientError traceSubmit remoteInfo reportRef errorPolicy
-        client = txSubmissionClient
-                     traceN2N
-                     traceSubmit
-                     (txStreamSource txStreamRef tpsThrottle)
-                     (submitSubmissionThreadStats reportRef)
+  let takeNE :: Int -> NonEmpty t -> NonEmpty t
+      takeNE n (x :| xs) = fromJust . nonEmpty . take n $ x : xs
+      replicateMNE :: Monad m => Int -> m t -> m (NonEmpty t)
+      replicateMNE n e = Trav.sequence . takeNE n $ NE.repeat e
+
+  reportRefs <- atomically do
+    replicateMNE numTargets STM.newEmptyTMVar
+  let asyncList = NE.zip reportRefs remoteAddresses
+      handleTxSubmissionClientError' ri rr =
+        handleTxSubmissionClientError traceSubmit ri rr errorPolicy
+      txStreamSource' = txStreamSource txStreamRef tpsThrottle
+      txSubmissionClient' =
+        txSubmissionClient traceN2N traceSubmit txStreamSource'
+  abcWorkers <- forM asyncList \(reportRef, remoteInfo) -> do
+    let (remoteName, remoteAddrInfo) = remoteInfo
+        errorHandler = handleTxSubmissionClientError' remoteInfo reportRef
+        client = txSubmissionClient' $ submitSubmissionThreadStats reportRef
         remoteAddrString = show $ addrAddress remoteAddrInfo
         mkLabel tid = "txSubmissionClient " ++ show tid ++
                       " servicing " ++ remoteName ++ " (" ++
                       remoteAddrString ++ ")"
     asyncThread <- Async.async do
       tid <- myThreadId
-      IO.hPutStrLn IO.stderr $
+      traceDebug $
         "spawned thread " <> show tid <> " " <> mkLabel tid <> " from:"
-      mapM_ (IO.hPutStrLn IO.stderr . show) =<< Stack.currentCallStack
+      mapM_ (putMsg . show) $ Stack.getCallStack Stack.callStack
       Except.handle errorHandler $ connectClient remoteAddrInfo client
     let tid = asyncThreadId asyncThread
     Conc.labelThread tid $ mkLabel tid
     pure asyncThread
 
   abcFeeder <- Async.async $ do
     startSending tpsThrottle
-    traceWith traceSubmit $ TraceBenchTxSubDebug "tpsLimitedFeeder : transmitting done"
+    traceDebug "tpsLimitedFeeder : transmitting done"
     STM.atomically $ sendStop tpsThrottle
-    traceWith traceSubmit $ TraceBenchTxSubDebug "tpsLimitedFeeder : shutdown done"
+    traceDebug "tpsLimitedFeeder : shutdown done"
   let tid = asyncThreadId abcFeeder
   Conc.labelThread tid $ "tpsThrottleThread " ++ show tid
 
   let abcShutdown = do
         cancel abcFeeder
         liftIO . STM.atomically $ sendStop tpsThrottle
 
-  pure AsyncBenchmarkControl { abcSummary = mkSubmissionSummary startTime reportRefs, .. }
+  pure AsyncBenchmarkControl { abcSummary = mkSubmissionSummary startTime $ NE.toList reportRefs, .. }
  where
   traceDebug :: String -> IO ()
-  traceDebug =   traceWith traceSubmit . TraceBenchTxSubDebug
+  traceDebug s = do
+    traceWith traceSubmit $ TraceBenchTxSubDebug s
+    putMsg $ "walletBenchmark: " <> s