WIP iohk-monitoring

cabal.project

@@ -155,7 +155,11 @@ package shelley-spec-ledger-test
 
 package iohk-monitoring
   -- disable all warnings
-  ghc-options: -w 
+  ghc-options: -w
+
+package contra-tracer
+  -- disable all warnings
+  ghc-options: -w
 
 source-repository-package
   type: git
@@ -190,12 +194,13 @@ source-repository-package
 
 source-repository-package
   type: git
-  location: https://github.com/raduom/iohk-monitoring-framework
-  tag: b5c035ad4e226d634242ad5979fa677921181435
+  location: https://github.com/j-mueller/iohk-monitoring-framework
+  tag: d8e6df66e2cf2442a6ec9bc0ced69ecd1d518947
   subdir: 
     iohk-monitoring 
     tracer-transformers 
     contra-tracer
+    plugins/backend-ekg
 
 source-repository-package
   type: git

plutus-contract/src/Control/Monad/Freer/Log.hs

@@ -35,6 +35,7 @@ module Control.Monad.Freer.Log(
     -- * Tracing
     , LogObserve(..)
     , ObservationHandle
+    , Observation(..)
     , observeBefore
     , observeAfter
     , surround
@@ -259,8 +260,7 @@ data ExitMode =
 data Observation v s =
     Observation
         { obsLabelStart :: v -- ^ Call-site information about the start of the observation
-        , obsStart      :: s -- ^ Measurement before running the action
-        , obsEnd        :: s -- ^ Measurement after running the action
+        , obsStart      :: s -- ^ Measurement taken before running the action
         , obsLabelEnd   :: Maybe v -- ^ Call-site information about the end of the observation
         , obsExit       :: ExitMode -- ^ 'ExitMode' of the action.
         }
@@ -289,7 +289,7 @@ initialState = ObsState 0 []
 --   them into 'LogMessage (Observation s)' values.
 handleObserve ::
     forall v s effs.
-    Eff effs s -- ^ How to get the current 's'
+    (v -> Eff effs s) -- ^ How to get the current 's'
     -> (Observation v s -> Eff effs ()) -- what to do with the observation
     -> Eff (LogObserve v ': effs)
     ~> Eff effs
@@ -310,7 +310,6 @@ handleObserve getCurrent handleObs =
         -- measurement and clear the stack of partial observations.
         handleObserveAfter :: Maybe v -> ObsState v s -> Integer -> Eff effs (ObsState v s)
         handleObserveAfter v' ObsState{obsPartials} i = do
-                current <- getCurrent
                 let (finishedPartials, remainingPartials) = span ((<=) i . obsDepth) obsPartials
                 for_ finishedPartials $ \PartialObservation{obsMsg, obsValue,obsDepth} -> do
                     -- we assume that a 'PartialObservation' was completed
@@ -323,7 +322,6 @@ handleObserve getCurrent handleObs =
                             Observation
                                 { obsLabelStart = obsMsg
                                 , obsStart = obsValue
-                                , obsEnd=current
                                 , obsExit=exitMode
                                 , obsLabelEnd = case exitMode of { Regular -> v'; Irregular -> Nothing }
                                 }
@@ -332,7 +330,7 @@ handleObserve getCurrent handleObs =
 
         handleObserveBefore :: v -> ObsState v s -> Eff effs (ObsState v s, ObservationHandle)
         handleObserveBefore v ObsState{obsPartials,obsMaxDepth} = do
-            current <- getCurrent
+            current <- getCurrent v
             let newMaxDepth = obsMaxDepth + 1
                 msg = PartialObservation
                         { obsMsg = v
@@ -364,7 +362,7 @@ handleObserveLog ::
     => Eff (LogObserve (LogMessage Text) ': effs)
     ~> Eff effs
 handleObserveLog =
-    handleObserve (pure ()) handleAfter
+    handleObserve (\_ -> pure ()) handleAfter
     . interpose handleBefore
         where
             handleBefore :: LogObserve (LogMessage Text) ~> Eff (LogObserve (LogMessage Text) ': effs)

plutus-scb/app/Main.hs

@@ -19,25 +19,37 @@ import qualified Cardano.Node.Server                             as NodeServer
 import qualified Cardano.SigningProcess.Server                   as SigningProcess
 import qualified Cardano.Wallet.Server                           as WalletServer
 import           Control.Concurrent                              (threadDelay)
+import Cardano.BM.Configuration (Configuration)
+import Cardano.BM.Data.Tracer (ToObject(..))
+import Cardano.BM.Data.Trace (Trace)
+import Control.Tracer (natTracer)
+import Cardano.BM.Setup (setupTrace_)
+import Data.Functor.Contravariant (Contravariant(..))
+import Data.Bifunctor (Bifunctor(..))
+import Plutus.SCB.Monitoring (defaultConfig, loadConfig, handleLogMsgTrace)
+import Plutus.SCB.MonadLoggerBridge (TraceLoggerT(..))
+import qualified Cardano.BM.Backend.EKGView
+import           Cardano.BM.Plugin              (loadPlugin)
+import Ledger.Tx (Tx)
 import           Control.Concurrent.Async                        (Async, async, waitAny)
 import           Control.Concurrent.Availability                 (Availability, newToken, starting)
 import           Control.Lens.Indexed                            (itraverse_)
 import           Control.Monad                                   (forever, void)
 import           Control.Monad.Freer                             (Eff, raise)
 import           Control.Monad.Freer.Error                       (handleError)
 import           Control.Monad.Freer.Extra.Log                   (LogMsg, logInfo)
-import           Control.Monad.Freer.Log                         (logError, renderLogMessages)
+import           Control.Monad.Freer.Log                         (logError)
 import           Control.Monad.IO.Class                          (liftIO)
-import           Control.Monad.Logger                            (LogLevel (LevelDebug, LevelInfo), LoggingT,
+import           Control.Monad.Logger                            (LogLevel (LevelDebug, LevelInfo),
                                                                   filterLogger, runStdoutLoggingT)
 import qualified Data.Aeson                                      as JSON
 import qualified Data.ByteString.Lazy.Char8                      as BS8
 import           Data.Foldable                                   (traverse_)
 import qualified Data.Map                                        as Map
-import           Data.Set                                        (Set)
 import qualified Data.Set                                        as Set
 import qualified Data.Text                                       as Text
-import           Data.Text.Prettyprint.Doc                       (Doc, Pretty (..), indent, parens, pretty, vsep, (<+>))
+
+import           Data.Text.Prettyprint.Doc                       (Pretty (..), pretty, (<+>), viaShow, colon)
 import           Data.Time.Units                                 (Second, toMicroseconds)
 import           Data.UUID                                       (UUID)
 import           Data.Yaml                                       (decodeFileThrow)
@@ -49,7 +61,7 @@ import           Options.Applicative                             (CommandFields,
                                                                   metavar, option, prefs, progDesc, short,
                                                                   showHelpOnEmpty, showHelpOnError, str, strArgument,
                                                                   strOption, subparser, value)
-import           Plutus.SCB.App                                  (App, AppBackend, ContractExeLogMsg (..), runApp)
+import           Plutus.SCB.App                                  (AppBackend, ContractExeLogMsg (..), runApp, SCBLogMsg)
 import qualified Plutus.SCB.App                                  as App
 import qualified Plutus.SCB.Core                                 as Core
 import qualified Plutus.SCB.Core.ContractInstance                as Instance
@@ -101,8 +113,8 @@ logLevelFlag =
         LevelDebug
         (short 'v' <> long "verbose" <> help "Enable debugging output.")
 
-commandLineParser :: Parser (LogLevel, FilePath, Command)
-commandLineParser = (,,) <$> logLevelFlag <*> configFileParser <*> commandParser
+commandLineParser :: Parser (LogLevel, FilePath, Maybe FilePath, Command)
+commandLineParser = (,,,) <$> logLevelFlag <*> configFileParser <*> logConfigFileParser <*> commandParser
 
 configFileParser :: Parser FilePath
 configFileParser =
@@ -112,6 +124,14 @@ configFileParser =
          metavar "CONFIG_FILE" <>
          help "Config file location." <> value "plutus-scb.yaml")
 
+logConfigFileParser :: Parser (Maybe FilePath)
+logConfigFileParser =
+    option
+        (Just <$> str)
+        (long "log-config" <>
+         metavar "LOG_CONFIG_FILE" <>
+         help "Logging config file location." <> value Nothing)
+
 commandParser :: Parser Command
 commandParser =
     subparser $
@@ -304,6 +324,21 @@ data AppMsg =
     | ContractHistoryMsg
     | ProcessInboxMsg
     | ProcessAllOutboxesMsg Second
+    | SCBMsg SCBLogMsg
+    | InstalledContract Text.Text
+    | ContractInstance ContractExe [ContractInstanceId]
+    | TxHistoryItem Tx
+    | RunningCommand Command
+    | ContractHistoryItem Int (ContractInstanceState ContractExe) -- index
+
+instance JSON.ToJSON AppMsg where
+    toJSON = undefined
+
+instance JSON.FromJSON AppMsg where
+    parseJSON = undefined
+
+instance ToObject AppMsg where
+    toObject = undefined
 
 instance Pretty AppMsg where
     pretty = \case
@@ -313,22 +348,28 @@ instance Pretty AppMsg where
         ContractHistoryMsg -> "Contract history"
         ProcessInboxMsg -> "Process contract inbox"
         ProcessAllOutboxesMsg s -> "Processing contract outboxes every" <+> pretty (fromIntegral @_ @Double s) <+> "seconds"
+        SCBMsg m -> pretty m
+        InstalledContract t -> pretty t
+        ContractInstance t s -> pretty t <+> pretty s-- FIXME
+        TxHistoryItem t -> pretty t
+        RunningCommand com -> "Running command" <+> viaShow com
+        ContractHistoryItem i s -> pretty i <> colon <+> pretty s
 
 ------------------------------------------------------------
 -- | Translate the command line configuation into the actual code to be run.
 --
-runCliCommand :: LogLevel -> Config ->  Availability -> Command -> Eff (LogMsg AppMsg ': AppBackend (LoggingT IO)) ()
-runCliCommand _ _ _ Migrate = raise App.migrate
-runCliCommand _ Config {walletServerConfig, nodeServerConfig, chainIndexConfig} serviceAvailability MockWallet =
+runCliCommand :: Trace IO AppMsg -> Configuration -> Config ->  Availability -> Command -> Eff (LogMsg AppMsg ': AppBackend (TraceLoggerT IO)) ()
+runCliCommand _ _ _ _ Migrate = raise App.migrate
+runCliCommand _ _ Config {walletServerConfig, nodeServerConfig, chainIndexConfig} serviceAvailability MockWallet =
     WalletServer.main
         walletServerConfig
         (NodeServer.mscBaseUrl nodeServerConfig)
         (ChainIndex.ciBaseUrl chainIndexConfig)
         serviceAvailability
-runCliCommand _ Config {nodeServerConfig} serviceAvailability MockNode =
+runCliCommand _ _ Config {nodeServerConfig} serviceAvailability MockNode =
     NodeServer.main nodeServerConfig serviceAvailability
-runCliCommand _ config serviceAvailability SCBWebserver = raise $ SCBServer.main config serviceAvailability
-runCliCommand minLogLevel config serviceAvailability (ForkCommands commands) =
+runCliCommand trace logConfig config serviceAvailability SCBWebserver = raise $ SCBServer.main (mapSCBMsg trace) logConfig config serviceAvailability
+runCliCommand trace logConfig config serviceAvailability (ForkCommands commands) =
     void . liftIO $ do
         threads <- traverse forkCommand commands
         putStrLn $ "Started all commands."
@@ -338,68 +379,81 @@ runCliCommand minLogLevel config serviceAvailability (ForkCommands commands) =
     forkCommand ::  Command -> IO (Async ())
     forkCommand subcommand = do
       putStrLn $ "Starting: " <> show subcommand
-      asyncId <- async . void . runApp minLogLevel config . renderLogMessages . runCliCommand minLogLevel config serviceAvailability $ subcommand
+    --   asyncId <- async . void . runApp minLogLevel config . renderLogMessages . runCliCommand minLogLevel config serviceAvailability $ subcommand
+      let trace' = natTracer (\x -> TraceLoggerT $ \_ -> x) trace
+      asyncId <- async . void . runApp (mapSCBMsg trace) logConfig config . handleLogMsgTrace trace' . runCliCommand trace logConfig config serviceAvailability $ subcommand
       putStrLn $ "Started: " <> show subcommand
       starting serviceAvailability
       pure asyncId
-runCliCommand _ Config {nodeServerConfig, chainIndexConfig} serviceAvailability ChainIndex =
+runCliCommand _ _ Config {nodeServerConfig, chainIndexConfig} serviceAvailability ChainIndex =
     ChainIndex.main chainIndexConfig (NodeServer.mscBaseUrl nodeServerConfig) serviceAvailability
-runCliCommand _ Config {signingProcessConfig} serviceAvailability SigningProcess =
+runCliCommand _ _ Config {signingProcessConfig} serviceAvailability SigningProcess =
     SigningProcess.main signingProcessConfig serviceAvailability
-runCliCommand _ _ _ (InstallContract path) = Core.installContract (ContractExe path)
-runCliCommand _ _ _ (ActivateContract path) = void $ Core.activateContract (ContractExe path)
-runCliCommand _ _ _ (ContractState uuid) = Core.reportContractState @ContractExe (ContractInstanceId uuid)
-runCliCommand _ _ _ ReportInstalledContracts = do
+runCliCommand _ _ _ _ (InstallContract path) = Core.installContract (ContractExe path)
+runCliCommand _ _ _ _ (ActivateContract path) = void $ Core.activateContract (ContractExe path)
+runCliCommand _ _ _ _ (ContractState uuid) = Core.reportContractState @ContractExe (ContractInstanceId uuid)
+runCliCommand _ _ _ _ ReportInstalledContracts = do
     logInfo InstalledContractsMsg
-    traverse_ (logInfo . render . pretty) =<< Core.installedContracts @ContractExe
-runCliCommand _ _ _ ReportActiveContracts = do
+    traverse_ (logInfo . InstalledContract . render . pretty) =<< Core.installedContracts @ContractExe
+runCliCommand _ _ _ _ ReportActiveContracts = do
     logInfo ActiveContractsMsg
     instances <- Map.toAscList <$> Core.activeContracts @ContractExe
-    let format :: (ContractExe, Set ContractInstanceId) -> Doc a
-        format (contractExe, contractInstanceIds) =
-          vsep [ pretty contractExe
-               , indent 2 (vsep (pretty <$> Set.toList contractInstanceIds))
-               ]
-    traverse_ (logInfo . render . format) instances
-runCliCommand _ _ _ ReportTxHistory = do
+    -- let format :: (ContractExe, Set ContractInstanceId) -> Doc a
+    --     format (contractExe, contractInstanceIds) =
+    --       vsep [ pretty contractExe
+    --            , indent 2 (vsep (pretty <$> Set.toList contractInstanceIds))
+    --            ]
+    traverse_ (\(e, s) -> (logInfo $ ContractInstance e (Set.toList s))) instances
+runCliCommand _ _ _ _ ReportTxHistory = do
     logInfo TransactionHistoryMsg
-    traverse_ (logInfo . render . pretty) =<< Core.txHistory @ContractExe
-runCliCommand _ _ _ (UpdateContract uuid endpoint payload) =
+    traverse_ (logInfo . TxHistoryItem) =<< Core.txHistory @ContractExe
+runCliCommand _ _ _ _ (UpdateContract uuid endpoint payload) =
     void $ Instance.callContractEndpoint @ContractExe (ContractInstanceId uuid) (getEndpointDescription endpoint) payload
-runCliCommand _ _ _ (ReportContractHistory uuid) = do
+runCliCommand _ _ _ _ (ReportContractHistory uuid) = do
     logInfo ContractHistoryMsg
     contracts <- Core.activeContractHistory @ContractExe (ContractInstanceId uuid)
-    itraverse_ (\i -> raise . logContract i) contracts
+    itraverse_ (\i -> logContract i) contracts
     where
-      logContract :: Int -> ContractInstanceState ContractExe -> App ()
-      logContract index contract = logInfo $ render $ parens (pretty index) <+> pretty contract
-runCliCommand _ _ _ (ProcessContractInbox uuid) = do
+    --   logContract :: Int -> ContractInstanceState ContractExe -> App ()
+      logContract index contract = logInfo $ ContractHistoryItem index contract
+runCliCommand _ _ _ _ (ProcessContractInbox uuid) = do
     logInfo ProcessInboxMsg
     Core.processContractInbox @ContractExe (ContractInstanceId uuid)
-runCliCommand _ Config{requestProcessingConfig} _ ProcessAllContractOutboxes = do
+runCliCommand _ _ Config{requestProcessingConfig} _ ProcessAllContractOutboxes = do
     let RequestProcessingConfig{requestProcessingInterval} = requestProcessingConfig
     logInfo $ ProcessAllOutboxesMsg requestProcessingInterval
     forever $ do
         _ <- liftIO . threadDelay . fromIntegral $ toMicroseconds requestProcessingInterval
         handleError @SCBError (Core.processAllContractOutboxes @ContractExe Instance.defaultMaxIterations) (logError . ContractExeSCBError)
-runCliCommand _ _ _ PSGenerator {_outputDir} =
+runCliCommand _ _ _ _ PSGenerator {_outputDir} =
     liftIO $ PSGenerator.generate _outputDir
 
 main :: IO ()
 main = do
-    (minLogLevel, configPath, cmd) <-
+    (minLogLevel, configPath, logConfigPath, cmd) <-
         customExecParser
             (prefs $ disambiguate <> showHelpOnEmpty <> showHelpOnError)
             (info (helper <*> versionOption <*> commandLineParser) idm)
     config <- liftIO $ decodeFileThrow configPath
+    -- FIXME: Set log level here (if provided)
+    logConfig <- maybe defaultConfig loadConfig logConfigPath
+    (trace :: Trace IO AppMsg, switchboard) <- setupTrace_ logConfig "pab"
+    let trace' = natTracer (\x -> TraceLoggerT $ \_ -> x) trace
+
+    -- enable EKG backend
+    Cardano.BM.Backend.EKGView.plugin logConfig trace switchboard >>= loadPlugin switchboard
+
     traverse_ (EKG.forkServer "localhost") (monitoringPort <$> monitoringConfig config)
     serviceAvailability <- newToken
     result <-
-        runApp minLogLevel config $ do
-            logInfo $ "Running: " <> Text.pack (show cmd)
-            renderLogMessages $ runCliCommand minLogLevel config serviceAvailability cmd
+        runApp (mapSCBMsg trace) logConfig config $ handleLogMsgTrace trace' $ do
+            logInfo $ RunningCommand cmd
+            runCliCommand trace logConfig config serviceAvailability cmd
     case result of
         Left err -> do
             runStdoutLoggingT $ filterLogger (\_ logLevel -> logLevel >= minLogLevel) $ logErrorS err
             exitWith (ExitFailure 1)
         Right _ -> exitSuccess
+
+mapSCBMsg :: Trace m AppMsg -> Trace m SCBLogMsg
+mapSCBMsg = contramap (second (fmap SCBMsg))

plutus-scb/plutus-scb.cabal

@@ -88,6 +88,8 @@ library
         Plutus.SCB.Effects.EventLog
         Plutus.SCB.Effects.MultiAgent
         Plutus.SCB.Effects.UUID
+        Plutus.SCB.MonadLoggerBridge
+        Plutus.SCB.Monitoring
         Plutus.SCB.Webserver.Types
         Plutus.SCB.Webserver.API
         Plutus.SCB.Webserver.Server
@@ -172,7 +174,10 @@ library
         freer-simple -any,
         mwc-random -any,
         primitive -any,
-        hedgehog -any
+        hedgehog -any,
+        iohk-monitoring -any,
+        lobemo-backend-ekg -any,
+        exceptions -any
 
 executable plutus-scb
     main-is: Main.hs
@@ -212,7 +217,9 @@ executable plutus-scb
         containers -any,
         iohk-monitoring -any,
         time-units -any,
-        servant-client -any
+        servant-client -any,
+        contra-tracer -any,
+        lobemo-backend-ekg -any
 
 executable plutus-game
     main-is: Main.hs