Merge #3852 #3880 #3882 3852: cardano-tracer: init RTView r=deepfire a=denisshev… - input-output-hk/cardano-node@dfc3cf6b

Home / Input Output / cardano-node / dfc3cf6b

View on GitHub

File Changes

m

+1/-0

                        Test.Cardano.Api.Typed.Orphans

                        Test.Cardano.Api.Typed.RawBytes

                        Test.Cardano.Api.Typed.Script

+

                        Test.Cardano.Api.Typed.TxBody

                        Test.Cardano.Api.Typed.Value

  ghc-options:          -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T

m

cardano-api/gen/Gen/Cardano/Api/Typed.hs

+1/-0

  , genStakeAddress

  , genTx

  , genTxBody

+

  , genTxBodyContent

  , genLovelace

  , genValue

  , genValueDefault

m

cardano-api/src/Cardano/Api/Script.hs

+17/-15

      (AlonzoEra, PlutusScriptLanguage PlutusScriptV1) ->

        Just PlutusScriptV1InAlonzo

+

      (BabbageEra, SimpleScriptLanguage SimpleScriptV1) ->

+

        Just SimpleScriptV1InBabbage

+

      (BabbageEra, SimpleScriptLanguage SimpleScriptV2) ->

+

        Just SimpleScriptV2InBabbage

+

      (BabbageEra, PlutusScriptLanguage PlutusScriptV1) ->

+

        Just PlutusScriptV1InBabbage

+

      (BabbageEra, PlutusScriptLanguage PlutusScriptV2) ->

        Just PlutusScriptV2InBabbage

   scriptInEraToRefScript $ fromShelleyBasedScript sbe script

scriptInEraToRefScript :: ScriptInEra era -> ReferenceScript era

-

scriptInEraToRefScript [email protected](ScriptInEra langInEra s) =

-

  let sLang = languageOfScriptLanguageInEra langInEra

-

      era = shelleyBasedToCardanoEra $ eraOfScriptInEra sIne

-

  in case refInsScriptsAndInlineDatsSupportedInEra era of

-

       Nothing -> ReferenceScriptNone

-

       Just supp ->

-

         case sLang of

-

           PlutusScriptLanguage PlutusScriptV2 ->

-

             ReferenceScript supp $ toScriptInAnyLang s

-

           SimpleScriptLanguage SimpleScriptV1 ->

-

             ReferenceScriptNone

-

           SimpleScriptLanguage SimpleScriptV2 ->

-

             ReferenceScriptNone

-

           PlutusScriptLanguage PlutusScriptV1 ->

-

             ReferenceScriptNone

+

scriptInEraToRefScript [email protected](ScriptInEra _ s) =

+

  case refInsScriptsAndInlineDatsSupportedInEra era of

+

    Nothing -> ReferenceScriptNone

+

    Just supp ->

+

      -- Any script can be a reference script

+

      ReferenceScript supp $ toScriptInAnyLang s

+

 where

+

  era = shelleyBasedToCardanoEra $ eraOfScriptInEra sIne

-- Helpers

m

cardano-api/src/Cardano/Api/TxBody.hs

