diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 22e6f76dfc2..cd023f3aab9 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -123,6 +123,7 @@ library , bytestring , cardano-git-rev , cardano-node + , cassava , cborg , containers , contra-tracer @@ -137,6 +138,7 @@ library , optparse-applicative , ouroboros-network , ouroboros-network-framework + , signal , smtp-mail == 0.3.0.0 , snap-blaze , snap-core @@ -149,6 +151,7 @@ library , trace-dispatcher , trace-forward , unordered-containers + , vector , yaml if os(linux) diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Run.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Run.hs index f2073731cac..8bd69d4aaf5 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Run.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Run.hs @@ -45,12 +45,16 @@ runRTView -> ConnectedNodes -> AcceptedMetrics -> SavedTraceObjects + -> BlockchainHistory + -> ResourcesHistory + -> TransactionsHistory -> DataPointRequestors -> Lock -> EventsQueues -> IO () runRTView TracerConfig{logging, network, hasRTView} connectedNodes acceptedMetrics savedTO + chainHistory resourcesHistory txHistory dpRequestors currentDPLock eventsQueues = whenJust hasRTView $ \(Endpoint host port) -> do -- Pause to prevent collision between "Listening"-notifications from servers. @@ -65,12 +69,9 @@ runRTView TracerConfig{logging, network, hasRTView} -- 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 + lastResources <- initLastResources + eraSettings <- initErasSettings + errors <- initErrors void . sequenceConcurrently $ [ UI.startGUI (config host port certFile keyFile) $ @@ -97,6 +98,13 @@ runRTView TracerConfig{logging, network, hasRTView} lastResources chainHistory txHistory + , runHistoricalBackup + connectedNodes + chainHistory + resourcesHistory + txHistory + dpRequestors + currentDPLock , runEraSettingsUpdater connectedNodes eraSettings diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/State/Historical.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/State/Historical.hs index d98d71b3207..498c0fb0d4c 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/State/Historical.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/State/Historical.hs @@ -1,10 +1,13 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Cardano.Tracer.Handlers.RTView.State.Historical ( BlockchainHistory (..) , DataName (..) , History , HistoricalPoint + , HistoricalPoints , POSIXTime , ResourcesHistory (..) , TransactionsHistory (..) @@ -20,14 +23,19 @@ module Cardano.Tracer.Handlers.RTView.State.Historical import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVarIO) +import Control.Monad (mzero) +import qualified Data.ByteString.Char8 as BSC +import Data.Csv (FromField (..), ToField (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Set (Set) import qualified Data.Set as S -import Data.Text (Text) +import Data.Text (Text, isInfixOf) +import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal, double) import Data.Time.Clock (UTCTime) import Data.Word (Word64) +import Text.Printf (printf) import Cardano.Tracer.Handlers.RTView.Update.Utils import Cardano.Tracer.Types (NodeId) @@ -73,6 +81,17 @@ instance Num ValueH where type HistoricalPoint = (POSIXTime, ValueH) +instance FromField ValueH where + parseField s = + let t = decodeUtf8 s in + if "." `isInfixOf` t + then either (const mzero) (return . ValueD . fst) $ double t + else either (const mzero) (return . ValueI . fst) $ decimal t + +instance ToField ValueH where + toField (ValueI i) = toField i + toField (ValueD d) = BSC.pack $ printf "%.3f" d + type HistoricalPoints = Set HistoricalPoint -- | Historical points for particular data. @@ -104,7 +123,7 @@ data DataName | TxsProcessedNumData | MempoolBytesData | TxsInMempoolData - deriving (Eq, Ord) + deriving (Eq, Ord, Read, Show) type HistoricalData = Map DataName HistoricalPoints type History = TVar (Map NodeId HistoricalData) diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/System.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/System.hs index 8902b4bf491..617cb211edd 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/System.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/System.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} module Cardano.Tracer.Handlers.RTView.System - ( getPathToChartsConfig + ( getPathToBackupDir + , getPathToChartsConfig , getPathToThemeConfig , getPathsToNotificationsSettings , getPathsToSSLCerts @@ -59,6 +60,16 @@ getPathsToNotificationsSettings = do getPathToConfigDir :: IO FilePath getPathToConfigDir = do configDir <- D.getXdgDirectory D.XdgConfig "" - let pathToRTViewConfigDir = configDir "cardano-rt-view" + let pathToRTViewConfigDir = configDir rtViewRootDir D.createDirectoryIfMissing True pathToRTViewConfigDir return pathToRTViewConfigDir + +getPathToBackupDir :: IO FilePath +getPathToBackupDir = do + dataDir <- D.getXdgDirectory D.XdgData "" + let pathToRTViewBackupDir = dataDir rtViewRootDir "backup" + D.createDirectoryIfMissing True pathToRTViewBackupDir + return pathToRTViewBackupDir + +rtViewRootDir :: FilePath +rtViewRootDir = "cardano-rt-view" diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/Charts.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/Charts.hs index 6ab4baaee93..8f470210a74 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/Charts.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/Charts.hs @@ -284,7 +284,7 @@ readSavedChartsSettings = liftIO $ [ (chartId, ChartSettings defaultTimeRangeInS defaultUpdatePeriodInS) | chartId <- chartsIds ] - defaultTimeRangeInS = 0 -- All time + defaultTimeRangeInS = 21600 -- Last 6 hours defaultUpdatePeriodInS = 15 changeChartsToLightTheme :: UI () diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/About.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/About.hs index d51458ebdf5..5b65800dd4e 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/About.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/About.hs @@ -1,17 +1,17 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} module Cardano.Tracer.Handlers.RTView.UI.HTML.About ( mkAboutInfo ) where +import Data.List.Extra (lower) import qualified Data.Text as T import Data.Version (showVersion) import qualified Graphics.UI.Threepenny as UI import Graphics.UI.Threepenny.Core import System.Directory (makeAbsolute) import System.Environment (getArgs) -import System.Info.Extra (isMac, isWindows) +import System.Info (os) import Cardano.Git.Rev (gitRev) @@ -80,9 +80,7 @@ mkAboutInfo = do , image "rt-view-href-icon" externalLinkSVG ] , UI.p #. "mb-3" #+ - [ string $ if | isWindows -> "Windows" - | isMac -> "macOS" - | otherwise -> "Linux" + [ string currentOS ] , UI.p #. "mb-3" #+ [ UI.div #. "field has-addons" #+ @@ -109,3 +107,14 @@ mkAboutInfo = do return info where commit = T.unpack . T.take 7 $ gitRev + +currentOS :: String +currentOS = + case lower os of + "darwin" -> "macOS" + "mingw32" -> "Windows" + "linux" -> "Linux" + "freebsd" -> "FreeBSD" + "netbsd" -> "NetBSD" + "openbsd" -> "OpenBSD" + _ -> "Unknown" diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/Body.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/Body.hs index 16029a8fd8c..f80e3e0c86b 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/Body.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/Body.hs @@ -5,6 +5,8 @@ module Cardano.Tracer.Handlers.RTView.UI.HTML.Body ( mkPageBody ) where +import Control.Concurrent.Extra (Lock) +import Control.Concurrent.STM.TVar (readTVarIO) import Control.Monad (unless, void, when) import Control.Monad.Extra (whenJustM, whenM) import Data.Text (Text) @@ -28,6 +30,7 @@ import Cardano.Tracer.Handlers.RTView.UI.Notifications import Cardano.Tracer.Handlers.RTView.UI.Theme import Cardano.Tracer.Handlers.RTView.UI.Types import Cardano.Tracer.Handlers.RTView.UI.Utils +import Cardano.Tracer.Handlers.RTView.Update.Historical import Cardano.Tracer.Types mkPageBody @@ -37,20 +40,25 @@ mkPageBody -> ResourcesHistory -> BlockchainHistory -> TransactionsHistory + -> DataPointRequestors + -> Lock -> DatasetsIndices -> DatasetsTimestamps -> EventsQueues -> UI Element mkPageBody window networkConfig connected - (ResHistory rHistory) (ChainHistory cHistory) (TXHistory tHistory) + resourcesHistory@(ResHistory rHistory) + chainHistory@(ChainHistory cHistory) + txHistory@(TXHistory tHistory) + dpRequestors currentDPLock dsIxs dsTss eventsQueues = do txsProcessedNumTimer <- mkChartTimer connected tHistory dsIxs dsTss TxsProcessedNumData TxsProcessedNumChart mempoolBytesTimer <- mkChartTimer connected tHistory dsIxs dsTss MempoolBytesData MempoolBytesChart txsInMempoolTimer <- mkChartTimer connected tHistory dsIxs dsTss TxsInMempoolData TxsInMempoolChart - txsProcessedNumChart <- mkChart window txsProcessedNumTimer TxsProcessedNumChart "Processed txs" - mempoolBytesChart <- mkChart window mempoolBytesTimer MempoolBytesChart "Mempool size" - txsInMempoolChart <- mkChart window txsInMempoolTimer TxsInMempoolChart "Txs in mempool" + txsProcessedNumChart <- mkChart txsProcessedNumTimer TxsProcessedNumData TxsProcessedNumChart "Processed txs" + mempoolBytesChart <- mkChart mempoolBytesTimer MempoolBytesData MempoolBytesChart "Mempool size" + txsInMempoolChart <- mkChart txsInMempoolTimer TxsInMempoolData TxsInMempoolChart "Txs in mempool" -- Resources charts. cpuTimer <- mkChartTimer connected rHistory dsIxs dsTss CPUData CPUChart @@ -62,14 +70,14 @@ mkPageBody window networkConfig connected cpuTimeAppTimer <- mkChartTimer connected rHistory dsIxs dsTss CPUTimeAppData CPUTimeAppChart threadsNumTimer <- mkChartTimer connected rHistory dsIxs dsTss ThreadsNumData ThreadsNumChart - cpuChart <- mkChart window cpuTimer CPUChart "CPU usage" - memoryChart <- mkChart window memoryTimer MemoryChart "Memory usage" - gcMajorNumChart <- mkChart window gcMajorNumTimer GCMajorNumChart "Number of major GCs" - gcMinorNumChart <- mkChart window gcMinorNumTimer GCMinorNumChart "Number of minor GCs" - gcLiveMemoryChart <- mkChart window gcLiveMemoryTimer GCLiveMemoryChart "GC, live data in heap" - cpuTimeGCChart <- mkChart window cpuTimeGCTimer CPUTimeGCChart "CPU time used by GC" - cpuTimeAppChart <- mkChart window cpuTimeAppTimer CPUTimeAppChart "CPU time used by app" - threadsNumChart <- mkChart window threadsNumTimer ThreadsNumChart "Number of threads" + cpuChart <- mkChart cpuTimer CPUData CPUChart "CPU usage" + memoryChart <- mkChart memoryTimer MemoryData MemoryChart "Memory usage" + gcMajorNumChart <- mkChart gcMajorNumTimer GCMajorNumData GCMajorNumChart "Number of major GCs" + gcMinorNumChart <- mkChart gcMinorNumTimer GCMinorNumData GCMinorNumChart "Number of minor GCs" + gcLiveMemoryChart <- mkChart gcLiveMemoryTimer GCLiveMemoryData GCLiveMemoryChart "GC, live data in heap" + cpuTimeGCChart <- mkChart cpuTimeGCTimer CPUTimeGCData CPUTimeGCChart "CPU time used by GC" + cpuTimeAppChart <- mkChart cpuTimeAppTimer CPUTimeAppData CPUTimeAppChart "CPU time used by app" + threadsNumChart <- mkChart threadsNumTimer ThreadsNumData ThreadsNumChart "Number of threads" -- Blockchain charts. chainDensityTimer <- mkChartTimer connected cHistory dsIxs dsTss ChainDensityData ChainDensityChart @@ -78,11 +86,11 @@ mkPageBody window networkConfig connected slotInEpochTimer <- mkChartTimer connected cHistory dsIxs dsTss SlotInEpochData SlotInEpochChart epochTimer <- mkChartTimer connected cHistory dsIxs dsTss EpochData EpochChart - chainDensityChart <- mkChart window chainDensityTimer ChainDensityChart "Chain density" - slotNumChart <- mkChart window slotNumTimer SlotNumChart "Slot height" - blockNumChart <- mkChart window blockNumTimer BlockNumChart "Block height" - slotInEpochChart <- mkChart window slotInEpochTimer SlotInEpochChart "Slot in epoch" - epochChart <- mkChart window epochTimer EpochChart "Epoch" + chainDensityChart <- mkChart chainDensityTimer ChainDensityData ChainDensityChart "Chain density" + slotNumChart <- mkChart slotNumTimer SlotNumData SlotNumChart "Slot height" + blockNumChart <- mkChart blockNumTimer BlockNumData BlockNumChart "Block height" + slotInEpochChart <- mkChart slotInEpochTimer SlotInEpochData SlotInEpochChart "Slot in epoch" + epochChart <- mkChart epochTimer EpochData EpochChart "Epoch" -- Leadership charts. cannotForgeTimer <- mkChartTimer' connected cHistory dsIxs dsTss NodeCannotForgeData NodeCannotForgeChart @@ -95,15 +103,15 @@ mkPageBody window networkConfig connected aboutToLeadTimer <- mkChartTimer' connected cHistory dsIxs dsTss AboutToLeadSlotLastData AboutToLeadSlotLastChart couldNotForgeTimer <- mkChartTimer' connected cHistory dsIxs dsTss CouldNotForgeSlotLastData CouldNotForgeSlotLastChart - cannotForgeChart <- mkChart window cannotForgeTimer NodeCannotForgeChart "Cannot forge" - forgedSlotChart <- mkChart window forgedSlotTimer ForgedSlotLastChart "Forged" - nodeIsLeaderChart <- mkChart window nodeIsLeaderTimer NodeIsLeaderChart "Is leader" - nodeIsNotLeaderChart <- mkChart window nodeIsNotLeaderTimer NodeIsNotLeaderChart "Is not leader" - forgedInvalidChart <- mkChart window forgedInvalidTimer ForgedInvalidSlotLastChart "Forged invalid" - adoptedChart <- mkChart window adoptedTimer AdoptedSlotLastChart "Is adopted" - notAdoptedChart <- mkChart window notAdoptedTimer NotAdoptedSlotLastChart "Is not adopted" - aboutToLeadChart <- mkChart window aboutToLeadTimer AboutToLeadSlotLastChart "About to lead" - couldNotForgeChart <- mkChart window couldNotForgeTimer CouldNotForgeSlotLastChart "Could not forge" + cannotForgeChart <- mkChart cannotForgeTimer NodeCannotForgeData NodeCannotForgeChart "Cannot forge" + forgedSlotChart <- mkChart forgedSlotTimer ForgedSlotLastData ForgedSlotLastChart "Forged" + nodeIsLeaderChart <- mkChart nodeIsLeaderTimer NodeIsLeaderData NodeIsLeaderChart "Is leader" + nodeIsNotLeaderChart <- mkChart nodeIsNotLeaderTimer NodeIsNotLeaderData NodeIsNotLeaderChart "Is not leader" + forgedInvalidChart <- mkChart forgedInvalidTimer ForgedInvalidSlotLastData ForgedInvalidSlotLastChart "Forged invalid" + adoptedChart <- mkChart adoptedTimer AdoptedSlotLastData AdoptedSlotLastChart "Is adopted" + notAdoptedChart <- mkChart notAdoptedTimer NotAdoptedSlotLastData NotAdoptedSlotLastChart "Is not adopted" + aboutToLeadChart <- mkChart aboutToLeadTimer AboutToLeadSlotLastData AboutToLeadSlotLastChart "About to lead" + couldNotForgeChart <- mkChart couldNotForgeTimer CouldNotForgeSlotLastData CouldNotForgeSlotLastChart "Could not forge" -- Visibility of charts groups. showHideTxs <- image "has-tooltip-multiline has-tooltip-top rt-view-show-hide-chart-group" showSVG @@ -478,6 +486,78 @@ mkPageBody window networkConfig connected UI.stop couldNotForgeTimer return body + where + mkChart chartUpdateTimer dataName chartId chartName = do + selectTimeRange <- + UI.select ## (show chartId <> show TimeRangeSelect) #+ + -- Values are ranges in seconds. + [ UI.option # set value "0" # set text "All time" + , UI.option # set value "300" # set text "Last 5 minutes" + , UI.option # set value "900" # set text "Last 15 minutes" + , UI.option # set value "1800" # set text "Last 30 minutes" + , UI.option # set value "3600" # set text "Last 1 hour" + , UI.option # set value "10800" # set text "Last 3 hours" + , UI.option # set value "21600" # set text "Last 6 hours" + ] + selectUpdatePeriod <- + UI.select ## (show chartId <> show UpdatePeriodSelect) #+ + -- Values are periods in seconds. + [ UI.option # set value "0" # set text "Off" + , UI.option # set value "15" # set text "15 seconds" + , UI.option # set value "30" # set text "30 seconds" + , UI.option # set value "60" # set text "1 minute" + , UI.option # set value "300" # set text "5 minutes" + , UI.option # set value "900" # set text "15 minutes" + , UI.option # set value "1800" # set text "30 minutes" + , UI.option # set value "3600" # set text "1 hour" + ] + + on UI.selectionChange selectTimeRange . const $ + whenJustM (readMaybe <$> get value selectTimeRange) $ \(rangeInSec :: Int) -> do + Chart.setTimeRange chartId rangeInSec + when (rangeInSec == 0) $ do + Chart.resetZoomChartJS chartId + -- Since the user changed '0' (which means "All time"), + -- we have to load all the history for currently connected nodes, + -- but for this 'chartName' only! + liftIO $ do + connected' <- readTVarIO connected + restoreHistoryFromBackupAll + dataName + connected' + chainHistory + resourcesHistory + txHistory + dpRequestors + currentDPLock + saveChartsSettings window + + on UI.selectionChange selectUpdatePeriod . const $ + whenJustM (readMaybe <$> get value selectUpdatePeriod) $ \(periodInSec :: Int) -> do + whenM (get UI.running chartUpdateTimer) $ UI.stop chartUpdateTimer + unless (periodInSec == 0) $ do + void $ return chartUpdateTimer # set UI.interval (periodInSec * 1000) + UI.start chartUpdateTimer + saveChartsSettings window + + UI.div #. "rt-view-chart-container" #+ + [ UI.div #. "columns" #+ + [ UI.div #. "column mt-1" #+ + [ UI.span #. "rt-view-chart-name" # set text chartName + ] + , UI.div #. "column has-text-right" #+ + [ UI.div #. "field is-grouped mt-3" #+ + [ image "has-tooltip-multiline has-tooltip-top rt-view-chart-icon" timeRangeSVG + # set dataTooltip "Select time range" + , UI.div #. "select is-link is-small mr-4" #+ [element selectTimeRange] + , image "has-tooltip-multiline has-tooltip-top rt-view-chart-icon" refreshSVG + # set dataTooltip "Select update period" + , UI.div #. "select is-link is-small" #+ [element selectUpdatePeriod] + ] + ] + ] + , UI.canvas ## show chartId #. "rt-view-chart-area" #+ [] + ] topNavigation :: UI.Window @@ -563,70 +643,6 @@ footer = ] ] -mkChart - :: UI.Window - -> UI.Timer - -> ChartId - -> String - -> UI Element -mkChart window chartUpdateTimer chartId chartName = do - selectTimeRange <- - UI.select ## (show chartId <> show TimeRangeSelect) #+ - -- Values are ranges in seconds. - [ UI.option # set value "0" # set text "All time" - , UI.option # set value "300" # set text "Last 5 minutes" - , UI.option # set value "900" # set text "Last 15 minutes" - , UI.option # set value "1800" # set text "Last 30 minutes" - , UI.option # set value "3600" # set text "Last 1 hour" - , UI.option # set value "10800" # set text "Last 3 hours" - , UI.option # set value "21600" # set text "Last 6 hours" - ] - selectUpdatePeriod <- - UI.select ## (show chartId <> show UpdatePeriodSelect) #+ - -- Values are periods in seconds. - [ UI.option # set value "0" # set text "Off" - , UI.option # set value "15" # set text "15 seconds" - , UI.option # set value "30" # set text "30 seconds" - , UI.option # set value "60" # set text "1 minute" - , UI.option # set value "300" # set text "5 minutes" - , UI.option # set value "900" # set text "15 minutes" - , UI.option # set value "1800" # set text "30 minutes" - , UI.option # set value "3600" # set text "1 hour" - ] - - on UI.selectionChange selectTimeRange . const $ - whenJustM (readMaybe <$> get value selectTimeRange) $ \(rangeInSec :: Int) -> do - Chart.setTimeRange chartId rangeInSec - when (rangeInSec == 0) $ Chart.resetZoomChartJS chartId - saveChartsSettings window - - on UI.selectionChange selectUpdatePeriod . const $ - whenJustM (readMaybe <$> get value selectUpdatePeriod) $ \(periodInSec :: Int) -> do - whenM (get UI.running chartUpdateTimer) $ UI.stop chartUpdateTimer - unless (periodInSec == 0) $ do - void $ return chartUpdateTimer # set UI.interval (periodInSec * 1000) - UI.start chartUpdateTimer - saveChartsSettings window - - UI.div #. "rt-view-chart-container" #+ - [ UI.div #. "columns" #+ - [ UI.div #. "column mt-1" #+ - [ UI.span #. "rt-view-chart-name" # set text chartName - ] - , UI.div #. "column has-text-right" #+ - [ UI.div #. "field is-grouped mt-3" #+ - [ image "has-tooltip-multiline has-tooltip-top rt-view-chart-icon" timeRangeSVG - # set dataTooltip "Select time range" - , UI.div #. "select is-link is-small mr-4" #+ [element selectTimeRange] - , image "has-tooltip-multiline has-tooltip-top rt-view-chart-icon" refreshSVG - # set dataTooltip "Select update period" - , UI.div #. "select is-link is-small" #+ [element selectUpdatePeriod] - ] - ] - ] - , UI.canvas ## show chartId #. "rt-view-chart-area" #+ [] - ] - changeVisibilityForCharts :: UI.Window -> Element diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/Main.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/Main.hs index bc741a5897c..27241a7b90b 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/Main.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/HTML/Main.hs @@ -89,6 +89,8 @@ mkMainPage connectedNodes displayedElements acceptedMetrics savedTO resourcesHistory chainHistory txHistory + dpRequestors + currentDPLock datasetIndices datasetTimestamps eventsQueues @@ -110,7 +112,7 @@ mkMainPage connectedNodes displayedElements acceptedMetrics savedTO on UI.tick uiNoNodesProgressTimer . const $ do let elId = "no-nodes-progress" valueS <- findAndGetValue window elId - let valueI = readInt (pack valueS) 0 + let valueI = readInt (pack valueS) 0 if valueI < 60 then findAndSet (set UI.value $ show (valueI + 1)) window elId else do @@ -123,10 +125,14 @@ mkMainPage connectedNodes displayedElements acceptedMetrics savedTO whenM (liftIO $ readTVarIO reloadFlag) $ do liftIO $ cleanupDisplayedValues displayedElements + updateUIAfterReload window connectedNodes displayedElements + chainHistory + resourcesHistory + txHistory dpRequestors currentDPLock loggingConfig @@ -135,6 +141,7 @@ mkMainPage connectedNodes displayedElements acceptedMetrics savedTO nodesErrors uiErrorsTimer uiNoNodesProgressTimer + liftIO $ pageWasNotReload reloadFlag -- Uptime is a real-time clock, so update it every second. @@ -155,6 +162,9 @@ mkMainPage connectedNodes displayedElements acceptedMetrics savedTO acceptedMetrics savedTO nodesEraSettings + chainHistory + resourcesHistory + txHistory dpRequestors currentDPLock loggingConfig diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/JS/Charts.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/JS/Charts.hs index c93201c46f0..1c59bb370be 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/JS/Charts.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/UI/JS/Charts.hs @@ -50,7 +50,7 @@ var chart = new Chart(ctx, { animation: false, normalized: true, showLine: true, - spanGaps: false, + spanGaps: true, interaction: { intersect: false, mode: 'index', diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Historical.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Historical.hs index 68b5aae4910..9368a794d64 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Historical.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Historical.hs @@ -1,21 +1,50 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Cardano.Tracer.Handlers.RTView.Update.Historical - ( runHistoricalUpdater + ( backupAllHistory + , restoreHistoryFromBackup + , restoreHistoryFromBackupAll + , runHistoricalBackup + , runHistoricalUpdater ) where -import Control.Concurrent.STM.TVar (readTVarIO) -import Control.Monad (forM_, forever) +import Control.Concurrent.Async (forConcurrently_) +import Control.Concurrent.Extra (Lock) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (modifyTVar', readTVar, readTVarIO) +import Control.Exception.Extra (ignore, try_) +import Control.Monad (forM, forM_, forever, unless) +import Control.Monad.Extra (ifM, whenJust) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Csv as CSV +import Data.List (find, isInfixOf, partition) import qualified Data.Map.Strict as M +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Text as T import Data.Time.Clock.System (getSystemTime, systemToUTCTime) +import qualified Data.Vector as V +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) +import System.Directory.Extra (listFiles) +import System.FilePath ((), takeBaseName) import System.Time.Extra (sleep) +import Text.Read (readMaybe) + +import Cardano.Node.Startup (NodeInfo (..)) import Cardano.Tracer.Handlers.Metrics.Utils 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.System import Cardano.Tracer.Handlers.RTView.Update.Chain import Cardano.Tracer.Handlers.RTView.Update.Leadership import Cardano.Tracer.Handlers.RTView.Update.Resources import Cardano.Tracer.Handlers.RTView.Update.Transactions +import Cardano.Tracer.Handlers.RTView.Update.Utils import Cardano.Tracer.Types -- | A lot of information received from the node is useful as historical data. @@ -41,7 +70,6 @@ runHistoricalUpdater runHistoricalUpdater _savedTO acceptedMetrics resourcesHistory lastResources chainHistory txHistory = forever $ do sleep 1.0 -- TODO: should it be configured? - now <- systemToUTCTime <$> getSystemTime allMetrics <- readTVarIO acceptedMetrics forM_ (M.toList allMetrics) $ \(nodeId, (ekgStore, _)) -> do @@ -51,3 +79,255 @@ runHistoricalUpdater _savedTO acceptedMetrics resourcesHistory updateResourcesHistory nodeId resourcesHistory lastResources metricName metricValue now updateBlockchainHistory nodeId chainHistory metricName metricValue now updateLeadershipHistory nodeId chainHistory metricName metricValue now + +runHistoricalBackup + :: ConnectedNodes + -> BlockchainHistory + -> ResourcesHistory + -> TransactionsHistory + -> DataPointRequestors + -> Lock + -> IO () +runHistoricalBackup connectedNodes + chainHistory resourcesHistory txHistory + dpRequestors currentDPLock = forever $ do + sleep 300.0 -- TODO: 5 minutes, should it be changed? + backupAllHistory connectedNodes + chainHistory resourcesHistory txHistory + dpRequestors currentDPLock + +backupAllHistory + :: ConnectedNodes + -> BlockchainHistory + -> ResourcesHistory + -> TransactionsHistory + -> DataPointRequestors + -> Lock + -> IO () +backupAllHistory connectedNodes + chainHistory resourcesHistory txHistory + dpRequestors currentDPLock = do + connected <- S.toList <$> readTVarIO connectedNodes + backupAllHistory' + connected + chainHistory + resourcesHistory + txHistory + dpRequestors + currentDPLock + +backupAllHistory' + :: [NodeId] + -> BlockchainHistory + -> ResourcesHistory + -> TransactionsHistory + -> DataPointRequestors + -> Lock + -> IO () +backupAllHistory' [] _ _ _ _ _ = return () +backupAllHistory' connected + (ChainHistory chainHistory) + (ResHistory resourcesHistory) + (TXHistory txHistory) + dpRequestors currentDPLock = do + nodesIdsWithNames <- getNodesIdsWithNames connected dpRequestors currentDPLock + backupDir <- getPathToBackupDir + (cHistory, rHistory, tHistory) <- atomically $ (,,) + <$> readTVar chainHistory + <*> readTVar resourcesHistory + <*> readTVar txHistory + -- We can safely work with files for different nodes concurrently. + forConcurrently_ nodesIdsWithNames $ \(nodeId, nodeName) -> do + backupHistory backupDir cHistory nodeId nodeName + backupHistory backupDir rHistory nodeId nodeName + backupHistory backupDir tHistory nodeId nodeName + -- Now we can remove historical points from histories, + -- to prevent big memory consumption. + cleanupHistoryPoints chainHistory + cleanupHistoryPoints resourcesHistory + cleanupHistoryPoints txHistory + where + backupHistory backupDir history nodeId nodeName = + whenJust (M.lookup nodeId history) $ \historyData -> ignore $ do + let nodeSubdir = backupDir T.unpack nodeName + createDirectoryIfMissing True nodeSubdir + forM_ (M.toList historyData) $ \(historyDataName, historyPoints) -> do + let historyDataFile = nodeSubdir show historyDataName + ifM (doesFileExist historyDataFile) + (BSL.appendFile historyDataFile $ pointsToBS historyPoints) + (BSL.writeFile historyDataFile $ pointsToBS historyPoints) + + pointsToBS = CSV.encode . S.toAscList + + -- Remove sets of historical points only, because they are already backed up. + cleanupHistoryPoints history = atomically $ + modifyTVar' history $ M.map (M.map (const S.empty)) + +data HistoryMark = LatestHistory | AllHistory + +restoreHistoryFromBackup + :: Set NodeId + -> BlockchainHistory + -> ResourcesHistory + -> TransactionsHistory + -> DataPointRequestors + -> Lock + -> IO () +restoreHistoryFromBackup = restoreHistoryFromBackup' LatestHistory Nothing + +restoreHistoryFromBackupAll + :: DataName + -> Set NodeId + -> BlockchainHistory + -> ResourcesHistory + -> TransactionsHistory + -> DataPointRequestors + -> Lock + -> IO () +restoreHistoryFromBackupAll dataName = restoreHistoryFromBackup' AllHistory (Just dataName) + +restoreHistoryFromBackup' + :: HistoryMark + -> Maybe DataName + -> Set NodeId + -> BlockchainHistory + -> ResourcesHistory + -> TransactionsHistory + -> DataPointRequestors + -> Lock + -> IO () +restoreHistoryFromBackup' historyMark aDataName connected + (ChainHistory chainHistory) + (ResHistory resourcesHistory) + (TXHistory txHistory) + dpRequestors currentDPLock = ignore $ do + nodesIdsWithNames <- + getNodesIdsWithNames (S.toList connected) dpRequestors currentDPLock + backupDir <- getPathToBackupDir + forM_ nodesIdsWithNames $ \(nodeId, nodeName) -> do + let nodeSubdir = backupDir T.unpack nodeName + doesDirectoryExist nodeSubdir >>= \case + False -> return () -- There is no backup for this node. + True -> do + backupFiles <- listFiles nodeSubdir + -- Check if we need a history for all historical data or for particular one only. + namesWithPoints <- + case aDataName of + Nothing -> + forM backupFiles $ + extractNamesWithHistoricalPoints nodeSubdir + Just oneDataName -> + case find (\bFile -> show oneDataName `isInfixOf` bFile) backupFiles of + Nothing -> return [] + Just backupFile -> do + nameWithPoints <- extractNamesWithHistoricalPoints nodeSubdir backupFile + return [nameWithPoints] + + fillHistory nodeId chainHistory chainData namesWithPoints + fillHistory nodeId resourcesHistory resData namesWithPoints + fillHistory nodeId txHistory txData namesWithPoints + where + extractNamesWithHistoricalPoints nodeSubdir bFile = do + let pureFile = takeBaseName bFile + case readMaybe pureFile of + Nothing -> return noPoints + Just (dataName :: DataName) -> do + -- Ok, this file contains historical points for 'dataName', extract them... + let backupFile = nodeSubdir pureFile + try_ (BSL.readFile backupFile) >>= \case + Left _ -> return noPoints + Right rawPoints -> + case CSV.decode CSV.NoHeader rawPoints of + Left _ -> return noPoints -- Maybe file was broken... + Right (pointsV :: V.Vector HistoricalPoint) -> do + let points = V.toList pointsV + if null points + then return noPoints + else + -- Now we extracted all the points from this backup file. + -- Check if we need all of them or the latest ones only. + case historyMark of + LatestHistory -> do + now <- systemToUTCTime <$> getSystemTime + -- Ok, take the points for the last 6 hours, and only these + -- points will be rendered on JS-charts. + let sixHoursInS = 21600 + !firstTSWeNeed = utc2s now - sixHoursInS + (earlyPoints, pointsWeNeed) = + partition (\(ts, _) -> ts < firstTSWeNeed) points + unless (null pointsWeNeed) $ + -- Now we re-write backup file with all the points + -- except points we need now. These "last" points + -- will be stored in this file again (with the new points) + -- during the first backup. + BSL.writeFile backupFile $ CSV.encode earlyPoints + return (Just dataName, S.fromList pointsWeNeed) + AllHistory -> + -- Ok, take all the history. + return (Just dataName, S.fromList points) + + noPoints = (Nothing, S.empty) + + fillHistory _ _ _ [] = return () + fillHistory nodeId history dataNames dataNamesWithPoints = do + let backupData = mkMapOfData dataNamesWithPoints M.empty + atomically . modifyTVar' history $ \currentHistory -> + case M.lookup nodeId currentHistory of + Nothing -> M.insert nodeId backupData currentHistory + Just currentData -> M.adjust (const $ M.unionWith S.union currentData backupData) + nodeId currentHistory + where + mkMapOfData [] aMap = aMap + mkMapOfData ((mDataName, points):others) aMap = + case mDataName of + Nothing -> mkMapOfData others aMap + Just dataName -> + if dataName `elem` dataNames + then mkMapOfData others $ M.insert dataName points aMap + else mkMapOfData others aMap + + chainData = + [ ChainDensityData + , SlotNumData + , BlockNumData + , SlotInEpochData + , EpochData + , NodeCannotForgeData + , ForgedSlotLastData + , NodeIsLeaderData + , NodeIsNotLeaderData + , ForgedInvalidSlotLastData + , AdoptedSlotLastData + , NotAdoptedSlotLastData + , AboutToLeadSlotLastData + , CouldNotForgeSlotLastData + ] + + resData = + [ CPUData + , MemoryData + , GCMajorNumData + , GCMinorNumData + , GCLiveMemoryData + , CPUTimeGCData + , CPUTimeAppData + , ThreadsNumData + ] + + txData = + [ TxsProcessedNumData + , MempoolBytesData + , TxsInMempoolData + ] + +getNodesIdsWithNames + :: [NodeId] + -> DataPointRequestors + -> Lock + -> IO [(NodeId, T.Text)] +getNodesIdsWithNames [] _ _ = return [] +getNodesIdsWithNames connected dpRequestors currentDPLock = + forM connected $ \nodeId@(NodeId anId) -> + askDataPoint dpRequestors currentDPLock nodeId "NodeInfo" >>= \case + Nothing -> return (nodeId, anId) + Just ni -> return (nodeId, niName ni) diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Nodes.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Nodes.hs index 48b61c80a84..33171a847a7 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Nodes.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Nodes.hs @@ -38,12 +38,14 @@ import Cardano.Tracer.Handlers.Metrics.Utils import Cardano.Tracer.Handlers.RTView.State.Displayed import Cardano.Tracer.Handlers.RTView.State.EraSettings import Cardano.Tracer.Handlers.RTView.State.Errors +import Cardano.Tracer.Handlers.RTView.State.Historical import Cardano.Tracer.Handlers.RTView.State.TraceObjects import Cardano.Tracer.Handlers.RTView.UI.Charts import Cardano.Tracer.Handlers.RTView.UI.HTML.Node.Column import Cardano.Tracer.Handlers.RTView.UI.HTML.NoNodes import Cardano.Tracer.Handlers.RTView.UI.Types import Cardano.Tracer.Handlers.RTView.UI.Utils +import Cardano.Tracer.Handlers.RTView.Update.Historical import Cardano.Tracer.Handlers.RTView.Update.NodeInfo import Cardano.Tracer.Handlers.RTView.Update.Utils import Cardano.Tracer.Types @@ -55,6 +57,9 @@ updateNodesUI -> AcceptedMetrics -> SavedTraceObjects -> ErasSettings + -> BlockchainHistory + -> ResourcesHistory + -> TransactionsHistory -> DataPointRequestors -> Lock -> NonEmpty LoggingParams @@ -65,8 +70,9 @@ updateNodesUI -> UI.Timer -> UI () updateNodesUI window connectedNodes displayedElements acceptedMetrics savedTO nodesEraSettings - dpRequestors currentDPLock loggingConfig colors datasetIndices nodesErrors - updateErrorsTimer noNodesProgressTimer = do + chainHistory resourcesHistory txHistory dpRequestors currentDPLock + loggingConfig colors datasetIndices nodesErrors updateErrorsTimer + noNodesProgressTimer = do (connected, displayedEls) <- liftIO . atomically $ (,) <$> readTVar connectedNodes <*> readTVar displayedElements @@ -86,7 +92,15 @@ updateNodesUI window connectedNodes displayedElements acceptedMetrics savedTO no checkNoNodesState window connected noNodesProgressTimer askNSetNodeInfo window dpRequestors currentDPLock newlyConnected displayedElements addDatasetsForConnected window newlyConnected colors datasetIndices displayedElements - liftIO $ updateDisplayedElements displayedElements connected + liftIO $ do + restoreHistoryFromBackup + newlyConnected + chainHistory + resourcesHistory + txHistory + dpRequestors + currentDPLock + updateDisplayedElements displayedElements connected setBlockReplayProgress connected displayedElements acceptedMetrics setChunkValidationProgress connected savedTO setLedgerDBProgress connected savedTO diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Reload.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Reload.hs index adf95996c2b..42ad7d2bdb0 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Reload.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Reload.hs @@ -14,7 +14,9 @@ import Graphics.UI.Threepenny.Core import Cardano.Tracer.Configuration 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.UI.Types +import Cardano.Tracer.Handlers.RTView.Update.Historical import Cardano.Tracer.Handlers.RTView.Update.NodeInfo import Cardano.Tracer.Handlers.RTView.Update.Nodes import Cardano.Tracer.Types @@ -23,6 +25,9 @@ updateUIAfterReload :: UI.Window -> ConnectedNodes -> DisplayedElements + -> BlockchainHistory + -> ResourcesHistory + -> TransactionsHistory -> DataPointRequestors -> Lock -> NonEmpty LoggingParams @@ -32,7 +37,8 @@ updateUIAfterReload -> UI.Timer -> UI.Timer -> UI () -updateUIAfterReload window connectedNodes displayedElements dpRequestors currentDPLock +updateUIAfterReload window connectedNodes displayedElements + chainHistory resourcesHistory txHistory dpRequestors currentDPLock loggingConfig colors datasetIndices nodesErrors updateErrorsTimer noNodesProgressTimer = do -- Ok, web-page was reload (i.e. it's the first update after DOM-rendering), @@ -48,4 +54,12 @@ updateUIAfterReload window connectedNodes displayedElements dpRequestors current checkNoNodesState window connected noNodesProgressTimer askNSetNodeInfo window dpRequestors currentDPLock connected displayedElements addDatasetsForConnected window connected colors datasetIndices displayedElements - liftIO $ updateDisplayedElements displayedElements connected + liftIO $ do + restoreHistoryFromBackup + connected + chainHistory + resourcesHistory + txHistory + dpRequestors + currentDPLock + updateDisplayedElements displayedElements connected diff --git a/cardano-tracer/src/Cardano/Tracer/Run.hs b/cardano-tracer/src/Cardano/Tracer/Run.hs index b2bc2079f0d..c9f95671cb0 100644 --- a/cardano-tracer/src/Cardano/Tracer/Run.hs +++ b/cardano-tracer/src/Cardano/Tracer/Run.hs @@ -10,16 +10,16 @@ import Control.Concurrent.Async.Extra (sequenceConcurrently) import Control.Concurrent.Extra (newLock) import Control.Monad (void) -import Cardano.Tracer.Acceptors.Run (runAcceptors) -import Cardano.Tracer.CLI (TracerParams (..)) -import Cardano.Tracer.Configuration (TracerConfig, readTracerConfig) -import Cardano.Tracer.Handlers.Logs.Rotator (runLogsRotator) -import Cardano.Tracer.Handlers.Metrics.Servers (runMetricsServers) -import Cardano.Tracer.Handlers.RTView.Run (initEventsQueues, initSavedTraceObjects, - runRTView) -import Cardano.Tracer.Types (DataPointRequestors, ProtocolsBrake) -import Cardano.Tracer.Utils (initAcceptedMetrics, initConnectedNodes, - initDataPointRequestors, initProtocolsBrake) +import Cardano.Tracer.Acceptors.Run +import Cardano.Tracer.CLI +import Cardano.Tracer.Configuration +import Cardano.Tracer.Handlers.Logs.Rotator +import Cardano.Tracer.Handlers.Metrics.Servers +import Cardano.Tracer.Handlers.RTView.Run +import Cardano.Tracer.Handlers.RTView.State.Historical +import Cardano.Tracer.Handlers.RTView.Update.Historical +import Cardano.Tracer.Types +import Cardano.Tracer.Utils -- | Top-level run function, called by 'cardano-tracer' app. runCardanoTracer :: TracerParams -> IO () @@ -38,10 +38,26 @@ doRunCardanoTracer doRunCardanoTracer config protocolsBrake dpRequestors = do connectedNodes <- initConnectedNodes acceptedMetrics <- initAcceptedMetrics - currentLogLock <- newLock - currentDPLock <- newLock savedTO <- initSavedTraceObjects - eventsQueues <- initEventsQueues dpRequestors currentDPLock + + resourcesHistory <- initResourcesHistory + chainHistory <- initBlockchainHistory + txHistory <- initTransactionsHistory + + currentLogLock <- newLock + currentDPLock <- newLock + eventsQueues <- initEventsQueues dpRequestors currentDPLock + + -- Specify what should be done before program stops. + beforeProgramStops $ + backupAllHistory + connectedNodes + chainHistory + resourcesHistory + txHistory + dpRequestors + currentDPLock + void . sequenceConcurrently $ [ runLogsRotator config currentLogLock , runMetricsServers config connectedNodes acceptedMetrics @@ -49,5 +65,6 @@ doRunCardanoTracer config protocolsBrake dpRequestors = do dpRequestors protocolsBrake currentLogLock eventsQueues , runRTView config connectedNodes acceptedMetrics savedTO + chainHistory resourcesHistory txHistory dpRequestors currentDPLock eventsQueues ] diff --git a/cardano-tracer/src/Cardano/Tracer/Utils.hs b/cardano-tracer/src/Cardano/Tracer/Utils.hs index 1a573d87f79..5f55d486808 100644 --- a/cardano-tracer/src/Cardano/Tracer/Utils.hs +++ b/cardano-tracer/src/Cardano/Tracer/Utils.hs @@ -12,6 +12,7 @@ module Cardano.Tracer.Utils ( applyBrake + , beforeProgramStops , connIdToNodeId , initAcceptedMetrics , initConnectedNodes @@ -26,16 +27,23 @@ module Cardano.Tracer.Utils ) where import Control.Applicative (liftA2, liftA3) +import Control.Concurrent import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO) -import Control.Exception (SomeException, SomeAsyncException (..), +import Control.Exception (SomeException, SomeAsyncException (..), finally, fromException, try, tryJust) +import Control.Monad (forM_) +import Control.Monad.Extra (whenJustM) import "contra-tracer" Control.Tracer (showTracing, stdoutTracer, traceWith) import Data.List.Extra (dropPrefix, dropSuffix, replace) import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T import Data.Tuple.Extra (uncurry3) +-- import System.Exit (exitSuccess) +import System.IO (hFlush, stdout) +import System.Mem.Weak (deRefWeak) +import qualified System.Signal as S import System.Time.Extra (sleep) import Ouroboros.Network.Socket (ConnectionId (..)) @@ -140,3 +148,21 @@ nl = "\r\n" showT :: Show a => a -> T.Text showT = T.pack . show + +-- | If 'cardano-tracer' process is going to die (by receiving some system signal), +-- we want to do something before it stops. +beforeProgramStops :: IO () -> IO () +beforeProgramStops action = do + mainThreadIdWk <- mkWeakThreadId =<< myThreadId + forM_ signals $ \sig -> + S.installHandler sig . const $ do + putStrLn " Program is stopping, please wait..." + hFlush stdout + action + `finally` whenJustM (deRefWeak mainThreadIdWk) killThread + where + signals = + [ S.sigABRT + , S.sigINT + , S.sigTERM + ]