diff --git a/cabal.project b/cabal.project index 0b294bf1a70..82138b1dff7 100644 --- a/cabal.project +++ b/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 diff --git a/nix/stack.materialized/plutus-scb.nix b/nix/stack.materialized/plutus-scb.nix index 5ca06a87154..4d5812dd532 100644 --- a/nix/stack.materialized/plutus-scb.nix +++ b/nix/stack.materialized/plutus-scb.nix @@ -99,6 +99,8 @@ (hsPkgs."mwc-random" or (errorHandler.buildDepError "mwc-random")) (hsPkgs."primitive" or (errorHandler.buildDepError "primitive")) (hsPkgs."hedgehog" or (errorHandler.buildDepError "hedgehog")) + (hsPkgs."iohk-monitoring" or (errorHandler.buildDepError "iohk-monitoring")) + (hsPkgs."lobemo-backend-ekg" or (errorHandler.buildDepError "lobemo-backend-ekg")) ]; buildable = true; modules = [ @@ -146,6 +148,7 @@ "Plutus/SCB/Effects/EventLog" "Plutus/SCB/Effects/MultiAgent" "Plutus/SCB/Effects/UUID" + "Plutus/SCB/Monitoring" "Plutus/SCB/Webserver/Types" "Plutus/SCB/Webserver/API" "Plutus/SCB/Webserver/Server" diff --git a/plutus-contract/src/Control/Monad/Freer/Log.hs b/plutus-contract/src/Control/Monad/Freer/Log.hs index e1468998945..0cb956f9b47 100644 --- a/plutus-contract/src/Control/Monad/Freer/Log.hs +++ b/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) diff --git a/plutus-scb/app/Main.hs b/plutus-scb/app/Main.hs index 084a134d44d..b067f144fb5 100644 --- a/plutus-scb/app/Main.hs +++ b/plutus-scb/app/Main.hs @@ -19,6 +19,18 @@ 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_) @@ -26,18 +38,18 @@ 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)) \ No newline at end of file diff --git a/plutus-scb/plutus-scb.cabal b/plutus-scb/plutus-scb.cabal index 4480e1f8974..50607d35c66 100644 --- a/plutus-scb/plutus-scb.cabal +++ b/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 diff --git a/plutus-scb/src/Plutus/SCB/App.hs b/plutus-scb/src/Plutus/SCB/App.hs index 536458dea8d..2d29eb106b2 100644 --- a/plutus-scb/src/Plutus/SCB/App.hs +++ b/plutus-scb/src/Plutus/SCB/App.hs @@ -22,22 +22,28 @@ import Cardano.Node.Client (handleNodeClientClient, handl handleRandomTxClient) import Cardano.Node.Follower (NodeFollowerEffect) import Cardano.Node.RandomTx (GenRandomTx) +import qualified Cardano.BM.Configuration.Model as CM +import Control.Tracer (natTracer) import qualified Cardano.Node.Server as NodeServer import qualified Cardano.SigningProcess.Client as SigningProcessClient import qualified Cardano.SigningProcess.Server as SigningProcess import qualified Cardano.Wallet.Client as WalletClient +import Control.Monad.Catch (MonadCatch) +import Data.Bifunctor (Bifunctor(..)) +import Data.Functor.Contravariant (Contravariant(..)) import qualified Cardano.Wallet.Server as WalletServer import Control.Monad.Freer +import Cardano.BM.Trace (Trace) +import Cardano.BM.Data.Tracer (ToObject) import Control.Monad.Freer.Error (Error, handleError, runError, throwError) -import Control.Monad.Freer.Extra.Log (LogMsg, handleWriterLog, logDebug, logInfo, runStderrLog) -import Control.Monad.Freer.Log (LogMessage, LogObserve, handleObserveLog, renderLogMessages) +import Control.Monad.Freer.Extra.Log (LogMsg, handleWriterLog, logDebug, logInfo) +import Control.Monad.Freer.Log (LogMessage, LogObserve) import qualified Control.Monad.Freer.Log as Log import Control.Monad.Freer.Reader (Reader, asks, runReader) import Control.Monad.Freer.Writer (Writer) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Logger (LogLevel, LoggingT (..), MonadLogger, filterLogger, - runStdoutLoggingT) +import Control.Monad.Logger (MonadLogger) import Data.Aeson (FromJSON, eitherDecode) import qualified Data.Aeson as JSON import qualified Data.Aeson.Encode.Pretty as JSON @@ -59,6 +65,8 @@ import Plutus.SCB.Effects.Contract (ContractEffect (..)) import Plutus.SCB.Effects.EventLog (EventLogEffect (..), handleEventLogSql) import Plutus.SCB.Effects.UUID (UUIDEffect, handleUUIDEffect) import Plutus.SCB.Events (ChainEvent) +import Plutus.SCB.Monitoring (handleLogMsgTraceMap, handleObserveTrace) +import Plutus.SCB.MonadLoggerBridge (TraceLoggerT(..), MonadLoggerMsg) import Plutus.SCB.Types (Config (Config), ContractExe (..), SCBError (..), chainIndexConfig, dbConfig, nodeServerConfig, signingProcessConfig, walletServerConfig) import Servant.Client (ClientEnv, ClientError, mkClientEnv) @@ -104,32 +112,59 @@ type AppBackend m = , LogMsg UnStringifyJSONLog , LogMsg (CoreMsg ContractExe) , LogObserve (LogMessage Text.Text) - , LogMsg Text.Text + -- , LogMsg Text.Text , Reader Connection , Reader Env , m ] +data SCBLogMsg = + SContractExeLogMsg ContractExeLogMsg + | SContractInstanceMsg (ContractInstanceMsg ContractExe) + | SCoreMsg (CoreMsg ContractExe) + | SUnstringifyJSON UnStringifyJSONLog + | SWalletEvent Wallet.Emulator.Wallet.WalletEvent + | SLoggerBridge MonadLoggerMsg + +instance Pretty SCBLogMsg where + pretty = \case + SContractExeLogMsg m -> pretty m + SContractInstanceMsg m -> pretty m + SCoreMsg m -> pretty m + SUnstringifyJSON m -> pretty m + SWalletEvent w -> pretty w + SLoggerBridge m -> pretty m + +instance JSON.ToJSON SCBLogMsg where + toJSON = undefined + +instance JSON.FromJSON SCBLogMsg where + parseJSON = undefined + +instance ToObject SCBLogMsg where + runAppBackend :: forall m a. ( MonadIO m - , MonadLogger m , MonadUnliftIO m + , MonadLogger m + , MonadCatch m ) - => Env - -> Eff (AppBackend m) a + => CM.Configuration -- ^ Logging / monitoring configuration + -> Trace m SCBLogMsg -- ^ Top-level tracer + -> Env -- ^ Client config + -> Eff (AppBackend m) a -- ^ Action -> m (Either SCBError a) -runAppBackend e@Env{dbConnection, nodeClientEnv, walletClientEnv, signingProcessEnv, chainIndexEnv} = +runAppBackend config trace e@Env{dbConnection, nodeClientEnv, walletClientEnv, signingProcessEnv, chainIndexEnv} = runM . runReader e . runReader dbConnection - . runStderrLog - . handleObserveLog - . renderLogMessages - . renderLogMessages - . renderLogMessages - . renderLogMessages - . renderLogMessages + . handleObserveTrace config trace + . handleLogMsgTraceMap SCoreMsg trace + . handleLogMsgTraceMap SUnstringifyJSON trace + . handleLogMsgTraceMap SContractInstanceMsg trace + . handleLogMsgTraceMap SContractExeLogMsg trace + . handleLogMsgTraceMap SWalletEvent trace . handleWriterLog (\_ -> Log.Info) . runError . handleEventLogSql @@ -168,19 +203,20 @@ runAppBackend e@Env{dbConnection, nodeClientEnv, walletClientEnv, signingProcess . flip handleError (throwError . WalletError) . WalletClient.handleWalletClient walletClientEnv +type App a = Eff (AppBackend (TraceLoggerT IO)) a -type App a = Eff (AppBackend (LoggingT IO)) a - -runApp :: LogLevel -> Config -> App a -> IO (Either SCBError a) -runApp minLogLevel Config {dbConfig, nodeServerConfig, walletServerConfig, signingProcessConfig, chainIndexConfig} action = - runStdoutLoggingT $ filterLogger (\_ logLevel -> logLevel >= minLogLevel) $ do +runApp :: Trace IO SCBLogMsg -> CM.Configuration -> Config -> App a -> IO (Either SCBError a) +runApp theTrace logConfig Config {dbConfig, nodeServerConfig, walletServerConfig, signingProcessConfig, chainIndexConfig} action =do + let theTrace' = natTracer (\x -> TraceLoggerT $ \_ -> x) theTrace + runTraceLoggerT (do walletClientEnv <- mkEnv (WalletServer.baseUrl walletServerConfig) nodeClientEnv <- mkEnv (NodeServer.mscBaseUrl nodeServerConfig) signingProcessEnv <- mkEnv (SigningProcess.spBaseUrl signingProcessConfig) chainIndexEnv <- mkEnv (ChainIndex.ciBaseUrl chainIndexConfig) dbConnection <- dbConnect dbConfig let env = Env {..} - runAppBackend @(LoggingT IO) env action + runAppBackend @(TraceLoggerT IO) logConfig theTrace' env action) + (contramap (second (fmap SLoggerBridge)) theTrace) where mkEnv baseUrl = mkClientEnv @@ -198,6 +234,7 @@ data ContractExeLogMsg = | InvokingEndpoint String JSON.Value | EndpointInvocationResponse [Doc Void] | ContractExeSCBError SCBError + | StartingSCBBackendServer Int instance Pretty ContractExeLogMsg where pretty = \case @@ -218,6 +255,9 @@ instance Pretty ContractExeLogMsg where hang 2 $ vsep ("Invocation response:" : fmap (fmap absurd) v) ContractExeSCBError e -> "SCB error:" <+> pretty e + StartingSCBBackendServer port -> + "Starting SCB backend server on port:" <+> pretty port + handleContractEffectApp :: (Member (LogMsg ContractExeLogMsg) effs, Member (Error SCBError) effs, LastMember m effs, MonadIO m) diff --git a/plutus-scb/src/Plutus/SCB/MonadLoggerBridge.hs b/plutus-scb/src/Plutus/SCB/MonadLoggerBridge.hs new file mode 100644 index 00000000000..c9947fbcad9 --- /dev/null +++ b/plutus-scb/src/Plutus/SCB/MonadLoggerBridge.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | A 'Control.Monad.Logger.Logger' instance +-- using the 'Control.Monad.Freer.Log.Log' effect +module Plutus.SCB.MonadLoggerBridge( + MonadLoggerMsg(..) + , TraceLoggerT(..) + ) where + +import Control.Monad.Logger (MonadLogger(..), Loc, LogSource, LogLevel(..), LogStr, ToLogStr(..)) +import Control.Monad.Freer +import Control.Monad.IO.Unlift (MonadUnliftIO(..)) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.Freer.Log (LogMsg(..), LogMessage(..)) +import qualified Control.Monad.Freer.Log as L +import Control.Monad.IO.Class(MonadIO(..)) +import Data.Text.Prettyprint.Doc (Pretty(..), (<+>), vsep, viaShow) +import Cardano.BM.Data.Trace (Trace) +import Cardano.BM.Data.LogItem (PrivacyAnnotation(Public)) +import Cardano.BM.Trace (traceNamedItem) +import qualified Plutus.SCB.Monitoring as M +import Control.Monad.Catch (MonadCatch, MonadThrow) + +data MonadLoggerMsg = + MonadLoggerMsg + { mlmLocation :: Loc + , mlmLogSource :: LogSource + , mlmLogStr :: LogStr + } + +instance Pretty MonadLoggerMsg where + pretty MonadLoggerMsg{mlmLocation, mlmLogSource, mlmLogStr} = + vsep + [ "Location:" <+> viaShow mlmLocation + , "Source:" <+> viaShow mlmLogSource + , "Message:" <+> viaShow mlmLogStr + ] + +instance (Member (LogMsg MonadLoggerMsg) effs) => MonadLogger (Eff effs) where + monadLoggerLog l ls ll msg = + send + $ LMessage + $ LogMessage + { _logLevel = toLogLevel ll + , _logMessageContent = + MonadLoggerMsg + { mlmLocation = l + , mlmLogSource = ls + , mlmLogStr = toLogStr msg + } + } + +toLogLevel :: LogLevel -> L.LogLevel +toLogLevel = \case + LevelDebug -> L.Debug + LevelInfo -> L.Info + LevelWarn -> L.Warning + LevelError -> L.Error + LevelOther _ -> L.Info + +-- | Interpret 'MonadLogger' effect using a 'Trace' +newtype TraceLoggerT m a = TraceLoggerT { runTraceLoggerT :: Trace m MonadLoggerMsg -> m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadCatch, MonadThrow) via (ReaderT (Trace m MonadLoggerMsg) m) + +instance (MonadIO m, MonadUnliftIO m) => MonadUnliftIO (TraceLoggerT m) where + withRunInIO inner = + TraceLoggerT $ \trace -> + withRunInIO $ \r -> + inner (r . flip runTraceLoggerT trace) + +instance (MonadIO m, Monad m) => MonadLogger (TraceLoggerT m) where + monadLoggerLog l logSource ll msg = TraceLoggerT $ \trace -> + traceNamedItem trace Public (M.toSeverity $ toLogLevel ll) + $ MonadLoggerMsg{mlmLocation = l, mlmLogSource = logSource, mlmLogStr = toLogStr msg} diff --git a/plutus-scb/src/Plutus/SCB/Monitoring.hs b/plutus-scb/src/Plutus/SCB/Monitoring.hs new file mode 100644 index 00000000000..7a5388aad7b --- /dev/null +++ b/plutus-scb/src/Plutus/SCB/Monitoring.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Plutus.SCB.Monitoring( + -- * Effect handlers + handleLogMsgTrace + , handleLogMsgTraceMap + , handleObserveTrace + -- * Conveniences for configuration + , defaultConfig + , loadConfig + -- * Misc + , test + , toSeverity + ) where + +import qualified Cardano.BM.Backend.EKGView +import Cardano.BM.Configuration (setup) +import qualified Cardano.BM.Configuration.Model as CM +import Cardano.BM.Data.BackendKind +import Cardano.BM.Data.Counter +import Cardano.BM.Data.LogItem +import Cardano.BM.Data.Observable (ObservableInstance (..)) +import Cardano.BM.Data.Output +import Cardano.BM.Data.Severity +import Control.Monad.Catch (MonadCatch) +import Cardano.BM.Data.SubTrace +import Cardano.BM.Data.Trace +import Cardano.BM.Observer.Monadic +import Cardano.BM.Plugin (loadPlugin) +import Cardano.BM.Setup +import Cardano.BM.Trace +import Control.Monad (void) +import Control.Monad.Freer +import Control.Monad.Freer.Log (LogMsg (..), LogObserve (..), Observation (..)) +import qualified Control.Monad.Freer.Log as L +import Data.Functor.Contravariant (Contravariant(..)) +import Data.Bifunctor (Bifunctor(..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) + + +-- | A default 'CM.Configuration' that logs on 'Info' and above +-- to stdout +defaultConfig :: IO CM.Configuration +defaultConfig = do + c <- CM.empty + CM.setMinSeverity c Info + CM.setSetupBackends c [ KatipBK + , AggregationBK + , MonitoringBK + , EKGViewBK + ] + CM.setDefaultBackends c [KatipBK, AggregationBK, EKGViewBK] + CM.setSetupScribes c [ ScribeDefinition { + scName = "stdout" + , scKind = StdoutSK + , scFormat = ScText + , scPrivacy = ScPublic + , scRotation = Nothing + }] + let observables = (Just $ ObservableTraceSelf [MonotonicClock, MemoryStats]) + CM.setSubTrace c "processAllContractOutboxes" observables + CM.setDefaultScribes c ["StdoutSK::stdout"] + CM.setEKGport c 12790 + pure c + +-- | Load a 'CM.Configuration' from a YAML file. +loadConfig :: FilePath -> IO CM.Configuration +loadConfig = setup + +test :: IO () +test = do + conf <- defaultConfig + (trace, sb) <- setupTrace_ conf "pab" + Cardano.BM.Backend.EKGView.plugin conf trace sb >>= loadPlugin sb + runM + $ handleObserveTrace conf trace + $ handleLogMsgTrace @Text trace + $ do + L.logInfo @Text "hello" + L.logInfo @Text "world" + L.surroundInfo @Text "processAllContractOutboxes" $ do + L.logInfo @Text "doing some work" + liftIO readLn + +-- | Handle the 'LogMsg' effect by logging messages to a 'Trace' +handleLogMsgTrace :: forall a m effs. + ( LastMember m effs + , MonadIO m + ) + => Trace m a + -> Eff (LogMsg a ': effs) + ~> Eff effs +handleLogMsgTrace trace = interpret $ \case + LMessage L.LogMessage{L._logLevel, L._logMessageContent} -> + let defaultPrivacy = Public -- TODO: Configurable / add to 'L.LogMessage'? + in sendM $ traceNamedItem trace defaultPrivacy (toSeverity _logLevel) _logMessageContent + +handleLogMsgTraceMap :: forall b a m effs. + ( LastMember m effs + , MonadIO m + ) + => (b -> a) + -> Trace m a + -> Eff (LogMsg b ': effs) + ~> Eff effs +handleLogMsgTraceMap f t = handleLogMsgTrace (contramap (second (fmap f)) t) + +toSeverity :: L.LogLevel -> Severity +toSeverity = \case + L.Debug -> Debug + L.Info -> Info + L.Notice -> Notice + L.Warning -> Warning + L.Error -> Error + L.Critical -> Critical + L.Alert -> Alert + L.Emergency -> Emergency + +-- | Handle the 'LogObserve' effect using the 'Cardano.BM.Observer.Monadic' +-- observer functions +handleObserveTrace :: + forall effs m a. + ( LastMember m effs + , MonadIO m + , MonadCatch m + ) + => CM.Configuration + -> Trace m a + -> Eff (LogObserve (L.LogMessage Text) ': effs) + ~> Eff effs +handleObserveTrace config t = + + let observeBefore :: (L.LogMessage Text) -> Eff effs (Maybe (SubTrace, CounterState)) + observeBefore L.LogMessage{L._logLevel, L._logMessageContent} = do + subtrace <- fromMaybe Neutral <$> sendM @_ @effs (liftIO $ CM.findSubTrace config _logMessageContent) + mCountersid <- sendM $ observeOpen subtrace (toSeverity _logLevel) t + case mCountersid of + Left _ -> pure Nothing + Right counterState -> pure (Just (subtrace, counterState)) + + observeAfter :: Observation (L.LogMessage Text) (Maybe (SubTrace, CounterState)) -> Eff effs () + observeAfter Observation{obsStart} = + case obsStart of + Nothing -> pure () + Just (subtrace, counterState) -> void $ sendM $ observeClose subtrace Info t counterState [] + + in L.handleObserve + observeBefore + observeAfter diff --git a/plutus-scb/src/Plutus/SCB/Webserver/Server.hs b/plutus-scb/src/Plutus/SCB/Webserver/Server.hs index cd2a4f45fad..1ed4732a456 100644 --- a/plutus-scb/src/Plutus/SCB/Webserver/Server.hs +++ b/plutus-scb/src/Plutus/SCB/Webserver/Server.hs @@ -16,6 +16,8 @@ module Plutus.SCB.Webserver.Server , contractSchema ) where +import Cardano.BM.Configuration (Configuration) +import Cardano.BM.Data.Trace (Trace) import Control.Concurrent.Availability (Availability, available) import Control.Monad.Except (ExceptT (ExceptT)) import Control.Monad.Freer (Eff, Member) @@ -23,7 +25,6 @@ import Control.Monad.Freer.Error (Error, throwEr import Control.Monad.Freer.Extra.Log (LogMsg, logInfo) import Control.Monad.Freer.Log (LogMessage, LogObserve) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (LogLevel (LevelDebug)) import qualified Data.Aeson as JSON import Data.Bifunctor (first) import qualified Data.ByteString.Lazy.Char8 as LBS @@ -42,7 +43,7 @@ import Ledger (PubKeyHash) import Ledger.Blockchain (Blockchain) import qualified Network.Wai.Handler.Warp as Warp import Plutus.SCB.App (App, ContractExeLogMsg (..), UnStringifyJSONLog, - parseStringifiedJSON, runApp) + parseStringifiedJSON, runApp, SCBLogMsg(..), ContractExeLogMsg(..)) import Plutus.SCB.Arbitrary () import Plutus.SCB.Core (runGlobalQuery) import qualified Plutus.SCB.Core as Core @@ -59,7 +60,6 @@ import Plutus.SCB.Types (ChainOverview baseUrl, chainOverviewBlockchain, chainOverviewUnspentTxsById, chainOverviewUtxoIndex, mkChainOverview, scbWebserverConfig, staticDir) -import Plutus.SCB.Utils (tshow) import Plutus.SCB.Webserver.API (API) import Plutus.SCB.Webserver.Types import Servant ((:<|>) ((:<|>)), Application, Handler (Handler), Raw, @@ -70,9 +70,9 @@ import Wallet.Effects (ChainIndexEffe import Wallet.Emulator.Wallet (Wallet) import qualified Wallet.Rollup as Rollup -asHandler :: Config -> App a -> Handler a -asHandler config = - Handler . ExceptT . fmap (first decodeErr) . runApp LevelDebug config +asHandler :: Trace IO SCBLogMsg -> Configuration -> Config -> App a -> Handler a +asHandler trace logConfig config = + Handler . ExceptT . fmap (first decodeErr) . runApp trace logConfig config where decodeErr (InvalidUUIDError t) = err400 @@ -225,18 +225,18 @@ handler = (EndpointDescription rawEndpointDescription) payload'))) -app :: Config -> Application -app config = serve rest (apiServer :<|> fileServer) +app :: Trace IO SCBLogMsg -> Configuration -> Config -> Application +app trace logConfig config = serve rest (apiServer :<|> fileServer) where rest = Proxy @(API ContractExe :<|> Raw) api = Proxy @(API ContractExe) - apiServer = hoistServer api (asHandler config) handler + apiServer = hoistServer api (asHandler trace logConfig config) handler fileServer = serveDirectoryFileServer (staticDir . scbWebserverConfig $ config) -main :: Config -> Availability -> App () -main config availability = do +main :: Trace IO SCBLogMsg -> Configuration -> Config -> Availability -> App () +main trace logConfig config availability = do let port = baseUrlPort $ baseUrl $ scbWebserverConfig config let warpSettings :: Warp.Settings warpSettings = Warp.defaultSettings & Warp.setPort port & Warp.setBeforeMainLoop (available availability) - logInfo $ "Starting SCB backend server on port: " <> tshow port - liftIO $ Warp.runSettings warpSettings $ app config + logInfo $ StartingSCBBackendServer port + liftIO $ Warp.runSettings warpSettings $ app trace logConfig config