+35/-7

      , txout <- toList (Alonzo.outputs' body) ]

    ShelleyBasedEraBabbage ->

-

      map (fromBabbageTxOut ScriptDataInBabbageEra ReferenceTxInsScriptsInlineDatumsInBabbageEra  MultiAssetInBabbageEra)

-

          (toList $ Babbage.outputs body)

+

      [ fromBabbageTxOut

+

          MultiAssetInBabbageEra

+

          ScriptDataInBabbageEra

+

          ReferenceTxInsScriptsInlineDatumsInBabbageEra

+

          txdatums

+

          txouts

+

      | let txdatums = selectTxDatums scriptdata

+

      , txouts <- toList (Babbage.outputs body)

+

  where

    selectTxDatums  TxBodyNoScriptData                            = Map.empty

    selectTxDatums (TxBodyScriptData _ (Alonzo.TxDats' datums) _) = datums

  => ShelleyLedgerEra era ~ ledgerera

  => Ledger.Crypto ledgerera ~ StandardCrypto

  => Ledger.Value ledgerera ~ Mary.Value StandardCrypto

-

  => ScriptDataSupportedInEra era

+

  => MultiAssetSupportedInEra era

+

  -> ScriptDataSupportedInEra era

  -> ReferenceTxInsScriptsInlineDatumsSupportedInEra era

-

  -> MultiAssetSupportedInEra era

+

  -> Map (Alonzo.DataHash StandardCrypto)

+

         (Alonzo.Data ledgerera)

  -> Babbage.TxOut ledgerera

  -> TxOut CtxTx era

-

fromBabbageTxOut s i m (Babbage.TxOut addr val datum mRefScript) =

+

fromBabbageTxOut multiAssetInEra scriptDataInEra inlineDatumsInEra txdatums txout =

   TxOut

     (fromShelleyAddr shelleyBasedEra addr)

-

     (TxOutValue m (fromMaryValue val))

-

     (fromBabbageTxOutDatum s i datum)

+

     (TxOutValue multiAssetInEra (fromMaryValue val))

+

     babbageTxOutDatum

     (case mRefScript of

       SNothing -> ReferenceScriptNone

       SJust rScript -> fromShelleyScriptToReferenceScript shelleyBasedEra rScript

+

 where

+

   -- NOTE: This is different to 'fromBabbageTxOutDatum' as it may resolve

+

   -- 'DatumHash' values using the datums included in the transaction.

+

   babbageTxOutDatum :: TxOutDatum CtxTx era

+

   babbageTxOutDatum =

+

     case datum of

+

       Babbage.NoDatum -> TxOutDatumNone

+

       Babbage.DatumHash dh -> resolveDatumInTx dh

+

       Babbage.Datum d ->

+

         TxOutDatumInline inlineDatumsInEra $

+

           binaryDataToScriptData inlineDatumsInEra d

+

   resolveDatumInTx :: Alonzo.DataHash StandardCrypto -> TxOutDatum CtxTx era

+

   resolveDatumInTx dh

+

      | Just d <- Map.lookup dh txdatums

+

                  = TxOutDatumInTx' scriptDataInEra (ScriptDataHash dh) (fromAlonzoData d)

+

      | otherwise = TxOutDatumHash scriptDataInEra (ScriptDataHash dh)

+

   (Babbage.TxOut addr val datum mRefScript) = txout

fromLedgerTxTotalCollateral

  :: ShelleyBasedEra era

a

cardano-api/test/Test/Cardano/Api/Typed/TxBody.hs

+81/-0

+

{-# LANGUAGE LambdaCase #-}

+

{-# LANGUAGE TemplateHaskell #-}

+

module Test.Cardano.Api.Typed.TxBody

+

  ( tests

+

  ) where

+

import           Cardano.Prelude

+

import           Hedgehog (Property, annotateShow, failure, (===), MonadTest)

+

import qualified Hedgehog as H

+

import           Test.Tasty (TestTree)

+

import           Test.Tasty.Hedgehog (testProperty)

+

import           Test.Tasty.TH (testGroupGenerator)

+

import           Cardano.Api

+

import           Cardano.Api.Shelley (ReferenceScript (..), refScriptToShelleyScript)

+

import           Data.Type.Equality (TestEquality (testEquality))

+

import           Gen.Cardano.Api.Typed

+

import           Test.Cardano.Api.Typed.Orphans ()

+

{- HLINT ignore "Use camelCase" -}

+

-- | Check the txOuts in a TxBodyContent after a ledger roundtrip.

+

prop_roundtrip_txbodycontent_txouts:: Property

+

prop_roundtrip_txbodycontent_txouts =

+

  H.property $ do

+

    content <- H.forAll $ genTxBodyContent BabbageEra

+

    -- Create the ledger body & auxiliaries

+

    body <- case makeTransactionBody content of

+

      Left err -> annotateShow err >> failure

+

      Right body -> pure body

+

    annotateShow body

+

    -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody'

+

    let (TxBody content') = body

+

    matchTxOuts (txOuts content) (txOuts content')

+

 where

+

  matchTxOuts :: MonadTest m => [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra] -> m ()

+

  matchTxOuts as bs =

+

    mapM_ matchTxOut $ zip as bs

+

  matchTxOut :: MonadTest m => (TxOut CtxTx BabbageEra, TxOut CtxTx BabbageEra) -> m ()

+

  matchTxOut (a, b) = do

+

    let TxOut aAddress aValue aDatum aRefScript = a

+

    let TxOut bAddress bValue bDatum bRefScript = b

+

    aAddress === bAddress

+

    aValue === bValue

+

    matchDatum (aDatum, bDatum)

+

    matchRefScript (aRefScript, bRefScript)

+

  -- NOTE: We accept TxOutDatumInTx instead of TxOutDatumHash as it may be

+

  -- correctly resolved given a datum matching the hash was generated.

+

  matchDatum :: MonadTest m => (TxOutDatum CtxTx era, TxOutDatum CtxTx era) -> m ()

+

  matchDatum = \case

+

    (TxOutDatumHash _ dh, TxOutDatumInTx _ d) ->

+

      dh === hashScriptData d

+

    (a, b) ->

+

      a === b

+

  -- NOTE: After Allegra, all eras interpret SimpleScriptV1 as SimpleScriptV2

+

  -- because V2 is a superset of V1. So we accept that as a valid conversion.

+

  matchRefScript :: MonadTest m => (ReferenceScript BabbageEra, ReferenceScript BabbageEra) -> m ()

+

  matchRefScript (a, b)

+

    | isSimpleScriptV1 a && isSimpleScriptV2 b =

+

      refScriptToShelleyScript BabbageEra a === refScriptToShelleyScript BabbageEra b

+

    | otherwise =

+

      a === b

+

  isSimpleScriptV1 :: ReferenceScript era -> Bool

+

  isSimpleScriptV1 = isLang (SimpleScriptLanguage SimpleScriptV1)

+

  isSimpleScriptV2 :: ReferenceScript era -> Bool

+

  isSimpleScriptV2 = isLang (SimpleScriptLanguage SimpleScriptV2)

+

  isLang :: ScriptLanguage a -> ReferenceScript era -> Bool

+

  isLang expected = \case

+

    (ReferenceScript _ (ScriptInAnyLang actual _)) -> isJust $ testEquality expected actual

+

    _ -> False

+

tests :: TestTree

+

tests = $testGroupGenerator

m

cardano-api/test/cardano-api-test.hs

+2/-0

import qualified Test.Cardano.Api.Typed.Ord

import qualified Test.Cardano.Api.Typed.RawBytes

import qualified Test.Cardano.Api.Typed.Script

+

import qualified Test.Cardano.Api.Typed.TxBody

import qualified Test.Cardano.Api.Typed.Value

main :: IO ()

    , Test.Cardano.Api.Typed.Ord.tests

    , Test.Cardano.Api.Typed.RawBytes.tests

    , Test.Cardano.Api.Typed.Script.tests

+

    , Test.Cardano.Api.Typed.TxBody.tests

    , Test.Cardano.Api.Typed.Value.tests

m

cardano-node/src/Cardano/Node/Run.hs

+55/-52

{-# LANGUAGE NamedFieldPuns #-}

{-# LANGUAGE PackageImports #-}

{-# LANGUAGE ScopedTypeVariables #-}

-

{-# LANGUAGE TupleSections #-}

{-# LANGUAGE TypeApplications #-}

#if !defined(mingw32_HOST_OS)

      let fp = maybe  "No file path found!"

                      unConfigPath

                      (getLast (pncConfigFile cmdPc))

-

      (tracers, mLoggingLayer) <-

-

        case ncTraceConfig nc of

-

          TraceDispatcher{} -> do

-

            (, Nothing) <$>

-

              initTraceDispatcher

-

nc

-

                networkMagic

-

                nodeKernelData

-

                p2pMode

-

          _ -> do

-

            eLoggingLayer <- runExceptT $ createLoggingLayer

-

              (Text.pack (showVersion version))

+

      case ncTraceConfig nc of

+

        TraceDispatcher{} -> do

+

          tracers <-

+

            initTraceDispatcher

nc

-

            loggingLayer <- case eLoggingLayer of

-

              Left err  -> putTextLn (Text.pack $ show err) >> exitFailure

-

              Right res -> return res

-

            !trace <- setupTrace loggingLayer

-

            let tracer = contramap pack $ toLogObject trace

-

            logTracingVerbosity nc tracer

-

            -- Legacy logging infrastructure must trace 'nodeStartTime' and 'nodeBasicInfo'.

-

            startTime <- getCurrentTime

-

            traceCounter "nodeStartTime" trace (ceiling $ utcTimeToPOSIXSeconds startTime)

-

            nbi <- nodeBasicInfo nc p startTime

-

            forM_ nbi $ \(LogObject nm mt content) ->

-

              traceNamedObject (appendName nm trace) (mt, content)

-

            (,Just loggingLayer) <$>

-

              mkTracers

-

                (Consensus.configBlock cfg)

-

                (ncTraceConfig nc)

-

                trace

-

                nodeKernelData

-

                (llEKGDirect loggingLayer)

-

                p2pMode

-

      getStartupInfo nc p fp

-

        >>= mapM_ (traceWith $ startupTracer tracers)

-

      Async.withAsync (handlePeersListSimple (error "Implement Tracer IO [Peer blk]") nodeKernelData)

-

          $ \_peerLoggingThread ->

-

            -- We ignore peer logging thread if it dies, but it will be killed

-

            -- when 'handleSimpleNode' terminates.

-

                handleSimpleNode runP p2pMode tracers nc

-

                  (\nk -> do

-

                      setNodeKernel nodeKernelData nk

-

                      traceWith (nodeStateTracer tracers) NodeKernelOnline)

-

                `finally`

-

                forM_ mLoggingLayer

-

                  shutdownLoggingLayer

+

              networkMagic

+

              nodeKernelData

+

              p2pMode

+

          handleSimpleNode runP p2pMode tracers nc

+

            (\nk -> do

+

                setNodeKernel nodeKernelData nk

+

                traceWith (nodeStateTracer tracers) NodeKernelOnline)

+

        _ -> do

+

          eLoggingLayer <- runExceptT $ createLoggingLayer

+

            (Text.pack (showVersion version))

+

nc

+

          loggingLayer <- case eLoggingLayer of

+

            Left err  -> putTextLn (Text.pack $ show err) >> exitFailure

+

            Right res -> return res

+

          !trace <- setupTrace loggingLayer

+

          let tracer = contramap pack $ toLogObject trace

+

          logTracingVerbosity nc tracer

+

          -- Legacy logging infrastructure must trace 'nodeStartTime' and 'nodeBasicInfo'.

+

          startTime <- getCurrentTime

+

          traceCounter "nodeStartTime" trace (ceiling $ utcTimeToPOSIXSeconds startTime)

+

          nbi <- nodeBasicInfo nc p startTime

+

          forM_ nbi $ \(LogObject nm mt content) ->

+

            traceNamedObject (appendName nm trace) (mt, content)

+

          tracers <-

+

            mkTracers

+

              (Consensus.configBlock cfg)

+

              (ncTraceConfig nc)

+

              trace

+

              nodeKernelData

+

              (llEKGDirect loggingLayer)

+

              p2pMode

+

          getStartupInfo nc p fp

+

            >>= mapM_ (traceWith $ startupTracer tracers)

+

          Async.withAsync (handlePeersListSimple (error "Implement Tracer IO [Peer blk]") nodeKernelData)

+

              $ \_peerLoggingThread ->

+

                -- We ignore peer logging thread if it dies, but it will be killed

+

                -- when 'handleSimpleNode' terminates.

+

                    handleSimpleNode runP p2pMode tracers nc

+

                      (\nk -> do

+

                          setNodeKernel nodeKernelData nk

+

                          traceWith (nodeStateTracer tracers) NodeKernelOnline)

+

                    `finally`

+

                    forM_ eLoggingLayer

+

                      shutdownLoggingLayer

logTracingVerbosity :: NodeConfiguration -> Tracer IO String -> IO ()

m

cardano-node/src/Cardano/Node/Tracing/Tracers.hs

+16/-11

mkDispatchTracers nodeKernel trBase trForward mbTrEKG trDataPoint trConfig enableP2P p = do

    -- Some special tracers

    -- NodeInfo tracer

-

    nodeInfoTr <- mkDataPointTracer

+

    nodeInfoDP <- mkDataPointTracer

                trDataPoint

                (const ["NodeInfo"])

-

    configureTracers trConfig docNodeInfoTraceEvent [nodeInfoTr]

+

    configureTracers trConfig docNodeInfoTraceEvent [nodeInfoDP]

-

    nodeStateTr <- mkDataPointTracer

+

    nodeStateDP <- mkDataPointTracer

                trDataPoint

                (const ["NodeState"])

                allPublic

    configureTracers trConfig SR.docNodeState [stateTr]

-

    nodePeersTr <- mkDataPointTracer

+

    nodePeersDP <- mkDataPointTracer

                trDataPoint

                (const ["NodePeers"])

    diffusionTrExtra :: Diffusion.ExtraTracers p2p <-

      mkDiffusionTracersExtra trBase trForward mbTrEKG trDataPoint trConfig enableP2P

    pure Tracers

-

      { chainDBTracer = Tracer (\x -> traceWith chainDBTr' x >> SR.traceNodeStateChainDB p nodeStateTr x)

-

                     <> Tracer (\x -> traceWith replayBlockTr' x >> SR.traceNodeStateChainDB p nodeStateTr x)

+

      { chainDBTracer = Tracer (traceWith chainDBTr')

+

                     <> Tracer (traceWith replayBlockTr')

+

                     <> Tracer (SR.traceNodeStateChainDB p nodeStateDP)

      , consensusTracers = consensusTr

      , nodeToClientTracers = nodeToClientTr

      , nodeToNodeTracers = nodeToNodeTr

      , diffusionTracers = diffusionTr

      , diffusionTracersExtra = diffusionTrExtra

-

      , startupTracer = Tracer $ \x -> traceWith startupTr x >> SR.traceNodeStateStartup nodeStateTr x

-

      , shutdownTracer = Tracer $ \x -> traceWith shutdownTr x >> SR.traceNodeStateShutdown nodeStateTr x

-

      , nodeInfoTracer = Tracer (traceWith nodeInfoTr)

-

      , nodeStateTracer = Tracer (traceWith stateTr) <> Tracer (traceWith nodeStateTr)

+

      , startupTracer   = Tracer (traceWith startupTr)

+

                        <> Tracer (SR.traceNodeStateStartup nodeStateDP)

+

      , shutdownTracer  = Tracer (traceWith shutdownTr)

+

                        <> Tracer (SR.traceNodeStateShutdown nodeStateDP)

+

      , nodeInfoTracer  = Tracer (traceWith nodeInfoDP)

+

      , nodeStateTracer = Tracer (traceWith stateTr)

+

                        <> Tracer (traceWith nodeStateDP)

      , resourcesTracer = Tracer (traceWith resourcesTr)

-

      , peersTracer = Tracer $ \x -> traceWith peersTr x >> traceNodePeers nodePeersTr x

+

      , peersTracer     = Tracer (traceWith peersTr)

+

                        <> Tracer (traceNodePeers nodePeersDP)

mkConsensusTracers :: forall blk.

m

cardano-tracer/bench/cardano-tracer-bench.hs

+10/-6

import           Cardano.Tracer.Configuration

import           Cardano.Tracer.Handlers.Logs.TraceObjects (traceObjectsHandler)

+

import           Cardano.Tracer.Handlers.RTView.State.TraceObjects (initSavedTraceObjects)

import           Cardano.Tracer.Types (NodeId (..))

main :: IO ()

  to100  <- generate 100

  to1000 <- generate 1000

+

  savedTO <- initSavedTraceObjects

+

  removePathForcibly root

  defaultMain

    [ bgroup "cardano-tracer"

      [ -- 10 'TraceObject's per request.

-

        bench "Handle TraceObjects LOG,  10"   $ whnfIO $ traceObjectsHandler c1 nId lock to10

-

      , bench "Handle TraceObjects JSON, 10"   $ whnfIO $ traceObjectsHandler c2 nId lock to10

+

        bench "Handle TraceObjects LOG,  10"   $ whnfIO $ traceObjectsHandler c1 nId lock savedTO to10

+

      , bench "Handle TraceObjects JSON, 10"   $ whnfIO $ traceObjectsHandler c2 nId lock savedTO to10

        -- 100 'TraceObject's per request.

-

      , bench "Handle TraceObjects LOG,  100"  $ whnfIO $ traceObjectsHandler c1 nId lock to100

-

      , bench "Handle TraceObjects JSON, 100"  $ whnfIO $ traceObjectsHandler c2 nId lock to100

+

      , bench "Handle TraceObjects LOG,  100"  $ whnfIO $ traceObjectsHandler c1 nId lock savedTO to100

+

      , bench "Handle TraceObjects JSON, 100"  $ whnfIO $ traceObjectsHandler c2 nId lock savedTO to100

        -- 1000 'TraceObject's per request.

-

      , bench "Handle TraceObjects LOG,  1000" $ whnfIO $ traceObjectsHandler c1 nId lock to1000

-

      , bench "Handle TraceObjects JSON, 1000" $ whnfIO $ traceObjectsHandler c2 nId lock to1000

+

      , bench "Handle TraceObjects LOG,  1000" $ whnfIO $ traceObjectsHandler c1 nId lock savedTO to1000

+

      , bench "Handle TraceObjects JSON, 1000" $ whnfIO $ traceObjectsHandler c2 nId lock savedTO to1000

 where

    , ekgRequestFreq = Nothing

    , hasEKG         = Nothing

    , hasPrometheus  = Nothing

+

    , hasRTView      = Nothing

    , logging        = NE.fromList [LoggingParams root FileMode format]

    , rotation       = Nothing

    , verbosity      = Nothing

m

cardano-tracer/cardano-tracer.cabal

+53/-0

                       Cardano.Tracer.Handlers.Metrics.Monitoring

                       Cardano.Tracer.Handlers.Metrics.Prometheus

                       Cardano.Tracer.Handlers.Metrics.Servers

+

                       Cardano.Tracer.Handlers.Metrics.Utils

+

                       Cardano.Tracer.Handlers.RTView.Run

+

                       Cardano.Tracer.Handlers.RTView.State.Displayed

+

                       Cardano.Tracer.Handlers.RTView.State.EraSettings

+

                       Cardano.Tracer.Handlers.RTView.State.Errors

+

                       Cardano.Tracer.Handlers.RTView.State.Historical

+

                       Cardano.Tracer.Handlers.RTView.State.Last

+

                       Cardano.Tracer.Handlers.RTView.State.Peers

+

                       Cardano.Tracer.Handlers.RTView.State.TraceObjects

+

                       Cardano.Tracer.Handlers.RTView.System

+

                       Cardano.Tracer.Handlers.RTView.UI.CSS.Bulma

+

                       Cardano.Tracer.Handlers.RTView.UI.CSS.Own

+

                       Cardano.Tracer.Handlers.RTView.UI.HTML.Node.Column

+

                       Cardano.Tracer.Handlers.RTView.UI.HTML.Node.EKG

+

                       Cardano.Tracer.Handlers.RTView.UI.HTML.Node.Errors

+

                       Cardano.Tracer.Handlers.RTView.UI.HTML.Node.Peers

+

                       Cardano.Tracer.Handlers.RTView.UI.HTML.About

+

                       Cardano.Tracer.Handlers.RTView.UI.HTML.Body

+

                       Cardano.Tracer.Handlers.RTView.UI.HTML.Main

+

                       Cardano.Tracer.Handlers.RTView.UI.HTML.NoNodes

+

                       Cardano.Tracer.Handlers.RTView.UI.HTML.Notifications

+

                       Cardano.Tracer.Handlers.RTView.UI.JS.ChartJS

+

                       Cardano.Tracer.Handlers.RTView.UI.JS.Charts

+

                       Cardano.Tracer.Handlers.RTView.UI.JS.Utils

+

                       Cardano.Tracer.Handlers.RTView.UI.Img.Icons

+

                       Cardano.Tracer.Handlers.RTView.UI.Charts

+

                       Cardano.Tracer.Handlers.RTView.UI.Theme

+

                       Cardano.Tracer.Handlers.RTView.UI.Types

+

                       Cardano.Tracer.Handlers.RTView.UI.Utils

+

                       Cardano.Tracer.Handlers.RTView.Update.Chain

+

                       Cardano.Tracer.Handlers.RTView.Update.EKG

+

                       Cardano.Tracer.Handlers.RTView.Update.EraSettings

+

                       Cardano.Tracer.Handlers.RTView.Update.Errors

+

                       Cardano.Tracer.Handlers.RTView.Update.Historical

+

                       Cardano.Tracer.Handlers.RTView.Update.KES

+

                       Cardano.Tracer.Handlers.RTView.Update.Leadership

+

                       Cardano.Tracer.Handlers.RTView.Update.NodeInfo

+

                       Cardano.Tracer.Handlers.RTView.Update.NodeState

+

                       Cardano.Tracer.Handlers.RTView.Update.Nodes

+

                       Cardano.Tracer.Handlers.RTView.Update.Peers

+

                       Cardano.Tracer.Handlers.RTView.Update.Reload

+

                       Cardano.Tracer.Handlers.RTView.Update.Resources

+

                       Cardano.Tracer.Handlers.RTView.Update.Transactions

+

                       Cardano.Tracer.Handlers.RTView.Update.Utils

                       Cardano.Tracer.CLI

                       Cardano.Tracer.Configuration

                       , blaze-html

                       , blaze-markup

                       , bytestring

+

                       , cardano-git-rev

+

                       , cardano-node

                       , cborg

                       , containers

                       , contra-tracer

                       , snap-core

                       , snap-server

                       , stm

+

                       , string-qq

                       , text

                       , threepenny-gui

                       , time

  if os(linux)

    build-depends:     libsystemd-journal

+

  if os(windows)

+

    build-depends:     Win32

+

  else

+

    build-depends:     unix

+

executable cardano-tracer

  import:              base, project-config

m

cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs

+7/-4

                   prepareMetricsStores, removeDisconnectedNode)

import qualified Cardano.Tracer.Configuration as TC

import           Cardano.Tracer.Handlers.Logs.TraceObjects (traceObjectsHandler)

+

import           Cardano.Tracer.Handlers.RTView.Run (SavedTraceObjects)

import           Cardano.Tracer.Types (AcceptedMetrics, ConnectedNodes, DataPointRequestors)

import           Cardano.Tracer.Utils (connIdToNodeId)

  -> ConnectedNodes

  -> AcceptedMetrics

+

  -> SavedTraceObjects

  -> DataPointRequestors

  -> Lock

  -> IO ()

runAcceptorsClient config p (ekgConfig, tfConfig, dpfConfig)

-

                   connectedNodes acceptedMetrics dpRequestors currentLogLock =

+

                   connectedNodes acceptedMetrics savedTO dpRequestors currentLogLock =

  withIOManager $ \iocp ->

    doConnectToForwarder

      (localSnocket iocp)

      -- there is no mechanism to disable some of them.

      appInitiator

        [ (runEKGAcceptorInit ekgConfig connectedNodes acceptedMetrics errorHandler, 1)

-

        , (runTraceObjectsAcceptorInit config tfConfig currentLogLock  errorHandler, 2)

+

        , (runTraceObjectsAcceptorInit config tfConfig currentLogLock savedTO errorHandler, 2)

        , (runDataPointsAcceptorInit dpfConfig connectedNodes dpRequestors errorHandler, 3)

 where

  :: TC.TracerConfig

  -> TF.AcceptorConfiguration TraceObject

  -> Lock

+

  -> SavedTraceObjects

  -> (ConnectionId LocalAddress -> IO ())

  -> ConnectionId LocalAddress

  -> RunMiniProtocol 'InitiatorMode LBS.ByteString IO () Void

-

runTraceObjectsAcceptorInit config tfConfig currentLogLock errorHandler connId =

+

runTraceObjectsAcceptorInit config tfConfig currentLogLock savedTO errorHandler connId =

  acceptTraceObjectsInit

    tfConfig

-

    (traceObjectsHandler config (connIdToNodeId connId) currentLogLock)

+

    (traceObjectsHandler config (connIdToNodeId connId) currentLogLock savedTO)

    (errorHandler connId)

runDataPointsAcceptorInit

m

cardano-tracer/src/Cardano/Tracer/Acceptors/Run.hs

+5/-3

import           Cardano.Tracer.Acceptors.Client (runAcceptorsClient)

import           Cardano.Tracer.Acceptors.Server (runAcceptorsServer)

import           Cardano.Tracer.Configuration

+

import           Cardano.Tracer.Handlers.RTView.Run (SavedTraceObjects)

import           Cardano.Tracer.Types (AcceptedMetrics, ConnectedNodes,

                   DataPointRequestors, ProtocolsBrake)

import           Cardano.Tracer.Utils (runInLoop)

  :: TracerConfig

  -> ConnectedNodes

  -> AcceptedMetrics

+

  -> SavedTraceObjects

  -> DataPointRequestors

  -> ProtocolsBrake

  -> Lock

  -> IO ()

runAcceptors [email protected]{network, ekgRequestFreq, loRequestNum, verbosity}

-

             connectedNodes acceptedMetrics dpRequestors stopIt currentLogLock =

+

             connectedNodes acceptedMetrics savedTO dpRequestors stopIt currentLogLock =

  case network of

    AcceptAt (LocalSocket p) ->

      -- Run one server that accepts connections from the nodes.

      runInLoop

        (runAcceptorsServer c p (acceptorsConfigs p) connectedNodes

-

                            acceptedMetrics dpRequestors currentLogLock)

+

                            acceptedMetrics savedTO dpRequestors currentLogLock)

        verbosity p 1

    ConnectTo localSocks ->

      -- Run N clients that initiate connections to the nodes.

      forConcurrently_ (NE.nub localSocks) $ \(LocalSocket p) ->

        runInLoop

          (runAcceptorsClient c p (acceptorsConfigs p) connectedNodes

-

                              acceptedMetrics dpRequestors currentLogLock)

+

                              acceptedMetrics savedTO dpRequestors currentLogLock)

          verbosity p 1

 where

  acceptorsConfigs p =

m

cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs

+8/-5

                   prepareMetricsStores, removeDisconnectedNode)

import qualified Cardano.Tracer.Configuration as TC

import           Cardano.Tracer.Handlers.Logs.TraceObjects (traceObjectsHandler)

+

import           Cardano.Tracer.Handlers.RTView.Run (SavedTraceObjects)

import           Cardano.Tracer.Types (AcceptedMetrics, ConnectedNodes, DataPointRequestors)

import           Cardano.Tracer.Utils (connIdToNodeId)

  -> ConnectedNodes

  -> AcceptedMetrics

+

  -> SavedTraceObjects

  -> DataPointRequestors

  -> Lock

  -> IO ()

-

runAcceptorsServer config p (ekgConfig, tfConfig, dpfConfig)

-

                   connectedNodes acceptedMetrics dpRequestors currentLogLock = withIOManager $ \iocp ->

+

runAcceptorsServer config p (ekgConfig, tfConfig, dpfConfig) connectedNodes

+

                   acceptedMetrics savedTO dpRequestors currentLogLock = withIOManager $ \iocp ->

  doListenToForwarder

    (localSnocket iocp)

    (localAddressFromPath p)

    -- there is no mechanism to disable some of them.

    appResponder

      [ (runEKGAcceptor ekgConfig connectedNodes acceptedMetrics errorHandler, 1)

-

      , (runTraceObjectsAcceptor config tfConfig currentLogLock  errorHandler, 2)

+

      , (runTraceObjectsAcceptor config tfConfig currentLogLock savedTO errorHandler, 2)

      , (runDataPointsAcceptor dpfConfig connectedNodes dpRequestors errorHandler, 3)

 where

  :: TC.TracerConfig

  -> TF.AcceptorConfiguration TraceObject

  -> Lock

+

  -> SavedTraceObjects

  -> (ConnectionId LocalAddress -> IO ())

  -> ConnectionId LocalAddress

  -> RunMiniProtocol 'ResponderMode LBS.ByteString IO Void ()

-

runTraceObjectsAcceptor config tfConfig currentLogLock errorHandler connId =

+

runTraceObjectsAcceptor config tfConfig currentLogLock savedTO errorHandler connId =

  acceptTraceObjectsResp

    tfConfig

-

    (traceObjectsHandler config (connIdToNodeId connId) currentLogLock)

+

    (traceObjectsHandler config (connIdToNodeId connId) currentLogLock savedTO)

    (errorHandler connId)

runDataPointsAcceptor

m

cardano-tracer/src/Cardano/Tracer/CLI.hs

+8/-8

-- | Parse CLI parameters for the tracer.

parseTracerParams :: Parser TracerParams

-

parseTracerParams = TracerParams <$>

-

  strOption

-

    (    long "config"

-

      <> short 'c'

-

      <> metavar "FILEPATH"

-

      <> help "Configuration file for cardano-tracer"

-

      <> completer (bashCompleter "file")

-

+

parseTracerParams = TracerParams

+

  <$> strOption

+

        (    long "config"

+

          <> short 'c'

+

          <> metavar "FILEPATH"

+

          <> help "Configuration file for cardano-tracer"

+

          <> completer (bashCompleter "file")

+

m

cardano-tracer/src/Cardano/Tracer/Configuration.hs

+3/-1

  , ekgRequestFreq :: !(Maybe Pico)                 -- ^ How often to request for EKG-metrics, in seconds.

  , hasEKG         :: !(Maybe (Endpoint, Endpoint)) -- ^ Endpoint for EKG web-page (list of nodes, monitoring).

  , hasPrometheus  :: !(Maybe Endpoint)             -- ^ Endpoint for Promeheus web-page.

+

  , hasRTView      :: !(Maybe Endpoint)             -- ^ Endpoint for RTView web-page.

  , logging        :: !(NonEmpty LoggingParams)     -- ^ Logging parameters.

  , rotation       :: !(Maybe RotationParams)       -- ^ Rotation parameters.

  , verbosity      :: !(Maybe Verbosity)            -- ^ Verbosity of the tracer itself.

        Right _ -> return config

checkMeaninglessValues :: TracerConfig -> Either String ()

-

checkMeaninglessValues TracerConfig{network, hasEKG, hasPrometheus, logging} =

+

checkMeaninglessValues TracerConfig{network, hasEKG, hasPrometheus, hasRTView, logging} =

  if null problems

    then Right ()

    else Left $ intercalate ", " problems

    , check "empty logRoot(s)" $ notNull . NE.filter invalidFileMode $ logging

    , (check "no host(s) in hasEKG" . nullEndpoints) =<< hasEKG

    , (check "no host in hasPrometheus" . nullEndpoint) =<< hasPrometheus

+

    , (check "no host in hasRTView" . nullEndpoint) =<< hasRTView

  check msg cond = if cond then Just msg else Nothing

m

cardano-tracer/src/Cardano/Tracer/Handlers/Logs/TraceObjects.hs

+12/-6

import           Control.Concurrent.Async (forConcurrently_)

import           Control.Concurrent.Extra (Lock)

+

import           Control.Monad.Extra (whenJust)

import qualified Data.List.NonEmpty as NE

import           Cardano.Logging (TraceObject)

import           Cardano.Tracer.Configuration

import           Cardano.Tracer.Handlers.Logs.File (writeTraceObjectsToFile)

import           Cardano.Tracer.Handlers.Logs.Journal (writeTraceObjectsToJournal)

+

import           Cardano.Tracer.Handlers.RTView.Run (SavedTraceObjects, saveTraceObjects)

import           Cardano.Tracer.Types (NodeId)

import           Cardano.Tracer.Utils (showProblemIfAny)

-- | This handler is called periodically by 'TraceObjectForward' protocol

--   from 'trace-forward' library.

traceObjectsHandler

-

  :: TracerConfig  -- ^ Tracer configuration.

-

  -> NodeId        -- ^ An id of the node 'TraceObject's were received from.

-

  -> Lock          -- ^ The lock we use for single-threaded access to the current log.

-

  -> [TraceObject] -- ^ The list of received 'TraceObject's (may be empty).

+

  :: TracerConfig      -- ^ Tracer configuration.

+

  -> NodeId            -- ^ An id of the node 'TraceObject's were received from.

+

  -> Lock              -- ^ The lock we use for single-threaded access to the current log.

+

  -> SavedTraceObjects -- ^ The buffer for accepted 'TraceObject's, used by RTView service.

+

  -> [TraceObject]     -- ^ The list of received 'TraceObject's (may be empty).

  -> IO ()

-

traceObjectsHandler _ _ _ [] = return ()

-

traceObjectsHandler TracerConfig{logging, verbosity} nodeId currentLogLock traceObjects =

+

traceObjectsHandler _ _ _ _ [] = return ()

+

traceObjectsHandler TracerConfig{logging, verbosity, hasRTView}

+

                    nodeId currentLogLock savedTO traceObjects = do

  forConcurrently_ (NE.nub logging) $ \LoggingParams{logMode, logRoot, logFormat} ->

    showProblemIfAny verbosity $

      case logMode of

        FileMode    -> writeTraceObjectsToFile nodeId currentLogLock logRoot logFormat traceObjects

        JournalMode -> writeTraceObjectsToJournal nodeId traceObjects

+

  whenJust hasRTView . const $

+

    saveTraceObjects savedTO nodeId traceObjects

m

cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Monitoring.hs

+4/-1

import qualified Graphics.UI.Threepenny as UI

import           Graphics.UI.Threepenny.Core (UI, Element, liftIO, set, (#), (#+))

import           System.Remote.Monitoring (forkServerWith, serverThreadId)

+

import           System.Time.Extra (sleep)

import           Cardano.Tracer.Configuration (Endpoint (..))

import           Cardano.Tracer.Types (AcceptedMetrics, ConnectedNodes, NodeId (..))

  -> ConnectedNodes

  -> AcceptedMetrics

  -> IO ()

-

runMonitoringServer (Endpoint listHost listPort, monitorEP) connectedNodes acceptedMetrics =

+

runMonitoringServer (Endpoint listHost listPort, monitorEP) connectedNodes acceptedMetrics = do

+

  -- Pause to prevent collision between "Listening"-notifications from servers.

+

  sleep 0.2

  UI.startGUI config $ \window -> do

    void $ return window # set UI.title "EKG Monitoring Nodes"

    void $ mkPageBody window connectedNodes monitorEP acceptedMetrics

m

cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Prometheus.hs

+2/-0

  -> AcceptedMetrics

  -> IO ()

runPrometheusServer (Endpoint host port) connectedNodes acceptedMetrics = forever $ do

+

  -- Pause to prevent collision between "Listening"-notifications from servers.

+

  sleep 0.1

  -- If everything is okay, the function 'simpleHttpServe' never returns.

  -- But if there is some problem, it never throws an exception, but just stops.

  -- So if it stopped - it will be re-started.

a

cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Utils.hs

+26/-0

+

module Cardano.Tracer.Handlers.Metrics.Utils

+

  ( MetricName

+

  , MetricValue

+

  , MetricsList

+

  , getListOfMetrics

+

  ) where

+

import qualified Data.HashMap.Strict as HM

+

import           Data.Maybe (mapMaybe)

+

import           Data.Text (Text)

+

import qualified Data.Text as T

+

import           System.Metrics (Store, Value (..), sampleAll)

+

type MetricName  = Text

+

type MetricValue = Text

+

type MetricsList = [(MetricName, MetricValue)]

+

getListOfMetrics :: Store -> IO MetricsList

+

getListOfMetrics = fmap (mapMaybe metricsWeNeed . HM.toList) . sampleAll

+

 where

+

  metricsWeNeed (mName, mValue) =

+

    case mValue of

+

      Counter c -> Just (mName, T.pack $ show c)

+

      Gauge g   -> Just (mName, T.pack $ show g)

+

      Label l   -> Just (mName, l)

+

      _         -> Nothing -- 'ekg-forward' doesn't support 'Distribution' yet.

a

cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Run.hs

+103/-0

+

{-# LANGUAGE NamedFieldPuns #-}

+

module Cardano.Tracer.Handlers.RTView.Run

+

  ( runRTView

+

  , module Cardano.Tracer.Handlers.RTView.State.TraceObjects

+

  ) where

+

import           Control.Concurrent.Async.Extra (sequenceConcurrently)

+

import           Control.Monad (void)

+

import           Control.Monad.Extra (whenJust)

+

import qualified Data.Text as T

+

import           Data.Text.Encoding (encodeUtf8)

+

import qualified Graphics.UI.Threepenny as UI

+

import           System.Time.Extra (sleep)

+

import           Cardano.Tracer.Configuration

+

import           Cardano.Tracer.Handlers.RTView.State.EraSettings

+

import           Cardano.Tracer.Handlers.RTView.State.Displayed

+

import           Cardano.Tracer.Handlers.RTView.State.Errors

+

import           Cardano.Tracer.Handlers.RTView.State.Historical

+

import           Cardano.Tracer.Handlers.RTView.State.Last

+

import           Cardano.Tracer.Handlers.RTView.State.TraceObjects

+

import           Cardano.Tracer.Handlers.RTView.UI.HTML.Main

+

import           Cardano.Tracer.Handlers.RTView.Update.EraSettings

+

import           Cardano.Tracer.Handlers.RTView.Update.Errors

+

import           Cardano.Tracer.Handlers.RTView.Update.Historical

+

import           Cardano.Tracer.Types

+

-- | RTView is a part of 'cardano-tracer' that provides an ability

+

--   to monitor Cardano nodes in a real-time. The core idea is simple:

+

--   RTView periodically receives some informations from the connected

+

--   node(s) and displays that information on a web-page.

+

--

+

--   The web-page is built using 'threepenny-gui' library. Please note

+

--   Gitub-version of this library is used, not Hackage-version!

+

--

+

--   TODO ...

+

runRTView

+

  :: TracerConfig

+

  -> ConnectedNodes

+

  -> AcceptedMetrics

+

  -> SavedTraceObjects

+

  -> DataPointRequestors

+

  -> IO ()

+

runRTView TracerConfig{logging, network, hasRTView}

+

          connectedNodes acceptedMetrics savedTO dpRequestors =

+

  whenJust hasRTView $ \(Endpoint host port) -> do

+

    -- Pause to prevent collision between "Listening"-notifications from servers.

+

    sleep 0.3

+

    -- Initialize displayed stuff outside of main page renderer,

+

    -- to be able to update corresponding elements after page reloading.

+

    displayedElements <- initDisplayedElements

+

    reloadFlag <- initPageReloadFlag

+

    -- We have to collect different information from the node and save it

+

    -- independently from RTView web-server. As a result, we'll be able to

+

    -- show charts with historical data (where X axis is the time) for the

+

    -- period when RTView web-page wasn't opened.

+

    resourcesHistory <- initResourcesHistory

+

    lastResources <- initLastResources

+

    chainHistory <- initBlockchainHistory

+

    txHistory <- initTransactionsHistory

+

    eraSettings <- initErasSettings

+

    errors <- initErrors

+

    void . sequenceConcurrently $

+

      [ UI.startGUI (config host port) $

+

          mkMainPage

+

            connectedNodes

+

            displayedElements

+

            acceptedMetrics

+

            savedTO

+

            eraSettings

+

            dpRequestors

+

            reloadFlag

+

            logging

+

            network

+

            resourcesHistory

+

            chainHistory

+

            txHistory

+

            errors

+

      , runHistoricalUpdater

+

          savedTO

+

          acceptedMetrics

+

          resourcesHistory

+

          lastResources

+

          chainHistory

+

          txHistory

+

      , runEraSettingsUpdater

+

          connectedNodes

+

          eraSettings

+

          savedTO

+

      , runErrorsUpdater

+

          connectedNodes

+

          errors

+

          savedTO

+

 where

+

  config h p = UI.defaultConfig

+

    { UI.jsPort = Just . fromIntegral $ p

+

    , UI.jsAddr = Just . encodeUtf8 . T.pack $ h

+

    , UI.jsLog  = const $ return () -- To hide 'threepenny-gui' internal messages.

+

a

cardano-tracer/src/Cardano/Tracer/Handlers/RTView/State/Displayed.hs

+125/-0

Diff too large – View on GitHub

2,741 commits this week Jun 19, 2022 - Jun 26, 2022

Showing 25 of 2741 recent commits.

Yesterday's Report

New Repo Discovered

New Releases