diff --git a/cabal.project b/cabal.project index ee877a7b74d..b67e7ef558c 100644 --- a/cabal.project +++ b/cabal.project @@ -11,6 +11,7 @@ packages: cardano-testnet nix/workbench/cardano-topology bench/tx-generator + nix/workbench/locli package cardano-api ghc-options: -Werror diff --git a/nix/haskell.nix b/nix/haskell.nix index ad95a4ff4a5..7dde011d41c 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -84,7 +84,7 @@ let } { # Stamp executables with the git revision and add shell completion - packages = lib.genAttrs ["cardano-node" "cardano-cli" "cardano-topology"] (name: { + packages = lib.genAttrs ["cardano-node" "cardano-cli" "cardano-topology" "locli" ] (name: { components.exes.${name}.postInstall = '' ${lib.optionalString stdenv.hostPlatform.isWindows setLibSodium} ${setGitRev} diff --git a/nix/pkgs.nix b/nix/pkgs.nix index 491f914873b..b510b3d6add 100644 --- a/nix/pkgs.nix +++ b/nix/pkgs.nix @@ -66,6 +66,7 @@ final: prev: with final; inherit (cardanoNodeHaskellPackages.cardano-cli.components.exes) cardano-cli; inherit (cardanoNodeHaskellPackages.cardano-topology.components.exes) cardano-topology; inherit (cardanoNodeHaskellPackages.tx-generator.components.exes) tx-generator; + inherit (cardanoNodeHaskellPackages.locli.components.exes) locli; inherit (cardanoNodeHaskellPackages.bech32.components.exes) bech32; inherit (cardanoNodeHaskellPackages.cardano-submit-api.components.exes) cardano-submit-api; cardano-node-profiled = cardanoNodeProfiledHaskellPackages.cardano-node.components.exes.cardano-node; diff --git a/nix/supervisord-cluster/default.nix b/nix/supervisord-cluster/default.nix index 7e7798602a8..f63a91f7f1a 100644 --- a/nix/supervisord-cluster/default.nix +++ b/nix/supervisord-cluster/default.nix @@ -148,7 +148,7 @@ let wb_run_start_args=( --supervisor-conf "${backend.supervisord.mkSupervisorConf profile}" ) - wb run start $(wb run current-name) "''${wb_run_start_args[@]}" + wb run start $(wb run current-tag) "''${wb_run_start_args[@]}" echo 'workbench: cluster started. Run `stop-cluster` to stop' ''; diff --git a/nix/workbench/analyse.sh b/nix/workbench/analyse.sh new file mode 100644 index 00000000000..bbd51369060 --- /dev/null +++ b/nix/workbench/analyse.sh @@ -0,0 +1,105 @@ +usage_analyse() { + usage "analyse" "Analyse cluster runs" < "$keyfile" + cat >>"$keyfile" < \ + "$adir"/logs-$(basename "$d").flt.json & + done + wait + + msg "log sizes: (files: $(ls "$adir"/*.flt.json | wc -l), lines: $(cat "$adir"/*.flt.json | wc -l))" + + msg "analysing.." + local locli_args=( + --genesis "$dir"/genesis/genesis.json + --run-metafile "$dir"/meta.json + ## -> + # --logobjects-json "$adir"/logs-cluster.logobjects.json + --analysis-json "$adir"/block-event-stream.json + ) + + locli 'analyse' 'block-propagation' \ + "${locli_args[@]}" "$adir"/*.flt.json;; + + machine-timeline | machine | mt ) + local usage="USAGE: wb analyse $op [RUN-NAME=current] [MACH-NAME=node-1]" + local name=${1:-current} + local mach=${2:-node-1} + local dir=$(run get "$name") + local adir=$dir/analysis + + mkdir -p "$adir" + + ## 0. subset what we care about into the keyfile + local keyfile=$adir/substring-keys + locli analyse substring-keys | grep -v 'Temporary modify' > "$keyfile" + + ## 1. enumerate logs, filter by keyfile & consolidate + local logs=("$dir"/$mach/stdout) consolidated="$adir"/logs-$mach.json + grep -hFf "$keyfile" "${logs[@]}" > "$consolidated" + msg "analysing logs of: $mach (lines: $(wc -l "$consolidated"))" + + local locli_args=( + --genesis "$dir"/genesis/genesis.json + --run-metafile "$dir"/meta.json + ## -> + --logobjects-json "$adir"/logs-$mach.logobjects.json + --slotstats-json "$adir"/logs-$mach.slotstats.json + --timeline-pretty "$adir"/logs-$mach.timeline.txt + --stats-csv "$adir"/logs-$mach.stats.csv + --analysis-json "$adir"/logs-$mach.analysis.json + # --timeline-csv "$adir"/logs-$mach.timeline.csv + # --cpu-spans-histogram-png "$adir"/logs-"$mach".cpu85-span-lens.png + # --derived-vectors-0-csv "$adir"/logs-$mach".derived.1.csv + # --derived-vectors-1-csv "$adir"/logs-$mach.derived.1.csv + ) + + locli 'analyse' 'machine-timeline' \ + "${locli_args[@]}" "$consolidated";; + + * ) usage_analyse;; esac +} diff --git a/nix/workbench/backend.sh b/nix/workbench/backend.sh index fc286cba6a5..f2cd6d81ffa 100644 --- a/nix/workbench/backend.sh +++ b/nix/workbench/backend.sh @@ -6,12 +6,17 @@ usage_backend() { Given a run directory, print the node socket path for 'cardano-cli' - start RUNDIR Start an allocated run - record-extended-env-config ENV-JSON [ENV-CONFIG-OPTS..] Extend the environment JSON file with backend-specific environment config + describe-run RUNDIR + pre-run-hook RUNDIR + lostream-fixup-jqargs RUNDIR + lostream-fixup-jqexpr + + start-run RUNDIR Start an allocated run + assert-is BACKEND-NAME Check that the current backend is as expected @@ -25,11 +30,15 @@ local op=${1:-$(usage_backend)} # No need to shift -- backends will use the op. case "${op}" in is-running ) $WORKBENCH_BACKEND "$@";; get-node-socket-path ) $WORKBENCH_BACKEND "$@";; - wait-for-local-node-socket ) $WORKBENCH_BACKEND "$@";; record-extended-env-config ) $WORKBENCH_BACKEND "$@";; describe-run ) $WORKBENCH_BACKEND "$@";; pre-run-hook ) $WORKBENCH_BACKEND "$@";; start-run ) $WORKBENCH_BACKEND "$@";; + lostream-fixup-jqargs ) $WORKBENCH_BACKEND "$@";; + lostream-fixup-jqexpr ) $WORKBENCH_BACKEND "$@";; + + ## Handle non-generic calls: + passthrough | pass ) $WORKBENCH_BACKEND "$@";; assert-is ) local usage="USAGE: wb run $op BACKEND-NAME" diff --git a/nix/workbench/default.nix b/nix/workbench/default.nix index 2d8e1e3a5a2..b22cc11cf70 100644 --- a/nix/workbench/default.nix +++ b/nix/workbench/default.nix @@ -10,6 +10,7 @@ , customConfig , cardano-cli , cardano-topology +, locli , useCabalRun }: @@ -56,6 +57,7 @@ let cardano-cli cardano-topology + locli ]; runWorkbench = @@ -120,7 +122,11 @@ let ${exeCabalOp "run" "cardano-topology"} "$@" } - export -f cardano-cli cardano-node cardano-topology + function locli() { + ${exeCabalOp "run" "locli"} "$@" + } + + export -f cardano-cli cardano-node cardano-topology locli ''} @@ -129,7 +135,7 @@ let '' git log -n1 --alternate-refs --pretty=format:"%Cblue%h %Cred%cr %Cgreen%D %Cblue%s%Creset" echo -n "workbench: prebuilding executables (because of useCabalRun):" - for exe in cardano-cli cardano-node cardano-topology + for exe in cardano-cli cardano-node cardano-topology locli do echo -n " $exe" ${exeCabalOp "run" "$exe"} --help >/dev/null || return 1 done diff --git a/nix/workbench/lib.sh b/nix/workbench/lib.sh index c448bf74ecb..443135e1515 100644 --- a/nix/workbench/lib.sh +++ b/nix/workbench/lib.sh @@ -52,3 +52,16 @@ fatal() { jqtest() { jq --exit-status "$@" > /dev/null } + +git_repo_commit_description() { + local repo=$1 + local commit=$(git -C "$repo" rev-parse 'HEAD' 2>/dev/null || true) + + test -d "$repo/.git" && { + git -C "$repo" fetch + git -C "$repo" describe --match '[0-9].*' --tags $commit 2>/dev/null | + cut -d'-' -f1,2 | tr -d '\n' + git -C "$repo" diff --exit-code --quiet || echo '-modified' + } || true +} + diff --git a/nix/workbench/locli/NOTICE b/nix/workbench/locli/NOTICE new file mode 100644 index 00000000000..fa9cc262f46 --- /dev/null +++ b/nix/workbench/locli/NOTICE @@ -0,0 +1,13 @@ +Copyright 2020 Input Output (Hong Kong) Ltd. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/nix/workbench/locli/app/locli.hs b/nix/workbench/locli/app/locli.hs new file mode 100644 index 00000000000..28c268b80e7 --- /dev/null +++ b/nix/workbench/locli/app/locli.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Cardano.Prelude hiding (option) + +import Control.Monad.Trans.Except.Exit (orDie) +import qualified Options.Applicative as Opt + +import Cardano.Analysis.TopHandler +import Cardano.Unlog.Parsers (opts, pref) +import Cardano.Unlog.Run (renderCommandError, runCommand) + + +main :: IO () +main = toplevelExceptionHandler $ do + + co <- Opt.customExecParser pref opts + + orDie renderCommandError $ runCommand co diff --git a/nix/workbench/locli/locli.cabal b/nix/workbench/locli/locli.cabal new file mode 100644 index 00000000000..2ae5eb16a4e --- /dev/null +++ b/nix/workbench/locli/locli.cabal @@ -0,0 +1,96 @@ +cabal-version: 2.4 + +name: locli +version: 1.27 +description: Cardano log analysis CLI. +author: IOHK +maintainer: operations@iohk.io +license: Apache-2.0 +license-files: + NOTICE +build-type: Simple + +library + + hs-source-dirs: src + + exposed-modules: Data.Accum + Data.Distribution + + Cardano.Analysis.Profile + Cardano.Analysis.TopHandler + + Cardano.Unlog.BlockProp + Cardano.Unlog.Commands + Cardano.Unlog.LogObject + Cardano.Unlog.Parsers + Cardano.Unlog.Resources + Cardano.Unlog.Run + Cardano.Unlog.SlotStats + Cardano.Unlog.Summary + Cardano.Unlog.Timeline + + other-modules: Paths_locli + + build-depends: base + , aeson + , aeson-pretty + , async + , attoparsec + , attoparsec-iso8601 + , bytestring + , cardano-config + , cardano-prelude + , containers + , directory + , filepath + , file-embed + , gnuplot + , Histogram + , iohk-monitoring + , optparse-applicative + , optparse-generic + , ouroboros-network + , process + , scientific + , split + , template-haskell + , text + , text-short + , time + , transformers + , transformers-except + , unordered-containers + , utf8-string + , vector + + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + OverloadedStrings + TupleSections + + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wpartial-fields + -Wcompat + -Wno-all-missed-specialisations + +executable locli + hs-source-dirs: app + main-is: locli.hs + default-language: Haskell2010 + ghc-options: -threaded + -Wall + -rtsopts + "-with-rtsopts=-T" + build-depends: base + , cardano-prelude + , locli + , optparse-applicative + , text + , text-short + , transformers + , transformers-except + default-extensions: NoImplicitPrelude diff --git a/nix/workbench/locli/src/Cardano/Analysis/Profile.hs b/nix/workbench/locli/src/Cardano/Analysis/Profile.hs new file mode 100644 index 00000000000..1402ef94483 --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Analysis/Profile.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-name-shadowing #-} +module Cardano.Analysis.Profile (module Cardano.Analysis.Profile) where + +import Prelude (String) +import Cardano.Prelude + +import qualified Data.Aeson.Types as Aeson +import Data.Aeson (FromJSON(..), Object, withObject, (.:)) +import qualified Data.Attoparsec.Text as Atto +import qualified Data.Attoparsec.Time as Iso8601 +import Data.Text (intercalate, pack) +import Data.Time.Clock (UTCTime, NominalDiffTime) +import qualified Data.Time.Clock as Time +import qualified Data.Time.Clock.POSIX as Time +import Options.Applicative +import qualified Options.Applicative as Opt + +import Ouroboros.Network.Block (SlotNo(..)) + + +data GenesisProfile + = GenesisProfile + { active_slots_coeff :: Float + , delegators :: Word64 + , dense_pool_density :: Word64 + , epoch_length :: Word64 + , parameter_k :: Word64 + , max_block_size :: Word64 + , max_tx_size :: Word64 + , n_pools :: Word64 + , slot_duration :: NominalDiffTime + , utxo :: Word64 + } + deriving (Show, Generic) + +data GeneratorProfile + = GeneratorProfile + { add_tx_size :: Word64 + , inputs_per_tx :: Word64 + , outputs_per_tx :: Word64 + , tps :: Word64 + , tx_count :: Word64 + } + deriving (Show, Generic) + +data Profile + = Profile + { genesis :: GenesisProfile + , generator :: GeneratorProfile + , tag :: Text + , profile_name :: Text + , genesis_cache_id :: Text + , era :: Text + , date :: UTCTime + } + deriving (Show) + +renderChainInfoExport :: ChainInfo -> [Text] +renderChainInfoExport CInfo{..} = + Data.Text.intercalate "," <$> + [[ "Profile", profile_name prof] + ,[ "Era", era prof ] + ,[ "Date", show $ date prof] + ,[ "Pools", show $ n_pools gsis] + ,[ "Density", show $ dense_pool_density gsis] + ,[ "Delegators", show $ delegators gsis] + ,[ "UTxO", show $ utxo gsis] + ] + +newtype Genesis + = Genesis + { systemStart :: UTCTime + } + deriving (Show, Generic) + +data ChainInfo + = ChainInfo + { cProfile :: Profile + , cGenesis :: Genesis + } + deriving (Show) + +pattern CInfo + :: GenesisProfile + -> GeneratorProfile + -> Profile + -> UTCTime + -> ChainInfo +pattern CInfo { gsis, gtor, prof, system_start } <- + ChainInfo prof@(Profile gsis gtor _ _ _ _ _) + (Genesis system_start) + +instance FromJSON GenesisProfile +instance FromJSON GeneratorProfile +instance FromJSON Genesis +instance FromJSON Profile where + parseJSON = withObject "Profile" $ \v -> do + meta :: Object <- v .: "meta" + profile_content :: Object <- meta .: "profile_content" + gener :: Object <- profile_content .: "generator" + Profile + <$> profile_content .: "genesis" + <*> profile_content .: "generator" + <*> meta .: "tag" + <*> meta .: "profile" + <*> meta .: "genesis_cache_id" + <*> gener .: "era" + <*> ((meta .: "timestamp" :: Aeson.Parser Integer) + <&> Time.posixSecondsToUTCTime . realToFrac) + +slotStart :: ChainInfo -> SlotNo -> UTCTime +slotStart CInfo{..} = + flip Time.addUTCTime system_start + . (* slot_duration gsis) + . fromIntegral + . unSlotNo + +-- pChainParams :: Parser ChainParams +-- pChainParams = +-- ChainParams +-- <$> (optUTCTime "system-start" +-- "Cluster system start time.") + +optUTCTime :: String -> String -> Parser UTCTime +optUTCTime optname desc = + Opt.option (readerFromAttoParser Iso8601.utcTime) + $ long optname + <> metavar "ISO8601-TIME" + <> help desc + +optDuration :: String -> String -> NominalDiffTime -> Parser NominalDiffTime +optDuration optname desc def= + Opt.option ((realToFrac :: Double -> NominalDiffTime) <$> Opt.auto) + $ long optname + <> metavar "SEC" + <> help desc + <> value def + +optWord :: String -> String -> Word64 -> Parser Word64 +optWord optname desc def = + Opt.option auto + $ long optname + <> metavar "INT" + <> help desc + <> value def + +-- Stolen from: cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +readerFromAttoParser :: Atto.Parser a -> Opt.ReadM a +readerFromAttoParser p = + Opt.eitherReader (Atto.parseOnly (p <* Atto.endOfInput) . pack) diff --git a/nix/workbench/locli/src/Cardano/Analysis/TopHandler.hs b/nix/workbench/locli/src/Cardano/Analysis/TopHandler.hs new file mode 100644 index 00000000000..0913e07d763 --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Analysis/TopHandler.hs @@ -0,0 +1,106 @@ +module Cardano.Analysis.TopHandler + ( toplevelExceptionHandler + ) where + +-- The code in this module derives from multiple authors over many years. +-- It is all under the BSD3 license below. +-- +-- Copyright (c) 2019 Input Output (Hong Kong) Ltd. +-- 2017 Edward Z. Yang +-- 2015 Edsko de Vries +-- 2009 Duncan Coutts +-- 2007 Galois Inc. +-- 2003 Isaac Jones, Simon Marlow +-- +-- Copyright (c) 2003-2017, Cabal Development Team. +-- See the AUTHORS file for the full list of copyright holders. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above +-- copyright notice, this list of conditions and the following +-- disclaimer in the documentation and/or other materials provided +-- with the distribution. +-- +-- * Neither the name of Isaac Jones nor the names of other +-- contributors may be used to endorse or promote products derived +-- from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +import Prelude + +import Control.Exception + +import System.Environment +import System.Exit +import System.IO + + +-- | An exception handler to use for a program top level, as an alternative to +-- the default top level handler provided by GHC. +-- +-- Use like: +-- +-- > main :: IO () +-- > main = toplevelExceptionHandler $ do +-- > ... +-- +toplevelExceptionHandler :: IO a -> IO a +toplevelExceptionHandler prog = do + -- Use line buffering in case we have to print big error messages, because + -- by default stderr to a terminal device is NoBuffering which is slow. + hSetBuffering stderr LineBuffering + catches prog [ + Handler rethrowAsyncExceptions + , Handler rethrowExitCode + , Handler handleSomeException + ] + where + -- Let async exceptions rise to the top for the default GHC top-handler. + -- This includes things like CTRL-C. + rethrowAsyncExceptions :: SomeAsyncException -> IO a + rethrowAsyncExceptions = throwIO + + -- We don't want to print ExitCode, and it should be handled by the default + -- top handler because that sets the actual OS process exit code. + rethrowExitCode :: ExitCode -> IO a + rethrowExitCode = throwIO + + -- Print all other exceptions + handleSomeException :: SomeException -> IO a + handleSomeException e = do + hFlush stdout + progname <- getProgName + hPutStr stderr (renderSomeException progname e) + throwIO (ExitFailure 1) + + -- Print the human-readable output of 'displayException' if it differs + -- from the default output (of 'show'), so that the user/sysadmin + -- sees something readable in the log. + renderSomeException :: String -> SomeException -> String + renderSomeException progname e + | showOutput /= displayOutput + = showOutput ++ "\n\n" ++ progname ++ ": " ++ displayOutput + + | otherwise + = "\n" ++ progname ++ ": " ++ showOutput + where + showOutput = show e + displayOutput = displayException e diff --git a/nix/workbench/locli/src/Cardano/Unlog/BlockProp.hs b/nix/workbench/locli/src/Cardano/Unlog/BlockProp.hs new file mode 100644 index 00000000000..f86b219943e --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Unlog/BlockProp.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-imports -Wno-partial-fields -Wno-unused-matches -Wno-deprecations -Wno-unused-local-binds -Wno-incomplete-record-updates #-} +module Cardano.Unlog.BlockProp (module Cardano.Unlog.BlockProp) where + +import Prelude (String, error, head, tail, id) +import Cardano.Prelude hiding (head) + +import Control.Arrow ((&&&), (***)) +import Control.Concurrent.Async (mapConcurrently) +import qualified Data.Aeson as AE +import Data.Function (on) +import Data.Either (partitionEithers, isLeft, isRight) +import Data.Maybe (catMaybes, mapMaybe) +import qualified Data.Sequence as Seq +import Data.Tuple (swap) +import Data.Vector (Vector) +import qualified Data.Map.Strict as Map + +import Data.Time.Clock (NominalDiffTime, UTCTime) +import qualified Data.Time.Clock as Time + +import Ouroboros.Network.Block (BlockNo(..), SlotNo(..)) + +import Data.Accum +import Cardano.Analysis.Profile +import Cardano.Unlog.LogObject +import Cardano.Unlog.Resources +import Cardano.Unlog.SlotStats + +import qualified Debug.Trace as D +import qualified Text.Printf as D + + +-- | Block's events, as seen by its forger. +data BlockForgerEvents + = BlockForgerEvents + { bfeHost :: !Host + , bfeBlock :: !Hash + , bfeBlockPrev :: !Hash + , bfeBlockNo :: !BlockNo + , bfeSlotNo :: !SlotNo + , bfeSlotStart :: !UTCTime + , bfeForged :: !(Maybe UTCTime) + , bfeAdopted :: !(Maybe UTCTime) + , bfeChainDelta :: !Int + , bfeAnnounced :: !(Maybe UTCTime) + , bfeSent :: !(Maybe UTCTime) + } + deriving (Generic, AE.FromJSON, AE.ToJSON, Show) + +bfePrevBlock :: BlockForgerEvents -> Maybe Hash +bfePrevBlock x = case bfeBlockNo x of + 0 -> Nothing + _ -> Just $ bfeBlockPrev x + +-- | Block's events, as seen by an observer. +data BlockObserverEvents + = BlockObserverEvents + { boeHost :: !Host + , boeBlock :: !Hash + , boeBlockNo :: !BlockNo + , boeSlotNo :: !SlotNo + , boeSlotStart :: !UTCTime + , boeNoticed :: !(Maybe UTCTime) + , boeFetched :: !(Maybe UTCTime) + , boeAdopted :: !(Maybe UTCTime) + , boeChainDelta :: !Int + , boeAnnounced :: !(Maybe UTCTime) + , boeSent :: !(Maybe UTCTime) + } + deriving (Generic, AE.FromJSON, AE.ToJSON, Show) + +-- | Sum of observer and forger events alike. +type MachBlockEvents = Either BlockObserverEvents BlockForgerEvents + +mbeIsForger :: MachBlockEvents -> Bool +mbeIsForger = isRight + +ordBlockEv :: MachBlockEvents -> MachBlockEvents -> Ordering +ordBlockEv l r + | (on (>) $ either boeBlockNo bfeBlockNo) l r = GT + | (on (>) $ either boeBlockNo bfeBlockNo) r l = LT + | isRight l = GT + | isRight r = LT + | otherwise = EQ + +mbeBlockHash :: MachBlockEvents -> Hash +mbeBlockHash = either boeBlock bfeBlock + +mbeSetAdoptedDelta :: UTCTime -> Int -> MachBlockEvents -> MachBlockEvents +mbeSetAdoptedDelta v d = either (\x -> Left x { boeAdopted=Just v, boeChainDelta=d }) (\x -> Right x { bfeAdopted=Just v, bfeChainDelta=d }) + +mbeSetAnnounced, mbeSetSent :: UTCTime -> MachBlockEvents -> MachBlockEvents +mbeSetAnnounced v = either (\x -> Left x { boeAnnounced=Just v }) (\x -> Right x { bfeAnnounced=Just v }) +mbeSetSent v = either (\x -> Left x { boeSent=Just v }) (\x -> Right x { bfeSent=Just v }) + +-- | Machine's private view of all the blocks. +type MachBlockMap + = Map.Map Hash MachBlockEvents + +blockMapHost :: MachBlockMap -> Host +blockMapHost = either boeHost bfeHost . head . Map.elems + +blockMapMaxBlock :: MachBlockMap -> MachBlockEvents +blockMapMaxBlock = maximumBy ordBlockEv . Map.elems + +blockMapBlock :: Hash -> MachBlockMap -> MachBlockEvents +blockMapBlock h = + fromMaybe (error $ "Invariant failed: missing hash " <> show h) . Map.lookup h + +-- | A completed, compactified version of BlockObserverEvents. +data BlockObservation + = BlockObservation + { boObserver :: !Host + , boNoticed :: !UTCTime + , boFetched :: !UTCTime + , boAdopted :: !(Maybe UTCTime) + , boChainDelta :: !Int -- ^ ChainDelta during adoption + , boAnnounced :: !(Maybe UTCTime) + , boSent :: !(Maybe UTCTime) + } + deriving (Generic, AE.FromJSON, AE.ToJSON) + +-- | All events related to a block. +data BlockEvents + = BlockEvents + { beForger :: !Host + , beBlock :: !Hash + , beBlockPrev :: !Hash + , beBlockNo :: !BlockNo + , beSlotNo :: !SlotNo + , beSlotStart :: !UTCTime + , beForged :: !UTCTime + , beAdopted :: !UTCTime + , beChainDelta :: !Int -- ^ ChainDelta during adoption + , beAnnounced :: !UTCTime + , beSent :: !UTCTime + , beObservations :: [BlockObservation] + } + deriving (Generic, AE.FromJSON, AE.ToJSON) + +-- | Ordered list of all block events of a chain. +type ChainBlockEvents + = [BlockEvents] + +blockProp :: ChainInfo -> [(JsonLogfile, [LogObject])] -> IO ChainBlockEvents +blockProp ci xs = do + putStrLn ("blockProp: recovering block event maps" :: String) + eventMaps <- mapConcurrently (pure . blockEventsFromLogObjects ci) xs + let finalBlockEv = maximumBy ordBlockEv $ blockMapMaxBlock <$> eventMaps + tipHash = rewindChain eventMaps 1 (mbeBlockHash finalBlockEv) + tipBlock = getBlockForge eventMaps tipHash + chain = rebuildChain eventMaps tipHash + putStrLn ("tip block: " <> show tipBlock :: String) + putStrLn ("chain length: " <> show (length chain) :: String) + pure chain + where + rewindChain :: [MachBlockMap] -> Int -> Hash -> Hash + rewindChain eventMaps count tip = go tip count + where go tip = \case + 0 -> tip + n -> go (bfeBlockPrev $ getBlockForge eventMaps tip) (n - 1) + + getBlockForge :: [MachBlockMap] -> Hash -> BlockForgerEvents + getBlockForge xs h = + either (error "Invariant failed: finalBlockEv isn't a forge.") id $ + maximumBy ordBlockEv $ + mapMaybe (Map.lookup h) xs + + rebuildChain :: [MachBlockMap] -> Hash -> ChainBlockEvents + rebuildChain machBlockMaps tip = go (Just tip) [] + where go Nothing acc = acc + go (Just h) acc = + let blkEvs@(forgerEv, _) = collectAllBlockEvents machBlockMaps h + in go (bfePrevBlock forgerEv) + (liftBlockEvents blkEvs : acc) + + collectAllBlockEvents :: [MachBlockMap] -> Hash -> (BlockForgerEvents, [BlockObserverEvents]) + collectAllBlockEvents xs blk = + partitionEithers (mapMaybe (Map.lookup blk) xs) + & swap & first head + + liftBlockEvents :: (BlockForgerEvents, [BlockObserverEvents]) -> BlockEvents + liftBlockEvents (BlockForgerEvents{..}, os) = + BlockEvents + { beForger = bfeHost + , beBlock = bfeBlock + , beBlockPrev = bfeBlockPrev + , beBlockNo = bfeBlockNo + , beSlotNo = bfeSlotNo + , beSlotStart = bfeSlotStart + , beForged = bfeForged & miss "Forged" + , beAdopted = bfeAdopted & miss "Adopted (forger)" + , beChainDelta = bfeChainDelta + , beAnnounced = bfeAnnounced & miss "Announced (forger)" + , beSent = bfeSent & miss "Sent (forger)" + , beObservations = catMaybes $ + os <&> \BlockObserverEvents{..}-> + BlockObservation + <$> Just boeHost + <*> boeNoticed + <*> boeFetched + <*> Just boeAdopted + <*> Just boeChainDelta + <*> Just boeAnnounced + <*> Just boeSent + } + where + miss :: String -> Maybe a -> a + miss slotDesc = fromMaybe $ error $ mconcat + [ "While processing ", show bfeBlockNo, " hash ", show bfeBlock + , " forged by ", show bfeHost + , " -- missing slot: ", slotDesc + ] + +-- | Given a single machine's log object stream, recover its block map. +blockEventsFromLogObjects :: ChainInfo -> (JsonLogfile, [LogObject]) -> MachBlockMap +blockEventsFromLogObjects ci (fp, xs) = + foldl (blockPropMachEventsStep ci fp) mempty xs + +blockPropMachEventsStep :: ChainInfo -> JsonLogfile -> MachBlockMap -> LogObject -> MachBlockMap +blockPropMachEventsStep ci fp bMap = \case + LogObject{loAt, loHost, loBody=LOBlockForged{loBlock,loPrev,loBlockNo,loSlotNo}} -> + flip (Map.insert loBlock) bMap $ + Right (mbmGetForger loHost loBlock bMap "LOBlockForged" + & fromMaybe (mbe0forger loHost loBlock loPrev loBlockNo loSlotNo)) + { bfeForged = Just loAt } + LogObject{loAt, loHost, loBody=LOBlockAddedToCurrentChain{loBlock,loChainLengthDelta}} -> + let mbe0 = Map.lookup loBlock bMap & fromMaybe + (err loHost loBlock "LOBlockAddedToCurrentChain leads") + in Map.insert loBlock (mbeSetAdoptedDelta loAt loChainLengthDelta mbe0) bMap + LogObject{loAt, loHost, loBody=LOChainSyncServerSendHeader{loBlock}} -> + let mbe0 = Map.lookup loBlock bMap & fromMaybe + (err loHost loBlock "LOChainSyncServerSendHeader leads") + in Map.insert loBlock (mbeSetAnnounced loAt mbe0) bMap + LogObject{loAt, loHost, loBody=LOBlockFetchServerSend{loBlock}} -> + -- D.trace (D.printf "mbeSetSent %s %s" (show loHost :: String) (show loBlock :: String)) $ + let mbe0 = Map.lookup loBlock bMap & fromMaybe + (err loHost loBlock "LOBlockFetchServerSend leads") + in Map.insert loBlock (mbeSetSent loAt mbe0) bMap + LogObject{loAt, loHost, loBody=LOChainSyncClientSeenHeader{loBlock,loBlockNo,loSlotNo}} -> + case Map.lookup loBlock bMap of + -- We only record the first ChainSync observation of a block. + Nothing -> Map.insert loBlock + (Left $ + (mbe0observ loHost loBlock loBlockNo loSlotNo) + { boeNoticed = Just loAt }) + bMap + Just{} -> bMap + LogObject{loAt, loHost, loBody=LOBlockFetchClientCompletedFetch{loBlock}} -> + flip (Map.insert loBlock) bMap $ + Left (mbmGetObserver loHost loBlock bMap "LOBlockFetchClientCompletedFetch") + { boeFetched = Just loAt } + _ -> bMap + where + err :: Host -> Hash -> String -> a + err ho ha desc = error $ mconcat + [ "In file ", show fp + , ", for host ", show ho + , ", for block ", show ha + , ": ", desc + ] + mbe0observ :: Host -> Hash -> BlockNo -> SlotNo -> BlockObserverEvents + mbe0observ ho ha bn sn = + BlockObserverEvents ho ha bn sn (slotStart ci sn) + Nothing Nothing Nothing 0 Nothing Nothing + mbe0forger :: Host -> Hash -> Hash -> BlockNo -> SlotNo -> BlockForgerEvents + mbe0forger ho ha hp bn sn = + BlockForgerEvents ho ha hp bn sn (slotStart ci sn) + Nothing Nothing 0 Nothing Nothing + mbmGetObserver :: Host -> Hash -> MachBlockMap -> String -> BlockObserverEvents + mbmGetObserver ho ha m eDesc = case Map.lookup ha m of + Just (Left x) -> x + Just (Right x) -> err ho ha (eDesc <> " after a BlockForgerEvents") + Nothing -> err ho ha (eDesc <> " leads") + mbmGetForger :: Host -> Hash -> MachBlockMap -> String -> Maybe BlockForgerEvents + mbmGetForger ho ha m eDesc = Map.lookup ha m <&> + either (const $ err ho ha (eDesc <> " after a BlockObserverEvents")) id diff --git a/nix/workbench/locli/src/Cardano/Unlog/Commands.hs b/nix/workbench/locli/src/Cardano/Unlog/Commands.hs new file mode 100644 index 00000000000..75dd1eec6ef --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Unlog/Commands.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | CLI command types +module Cardano.Unlog.Commands (module Cardano.Unlog.Commands) where + +import Prelude + +import Data.Text (Text) + +import Options.Applicative +import qualified Options.Applicative as Opt + +import Cardano.Unlog.LogObject hiding (Text) + +-- +-- Analysis CLI command data types +-- + +-- | All the CLI subcommands under \"analysis\". +-- +data AnalysisCommand + = MachineTimeline + JsonGenesisFile + JsonRunMetafile + [JsonLogfile] + MachineTimelineOutputFiles + | BlockPropagation + JsonGenesisFile + JsonRunMetafile + [JsonLogfile] + BlockPropagationOutputFiles + | SubstringKeys + deriving (Show) + +data MachineTimelineOutputFiles + = MachineTimelineOutputFiles + { mtofLogObjects :: Maybe JsonOutputFile + , mtofSlotStats :: Maybe JsonOutputFile + , mtofTimelinePretty :: Maybe TextOutputFile + , mtofTimelineCsv :: Maybe CsvOutputFile + , mtofStatsCsv :: Maybe CsvOutputFile + , mtofHistogram :: Maybe OutputFile + , mtofAnalysis :: Maybe JsonOutputFile + , mtofDerivedVectors0Csv :: Maybe CsvOutputFile + , mtofDerivedVectors1Csv :: Maybe CsvOutputFile + } + deriving (Show) + +data BlockPropagationOutputFiles + = BlockPropagationOutputFiles + { bpofLogObjects :: Maybe JsonOutputFile + , bpofTimelinePretty :: Maybe TextOutputFile + , bpofAnalysis :: Maybe JsonOutputFile + } + deriving (Show) + +renderAnalysisCommand :: AnalysisCommand -> Text +renderAnalysisCommand sc = + case sc of + MachineTimeline {} -> "analyse machine-timeline" + BlockPropagation {} -> "analyse block-propagation" + SubstringKeys {} -> "analyse substring-keys" + +parseMachineTimelineOutputFiles :: Parser MachineTimelineOutputFiles +parseMachineTimelineOutputFiles = + MachineTimelineOutputFiles + <$> optional + (argJsonOutputFile "logobjects-json" + "Dump the entire input LogObject stream") + <*> optional + (argJsonOutputFile "slotstats-json" + "Dump extracted per-slot summaries, as a side-effect of log analysis") + <*> optional + (argTextOutputFile "timeline-pretty" + "Dump pretty timeline of extracted slot leadership summaries, as a side-effect of log analysis") + <*> optional + (argCsvOutputFile "timeline-csv" + "Dump CSV of the timeline") + <*> optional + (argCsvOutputFile "stats-csv" + "Dump CSV of the timeline statistics") + <*> optional + (argOutputFile "cpu-spans-histogram-png" + "Write a PNG file with the CPU spans histogram") + <*> optional + (argJsonOutputFile "analysis-json" + "Write analysis JSON to this file, if specified -- otherwise print to stdout.") + <*> optional + (argCsvOutputFile "derived-vectors-0-csv" + "Dump CSV of vectors derived from the timeline") + <*> optional + (argCsvOutputFile "derived-vectors-1-csv" + "Dump CSV of vectors derived from the timeline") + +parseBlockPropagationOutputFiles :: Parser BlockPropagationOutputFiles +parseBlockPropagationOutputFiles = + BlockPropagationOutputFiles + <$> optional + (argJsonOutputFile "logobjects-json" + "Dump the entire input LogObject stream") + <*> optional + (argTextOutputFile "timeline-pretty" + "Dump pretty timeline of extracted slot leadership summaries, as a side-effect of log analysis") + <*> optional + (argJsonOutputFile "analysis-json" + "Write analysis JSON to this file, if specified -- otherwise print to stdout.") + +parseAnalysisCommands :: Parser AnalysisCommand +parseAnalysisCommands = + Opt.subparser $ + mconcat + [ Opt.command "machine-timeline" + (Opt.info (MachineTimeline + <$> argJsonGenesisFile "genesis" + "Genesis file of the run" + <*> argJsonRunMetafile "run-metafile" + "The meta.json file from the benchmark run" + <*> some argJsonLogfile + <*> parseMachineTimelineOutputFiles) $ + Opt.progDesc "Analyse leadership checks") + , Opt.command "block-propagation" + (Opt.info (BlockPropagation + <$> argJsonGenesisFile "genesis" + "Genesis file of the run" + <*> argJsonRunMetafile "run-metafile" + "The meta.json file from the benchmark run" + <*> some argJsonLogfile + <*> parseBlockPropagationOutputFiles) $ + Opt.progDesc "Analyse leadership checks") + , Opt.command "substring-keys" + (Opt.info (pure SubstringKeys) $ + Opt.progDesc "Dump substrings that narrow logs to relevant subset") + ] + +-- +-- Analysis CLI flag/option data types +-- + +argJsonGenesisFile :: String -> String -> Parser JsonGenesisFile +argJsonGenesisFile optname desc = + fmap JsonGenesisFile $ + Opt.option Opt.str + $ long optname + <> metavar "JSON-GENESIS-FILE" + <> help desc + +argJsonRunMetafile :: String -> String -> Parser JsonRunMetafile +argJsonRunMetafile optname desc = + fmap JsonRunMetafile $ + Opt.option Opt.str + $ long optname + <> metavar "JSON-RUN-METAFILE" + <> help desc + +argJsonLogfile :: Parser JsonLogfile +argJsonLogfile = + JsonLogfile <$> + Opt.argument Opt.str (Opt.metavar "JSON-LOGFILE") + +argJsonOutputFile :: String -> String -> Parser JsonOutputFile +argJsonOutputFile optname desc = + fmap JsonOutputFile $ + Opt.option Opt.str + $ long optname + <> metavar "JSON-OUTFILE" + <> help desc + +argTextOutputFile :: String -> String -> Parser TextOutputFile +argTextOutputFile optname desc = + fmap TextOutputFile $ + Opt.option Opt.str + $ long optname + <> metavar "TEXT-OUTFILE" + <> help desc + +argCsvOutputFile :: String -> String -> Parser CsvOutputFile +argCsvOutputFile optname desc = + fmap CsvOutputFile $ + Opt.option Opt.str + $ long optname + <> metavar "CSV-OUTFILE" + <> help desc + +argOutputFile :: String -> String -> Parser OutputFile +argOutputFile optname desc = + fmap OutputFile $ + Opt.option Opt.str + $ long optname + <> metavar "OUTFILE" + <> help desc diff --git a/nix/workbench/locli/src/Cardano/Unlog/LogObject.hs b/nix/workbench/locli/src/Cardano/Unlog/LogObject.hs new file mode 100644 index 00000000000..96e9241bf44 --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Unlog/LogObject.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-partial-fields -Wno-orphans #-} + +module Cardano.Unlog.LogObject (module Cardano.Unlog.LogObject) where + +import Prelude (error) +import qualified Prelude +import Cardano.Prelude hiding (Text) + +import Control.Monad (fail) +import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), Object, (.:)) +import Data.Aeson.Types (Parser) +import qualified Data.Aeson as AE +import qualified Data.Aeson.Types as AE +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as LText +import qualified Data.Text.Short as Text +import Data.Text.Short (ShortText, fromText, toText) +import Data.Time.Clock (NominalDiffTime, UTCTime) +import qualified Data.Map as Map +import Data.Vector (Vector) + +import Ouroboros.Network.Block (BlockNo(..), SlotNo(..)) + +import Cardano.BM.Stats.Resources + + +type Text = ShortText + +readLogObjectStream :: JsonLogfile -> IO [LogObject] +readLogObjectStream (JsonLogfile f) = + LBS.readFile f + <&> catMaybes . fmap AE.decode . LBS.split (fromIntegral $ fromEnum '\n') + +newtype JsonRunMetafile + = JsonRunMetafile { unJsonRunMetafile :: FilePath } + deriving (Show, Eq) + +newtype JsonGenesisFile + = JsonGenesisFile { unJsonGenesisFile :: FilePath } + deriving (Show, Eq) + +newtype JsonLogfile + = JsonLogfile { unJsonLogfile :: FilePath } + deriving (Show, Eq) + +newtype JsonOutputFile + = JsonOutputFile { unJsonOutputFile :: FilePath } + deriving (Show, Eq) + +newtype TextOutputFile + = TextOutputFile { unTextOutputFile :: FilePath } + deriving (Show, Eq) + +newtype CsvOutputFile + = CsvOutputFile { unCsvOutputFile :: FilePath } + deriving (Show, Eq) + +newtype OutputFile + = OutputFile { unOutputFile :: FilePath } + deriving (Show, Eq) + +data LogObject + = LogObject + { loAt :: !UTCTime + , loKind :: !Text + , loHost :: !Host + , loBody :: !LOBody + } + deriving (Generic, Show) + +instance ToJSON LogObject + +instance ToJSON ShortText where + toJSON = String . toText + +instance FromJSON ShortText where + parseJSON = AE.withText "String" $ pure . fromText + +instance Print ShortText where + hPutStr h = hPutStr h . toText + hPutStrLn h = hPutStrLn h . toText + +newtype TId = TId { unTId :: ShortText } + deriving (Eq, Ord, Show, FromJSON, ToJSON) + +newtype Hash = Hash { unHash :: ShortText } + deriving (Eq, Ord, FromJSON, ToJSON) + +instance Show Hash where show = LText.unpack . toText . unHash + +instance AE.ToJSONKey Hash where + toJSONKey = AE.toJSONKeyText (toText . unHash) + +newtype Host = Host { unHost :: ShortText } + deriving (Eq, Ord, Show, FromJSON, ToJSON) + +instance FromJSON BlockNo where + parseJSON o = BlockNo <$> parseJSON o +instance ToJSON BlockNo where + toJSON (BlockNo x) = toJSON x + +-- +-- LogObject stream interpretation +-- + +interpreters :: Map Text (Object -> TId -> Parser LOBody) +interpreters = Map.fromList + [ (,) "TraceStartLeadershipCheck" $ + \v _ -> LOTraceStartLeadershipCheck + <$> v .: "slot" + <*> v .: "utxoSize" + <*> v .: "chainDensity" + + , (,) "TraceBlockContext" $ + \v _ -> LOBlockContext + <$> v .: "tipBlockNo" + + , (,) "TraceNodeIsLeader" $ + \v _ -> LOTraceNodeIsLeader + <$> v .: "slot" + + , (,) "TraceNodeNotLeader" $ + \v _ -> LOTraceNodeNotLeader + <$> v .: "slot" + + , (,) "TraceMempoolAddedTx" $ + \v _ -> do + x :: Object <- v .: "mempoolSize" + LOMempoolTxs <$> x .: "numTxs" + + , (,) "TraceMempoolRemoveTxs" $ + \v _ -> do + x :: Object <- v .: "mempoolSize" + LOMempoolTxs <$> x .: "numTxs" + + , (,) "TraceMempoolRejectedTx" $ + \_ _ -> pure LOMempoolRejectedTx + + , (,) "TraceLedgerEvent.TookSnapshot" $ + \_ _ -> pure LOLedgerTookSnapshot + + , (,) "TraceBenchTxSubSummary" $ + \v _ -> do + x :: Object <- v .: "summary" + LOGeneratorSummary + <$> ((x .: "ssFailures" :: Parser [Text]) + <&> null) + <*> x .: "ssTxSent" + <*> x .: "ssElapsed" + <*> x .: "ssThreadwiseTps" + + , (,) "TraceBenchTxSubServAck" $ + \v _ -> LOTxsAcked <$> v .: "txIds" + + , (,) "Resources" $ + \v _ -> LOResources <$> parsePartialResourceStates (Object v) + + , (,) "TraceTxSubmissionCollected" $ + \v tid -> LOTxsCollected + <$> pure tid + <*> v .: "count" + + , (,) "TraceTxSubmissionProcessed" $ + \v tid -> LOTxsProcessed + <$> pure tid + <*> v .: "accepted" + <*> v .: "rejected" + + , (,) "TraceForgedBlock" $ + \v _ -> LOBlockForged + <$> v .: "block" + <*> v .: "blockPrev" + <*> v .: "blockNo" + <*> v .: "slot" + , (,) "TraceAddBlockEvent.AddedToCurrentChain" $ + \v _ -> LOBlockAddedToCurrentChain + <$> ((v .: "newtip") <&> hashFromPoint) + <*> v .: "chainLengthDelta" + -- TODO: we should clarify the distinction between the two cases (^ and v). + , (,) "TraceAdoptedBlock" $ + \v _ -> LOBlockAddedToCurrentChain + <$> v .: "blockHash" + <*> pure 1 + , (,) "ChainSyncServerEvent.TraceChainSyncServerRead.AddBlock" $ + \v _ -> LOChainSyncServerSendHeader + <$> v .: "block" + <*> v .: "blockNo" + <*> v .: "slot" + , (,) "ChainSyncServerEvent.TraceChainSyncServerReadBlocked.AddBlock" $ + \v _ -> LOChainSyncServerSendHeader + <$> v .: "block" + <*> v .: "blockNo" + <*> v .: "slot" + , (,) "TraceBlockFetchServerSendBlock" $ + \v _ -> LOBlockFetchServerSend + <$> v .: "block" + , (,) "ChainSyncClientEvent.TraceDownloadedHeader" $ + \v _ -> LOChainSyncClientSeenHeader + <$> v .: "block" + <*> v .: "blockNo" + <*> v .: "slot" + , (,) "CompletedBlockFetch" $ + \v _ -> LOBlockFetchClientCompletedFetch + <$> v .: "block" + ] + where + hashFromPoint :: LText.Text -> Hash + hashFromPoint = Hash . fromText . Prelude.head . LText.splitOn "@" + +logObjectStreamInterpreterKeys :: [Text] +logObjectStreamInterpreterKeys = Map.keys interpreters + +data LOBody + = LOTraceStartLeadershipCheck !SlotNo !Word64 !Float + | LOTraceNodeIsLeader !SlotNo + | LOTraceNodeNotLeader !SlotNo + | LOResources !ResourceStats + | LOMempoolTxs !Word64 + | LOMempoolRejectedTx + | LOLedgerTookSnapshot + | LOBlockContext !Word64 + | LOGeneratorSummary !Bool !Word64 !NominalDiffTime (Vector Float) + | LOTxsAcked !(Vector Text) + | LOTxsCollected !TId !Word64 + | LOTxsProcessed !TId !Word64 !Int + | LOBlockForged + { loBlock :: !Hash + , loPrev :: !Hash + , loBlockNo :: !BlockNo + , loSlotNo :: !SlotNo + } + | LOBlockAddedToCurrentChain + { loBlock :: !Hash + , loChainLengthDelta :: !Int + } + | LOChainSyncServerSendHeader + { loBlock :: !Hash + , loBlockNo :: !BlockNo + , loSlotNo :: !SlotNo + } + | LOBlockFetchServerSend + { loBlock :: !Hash + } + | LOChainSyncClientSeenHeader + { loBlock :: !Hash + , loBlockNo :: !BlockNo + , loSlotNo :: !SlotNo + } + | LOBlockFetchClientCompletedFetch + { loBlock :: !Hash + } + | LOAny !Object + deriving (Generic, Show) + +instance ToJSON LOBody + +instance FromJSON LogObject where + parseJSON = AE.withObject "LogObject" $ \v -> do + body :: Object <- v .: "data" + tid :: TId <- v .: "thread" + -- XXX: fix node causing the need for this workaround + (,) unwrapped kind <- unwrap "credentials" "val" body + LogObject + <$> v .: "at" + <*> pure kind + <*> v .: "host" + <*> case Map.lookup kind interpreters of + Just interp -> interp unwrapped tid + Nothing -> pure $ LOAny unwrapped + where + unwrap :: Text -> Text -> Object -> Parser (Object, Text) + unwrap wrappedKeyPred unwrapKey v = do + kind <- (fromText <$>) <$> v AE..:? "kind" + wrapped :: Maybe Text <- + (fromText <$>) <$> v AE..:? toText wrappedKeyPred + unwrapped :: Maybe Object <- v AE..:? toText unwrapKey + case (kind, wrapped, unwrapped) of + (Nothing, Just _, Just x) -> (,) <$> pure x <*> (fromText <$> x .: "kind") + (Just kind0, _, _) -> pure (v, kind0) + _ -> fail $ "Unexpected LogObject .data: " <> show v + +extendObject :: Text -> Value -> Value -> Value +extendObject k v (Object hm) = Object $ hm <> HM.singleton (toText k) v +extendObject k _ _ = error . Text.unpack $ "Summary key '" <> k <> "' does not serialise to an Object." + +parsePartialResourceStates :: Value -> Parser (Resources Word64) +parsePartialResourceStates = + AE.withObject "NodeSetup" $ + \o -> + Resources + <$> o .: "CentiCpu" + <*> o .: "CentiGC" + <*> o .: "CentiMut" + <*> o .: "GcsMajor" + <*> o .: "GcsMinor" + <*> o .: "Alloc" + <*> o .: "Live" + <*> (o AE..:? "Heap" & fmap (fromMaybe 0)) + <*> o .: "RSS" + <*> o .: "CentiBlkIO" + <*> o .: "Threads" diff --git a/nix/workbench/locli/src/Cardano/Unlog/Parsers.hs b/nix/workbench/locli/src/Cardano/Unlog/Parsers.hs new file mode 100644 index 00000000000..51076e6fb9d --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Unlog/Parsers.hs @@ -0,0 +1,66 @@ +module Cardano.Unlog.Parsers + ( opts + , pref + ) where + +import Cardano.Prelude +import Prelude (String) + +import Options.Applicative +import qualified Options.Applicative as Opt + +import Cardano.Unlog.Commands +import Cardano.Unlog.Run (Command (..)) + +command' :: String -> String -> Parser a -> Mod CommandFields a +command' c descr p = + command c $ info (p <**> helper) + $ mconcat [ progDesc descr ] + +opts :: ParserInfo Command +opts = + Opt.info (parseCommand <**> Opt.helper) + ( Opt.fullDesc + <> Opt.header + "locli - parse JSON log files, as emitted by cardano-node." + ) + +pref :: ParserPrefs +pref = Opt.prefs showHelpOnEmpty + +parseCommand :: Parser Command +parseCommand = + asum + [ parseAnalysis + , parseDisplayVersion + ] + +parseAnalysis :: Parser Command +parseAnalysis = + fmap AnalysisCommand $ + subparser $ mconcat + [ commandGroup "Log analysis" + , metavar "Log analysis" + , command' + "analyse" + "Log analysis" + parseAnalysisCommands + ] + +parseDisplayVersion :: Parser Command +parseDisplayVersion = + subparser + (mconcat + [ commandGroup "Miscellaneous commands" + , metavar "Miscellaneous commands" + , command' + "version" + "Show the locli version" + (pure DisplayVersion) + ] + ) + <|> flag' DisplayVersion + ( long "version" + <> help "Show the locli version" + <> hidden + ) diff --git a/nix/workbench/locli/src/Cardano/Unlog/Resources.hs b/nix/workbench/locli/src/Cardano/Unlog/Resources.hs new file mode 100644 index 00000000000..ae719819b19 --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Unlog/Resources.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Unlog.Resources + ( ResAccums + , mkResAccums + , updateResAccums + , extractResAccums + , ResDistribProjections + , computeResDistrib + , ResContinuity + , discardObsoleteValues + -- * Re-exports + , Resources(..) + ) where + +import Cardano.Prelude + +import Data.Accum +import Data.Distribution +import qualified Data.Sequence as Seq +import Data.Time.Clock (UTCTime) + +import Cardano.BM.Stats.Resources + +-- | Resouce accumulators +type ResAccums = Resources (Accum Word64 Word64) + +mkResAccums :: ResAccums +mkResAccums = + Resources + { rCentiCpu = mkAccumTicksShare + , rCentiGC = mkAccumTicksShare + , rCentiMut = mkAccumTicksShare + , rGcsMajor = mkAccumDelta + , rGcsMinor = mkAccumDelta + , rRSS = mkAccumNew `divAccum` 1048576 + , rHeap = mkAccumNew `divAccum` 1048576 + , rLive = mkAccumNew `divAccum` 1048576 + , rAlloc = mkAccumDelta `divAccum` 1048576 + , rCentiBlkIO = mkAccumTicksShare + , rThreads = mkAccumNew + } + +updateResAccums :: UTCTime -> ResourceStats -> ResAccums -> ResAccums +updateResAccums now rs ra = + updateAccum now <$> rs <*> ra + +-- | Obtain the current values in resource accumulators. +extractResAccums :: ResAccums -> Resources Word64 +extractResAccums = (aCurrent <$>) + +type ResDistribProjections a = Resources (a -> Maybe Word64) + +computeResDistrib :: + forall a + . [PercSpec Float] + -> ResDistribProjections a + -> Seq.Seq a + -> Resources (Distribution Float Word64) +computeResDistrib percentiles projs xs = + compDist <$> projs + where + compDist :: (a -> Maybe Word64) -> Distribution Float Word64 + compDist proj = computeDistribution percentiles + (Seq.fromList . catMaybes . toList $ proj <$> xs) + +type ResContinuity a = Resources (a -> Maybe a) + +discardObsoleteValues :: ResContinuity a +discardObsoleteValues = + Resources + { rCentiCpu = Just + , rCentiGC = Just + , rCentiMut = Just + , rGcsMajor = const Nothing + , rGcsMinor = const Nothing + , rRSS = Just + , rHeap = Just + , rLive = Just + , rAlloc = const Nothing + , rCentiBlkIO = Just + , rThreads = Just + } diff --git a/nix/workbench/locli/src/Cardano/Unlog/Run.hs b/nix/workbench/locli/src/Cardano/Unlog/Run.hs new file mode 100644 index 00000000000..bfa5e378f4b --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Unlog/Run.hs @@ -0,0 +1,51 @@ + +-- | Dispatch for running all the CLI commands +module Cardano.Unlog.Run + ( Command(..) + , CommandErrors + , renderCommandError + , runCommand + ) where + +import Cardano.Prelude + +import Control.Monad.Trans.Except.Extra (firstExceptT) +import qualified Data.Text as Text + +import Cardano.Unlog.Commands (AnalysisCommand) +import Cardano.Unlog.Summary (AnalysisCmdError, renderAnalysisCmdError, + runAnalysisCommand) + +import Cardano.Config.Git.Rev (gitRev) +import Data.Version (showVersion) +import Paths_locli (version) + +-- | Sub-commands of 'locli'. +data Command = + + -- | Analysis commands + AnalysisCommand AnalysisCommand + + | DisplayVersion + deriving Show + +data CommandErrors + = AnalysisError AnalysisCommand AnalysisCmdError + deriving Show + +runCommand :: Command -> ExceptT CommandErrors IO () +runCommand (AnalysisCommand c) = firstExceptT (AnalysisError c) $ runAnalysisCommand c +runCommand DisplayVersion = runDisplayVersion + +renderCommandError :: CommandErrors -> Text +renderCommandError (AnalysisError cmd err) = + renderAnalysisCmdError cmd err + +runDisplayVersion :: ExceptT CommandErrors IO () +runDisplayVersion = do + liftIO . putTextLn $ mconcat + [ "locli ", renderVersion version + , ", git rev ", gitRev + ] + where + renderVersion = Text.pack . showVersion diff --git a/nix/workbench/locli/src/Cardano/Unlog/SlotStats.hs b/nix/workbench/locli/src/Cardano/Unlog/SlotStats.hs new file mode 100644 index 00000000000..2056ecc49c4 --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Unlog/SlotStats.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Unlog.SlotStats (module Cardano.Unlog.SlotStats) where + +import qualified Prelude as P +import Cardano.Prelude + +import Data.Aeson +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import Data.List.Split (splitOn) + +import Data.Time.Clock (UTCTime, NominalDiffTime) +import Text.Printf + +import Ouroboros.Network.Block (SlotNo(..)) + +import Data.Accum +import Cardano.Unlog.Resources + + +-- type Text = ShortText + +data SlotStats + = SlotStats + { slSlot :: !SlotNo + , slEpoch :: !Word64 + , slEpochSlot :: !Word64 + , slStart :: !UTCTime + , slCountChecks :: !Word64 + , slCountLeads :: !Word64 + , slChainDBSnap :: !Word64 + , slRejectedTx :: !Word64 + , slBlockNo :: !Word64 + , slBlockless :: !Word64 + , slOrderViol :: !Word64 + , slEarliest :: !UTCTime + , slSpanCheck :: !NominalDiffTime + , slSpanLead :: !NominalDiffTime + , slMempoolTxs :: !Word64 + , slTxsMemSpan :: !(Maybe NominalDiffTime) + , slTxsCollected :: !Word64 + , slTxsAccepted :: !Word64 + , slTxsRejected :: !Word64 + , slUtxoSize :: !Word64 + , slDensity :: !Float + , slResources :: !(Resources (Maybe Word64)) + } + deriving (Generic, Show) + +instance ToJSON SlotStats + +slotHeadE, slotFormatE :: Text +slotHeadP, slotFormatP :: Text +slotHeadP = + "abs. slot block block lead leader CDB rej check lead mempool tx chain %CPU GCs Produc- Memory use, kB Alloc rate Mempool UTxO Absolute" <>"\n"<> + "slot# epoch no. -less checks ships snap txs span span span col acc rej density all/ GC/mut maj/min tivity RSS Heap Live Alloc /mut sec,kB txs entries slot time" +slotHeadE = + "abs.slot#,slot,epoch,block,blockless,checkSpan,leadSpan,leadShips,cdbSnap,rejTx,checkSpan,mempoolTxSpan,chainDens,%CPU,%GC,%MUT,Productiv,MemLiveKb,MemAllocKb,MemRSSKb,AllocRate/Mut,MempoolTxs,UTxO" +slotFormatP = "%5d %4d:%2d %4d %2d %2d %2d %2d %2d %7s %5s %5s %2d %2d %2d %0.3f %3s %3s %3s %2s %4s %5s %5s %5s %5s %4s %8s %4d %9d %s" +slotFormatE = "%d,%d,%d,%d,%d,%d,%d,%d,%d,%s,%s,%s,%d,%d%0.3f,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%d,%d,%s" + +slotLine :: Bool -> Text -> SlotStats -> Text +slotLine exportMode leadershipF SlotStats{..} = Text.pack $ + printf (Text.unpack leadershipF) + sl epsl epo blk blkl chks lds cdbsn rejtx spanC spanL subdt scol sacc srej dens cpu gc mut majg ming pro rss hea liv alc atm mpo utx start + where sl = unSlotNo slSlot + epsl = slEpochSlot + epo = slEpoch + blk = slBlockNo + blkl = slBlockless + chks = slCountChecks + lds = slCountLeads + cdbsn = slChainDBSnap + rejtx = slRejectedTx + subdt = maybe "" (Text.init . show) slTxsMemSpan + scol = slTxsCollected + sacc = slTxsAccepted + srej = slTxsRejected + spanC = Text.init $ show slSpanCheck + spanL = Text.init $ show slSpanLead + cpu = d 3 $ rCentiCpu slResources + dens = slDensity + gc = d 2 $ min 999 -- workaround for ghc-8.10.x + <$> rCentiGC slResources + mut = d 2 $ min 999 -- workaround for ghc-8.10.x + <$> rCentiMut slResources + majg = d 2 $ rGcsMajor slResources + ming = d 2 $ rGcsMinor slResources + pro = f 2 $ calcProd <$> (min 6 . -- workaround for ghc-8.10.2 + fromIntegral <$> rCentiMut slResources :: Maybe Float) + <*> (fromIntegral <$> rCentiCpu slResources) + rss = d 5 (rRSS slResources) + hea = d 5 (rHeap slResources) + liv = d 5 (rLive slResources) + alc = d 5 (rAlloc slResources) + atm = d 8 $ + (ceiling :: Float -> Int) + <$> ((/) <$> (fromIntegral . (100 *) <$> rAlloc slResources) + <*> (fromIntegral . max 1 . (1024 *) <$> rCentiMut slResources)) + mpo = slMempoolTxs + utx = slUtxoSize + start = " " `splitOn` show slStart P.!! 1 + + calcProd :: Float -> Float -> Float + calcProd mut' cpu' = if cpu' == 0 then 1 else mut' / cpu' + + d, f :: PrintfArg a => Int -> Maybe a -> Text + d width = \case + Just x -> Text.pack $ printf ("%"<>(if exportMode then "0" else "") + <>show width<>"d") x + Nothing -> mconcat (replicate width "-") + f width = \case + Just x -> Text.pack $ printf ("%0."<>show width<>"f") x + Nothing -> mconcat (replicate width "-") + +renderSlotTimeline :: Text -> Text -> Bool -> Seq SlotStats -> Handle -> IO () +renderSlotTimeline leadHead fmt exportMode slotStats hnd = do + forM_ (zip (toList slotStats) [(0 :: Int)..]) $ \(l, i) -> do + when (i `mod` 33 == 0 && (i == 0 || not exportMode)) $ + hPutStrLn hnd leadHead + hPutStrLn hnd $ slotLine exportMode fmt l + +-- | Initial and trailing data are noisy outliers: drop that. +-- +-- The initial part is useless until the node actually starts +-- to interact with the blockchain, so we drop all slots until +-- they start getting non-zero chain density reported. +-- +-- On the trailing part, we drop everything since the last leadership check. +cleanupSlotStats :: Seq SlotStats -> Seq SlotStats +cleanupSlotStats = + -- Seq.dropWhileL ((== 0) . slDensity) . + Seq.dropWhileL ((/= 500) . slSlot) . + Seq.dropWhileR ((== 0) . slCountChecks) + +zeroSlotStats :: SlotStats +zeroSlotStats = + SlotStats + { slSlot = 0 + , slEpoch = 0 + , slEpochSlot = 0 + , slStart = zeroUTCTime + , slCountChecks = 0 + , slCountLeads = 0 + , slOrderViol = 0 + , slEarliest = zeroUTCTime + , slSpanCheck = realToFrac (0 :: Int) + , slSpanLead = realToFrac (0 :: Int) + , slMempoolTxs = 0 + , slTxsMemSpan = Nothing + , slTxsCollected = 0 + , slTxsAccepted = 0 + , slTxsRejected = 0 + , slUtxoSize = 0 + , slDensity = 0 + , slResources = pure Nothing + , slChainDBSnap = 0 + , slRejectedTx = 0 + , slBlockNo = 0 + , slBlockless = 0 + } + diff --git a/nix/workbench/locli/src/Cardano/Unlog/Summary.hs b/nix/workbench/locli/src/Cardano/Unlog/Summary.hs new file mode 100644 index 00000000000..57ddddb87da --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Unlog/Summary.hs @@ -0,0 +1,474 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-name-shadowing #-} +module Cardano.Unlog.Summary + ( AnalysisCmdError + , renderAnalysisCmdError + , runAnalysisCommand + ) where + +import Prelude (String) +import Cardano.Prelude + +import Control.Arrow ((&&&), (***)) +import Control.Monad.Trans.Except.Extra (firstExceptT, newExceptT) +import Control.Concurrent.Async (mapConcurrently) + +import qualified Data.Aeson as Aeson +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import Data.Vector (Vector) +import qualified Data.Vector as Vec + +import qualified System.FilePath as F + +import qualified Graphics.Histogram as Hist +import qualified Graphics.Gnuplot.Frame.OptionSet as Opts + +import Data.Time.Clock (NominalDiffTime) +import Text.Printf + +import Ouroboros.Network.Block (SlotNo(..)) + +import Data.Distribution +import Cardano.Analysis.Profile +import Cardano.Unlog.BlockProp +import Cardano.Unlog.Commands +import Cardano.Unlog.LogObject hiding (Text) +import Cardano.Unlog.Resources +import Cardano.Unlog.SlotStats +import Cardano.Unlog.Timeline + + +data AnalysisCmdError + = AnalysisCmdError !Text + | RunMetaParseError !JsonRunMetafile !Text + | GenesisParseError !JsonGenesisFile !Text + deriving Show + +renderAnalysisCmdError :: AnalysisCommand -> AnalysisCmdError -> Text +renderAnalysisCmdError cmd err = + case err of + AnalysisCmdError err' -> renderError cmd err' + "Analysis command failed" + pure + RunMetaParseError (JsonRunMetafile fp) err' -> renderError cmd err' + ("Benchmark run metafile parse failed: " <> Text.pack fp) + pure + GenesisParseError (JsonGenesisFile fp) err' -> renderError cmd err' + ("Genesis parse failed: " <> Text.pack fp) + pure + where + renderError :: AnalysisCommand -> a -> Text -> (a -> [Text]) -> Text + renderError cmd' cmdErr desc renderer = + mconcat [ desc, ": " + , renderAnalysisCommand cmd' + , " Error: " + , mconcat (renderer cmdErr) + ] + +-- +-- CLI shelley command dispatch +-- + +runAnalysisCommand :: AnalysisCommand -> ExceptT AnalysisCmdError IO () +runAnalysisCommand (MachineTimeline genesisFile metaFile logfiles oFiles) = do + chainInfo <- + ChainInfo + <$> firstExceptT (RunMetaParseError metaFile . Text.pack) + (newExceptT $ + Aeson.eitherDecode @Profile <$> LBS.readFile (unJsonRunMetafile metaFile)) + <*> firstExceptT (GenesisParseError genesisFile . Text.pack) + (newExceptT $ + Aeson.eitherDecode @Genesis <$> LBS.readFile (unJsonGenesisFile genesisFile)) + firstExceptT AnalysisCmdError $ + runMachineTimeline chainInfo logfiles oFiles +runAnalysisCommand (BlockPropagation genesisFile metaFile logfiles oFiles) = do + chainInfo <- + ChainInfo + <$> firstExceptT (RunMetaParseError metaFile . Text.pack) + (newExceptT $ + Aeson.eitherDecode @Profile <$> LBS.readFile (unJsonRunMetafile metaFile)) + <*> firstExceptT (GenesisParseError genesisFile . Text.pack) + (newExceptT $ + Aeson.eitherDecode @Genesis <$> LBS.readFile (unJsonGenesisFile genesisFile)) + firstExceptT AnalysisCmdError $ + runBlockPropagation chainInfo logfiles oFiles +runAnalysisCommand SubstringKeys = + liftIO $ mapM_ putStrLn logObjectStreamInterpreterKeys + +runBlockPropagation :: + ChainInfo -> [JsonLogfile] -> BlockPropagationOutputFiles -> ExceptT Text IO () +runBlockPropagation chainInfo logfiles BlockPropagationOutputFiles{..} = do + liftIO $ do + putStrLn ("runBlockPropagation: lifting LO streams" :: Text) + -- 0. Recover LogObjects + objLists :: [(JsonLogfile, [LogObject])] <- flip mapConcurrently logfiles + (joinT . (pure &&& readLogObjectStream)) + + forM_ bpofLogObjects . const $ do + putStrLn ("runBlockPropagation: dumping LO streams" :: Text) + flip mapConcurrently objLists $ + \(JsonLogfile f, objs) -> + dumpLOStream objs + (JsonOutputFile $ F.dropExtension f <> ".logobjects.json") + + chainBlockEvents <- blockProp chainInfo objLists + + putStrLn ("runBlockPropagation: dumping analyses" :: Text) + forM_ bpofAnalysis $ + \(JsonOutputFile f) -> + withFile f WriteMode $ \hnd -> + forM_ chainBlockEvents $ \x-> + LBS.hPutStrLn hnd (Aeson.encode x) + where + joinT :: (IO a, IO b) -> IO (a, b) + joinT (a, b) = (,) <$> a <*> b + +runMachineTimeline :: + ChainInfo -> [JsonLogfile] -> MachineTimelineOutputFiles -> ExceptT Text IO () +runMachineTimeline chainInfo logfiles MachineTimelineOutputFiles{..} = do + liftIO $ do + -- 0. Recover LogObjects + objs :: [LogObject] <- concat <$> mapM readLogObjectStream logfiles + forM_ mtofLogObjects + (dumpLOStream objs) + + -- 1. Derive the basic scalars and vectors + let (,) runStats noisySlotStats = timelineFromLogObjects chainInfo objs + forM_ mtofSlotStats $ + \(JsonOutputFile f) -> + withFile f WriteMode $ \hnd -> + forM_ noisySlotStats $ LBS.hPutStrLn hnd . Aeson.encode + + -- 2. Reprocess the slot stats + let slotStats = cleanupSlotStats noisySlotStats + + -- 3. Derive the summary + let drvVectors0, _drvVectors1 :: Seq DerivedSlot + (,) drvVectors0 _drvVectors1 = computeDerivedVectors slotStats + summary :: Summary + summary = slotStatsSummary chainInfo slotStats + timelineOutput :: LBS.ByteString + timelineOutput = Aeson.encode summary + + -- 4. Render various outputs + forM_ mtofTimelinePretty + (renderPrettySummary slotStats summary logfiles) + forM_ mtofStatsCsv + (renderExportStats runStats summary) + forM_ mtofTimelineCsv + (renderExportTimeline slotStats) + forM_ mtofDerivedVectors0Csv + (renderDerivedSlots drvVectors0) + forM_ mtofHistogram + (renderHistogram "CPU usage spans over 85%" "Span length" + (toList $ Seq.sort $ sSpanLensCPU85 summary)) + + flip (maybe $ LBS.putStrLn timelineOutput) mtofAnalysis $ + \case + JsonOutputFile f -> + withFile f WriteMode $ \hnd -> + LBS.hPutStrLn hnd timelineOutput + where + renderHistogram :: Integral a + => String -> String -> [a] -> OutputFile -> IO () + renderHistogram desc ylab xs (OutputFile f) = + Hist.plotAdv f opts hist >> pure () + where + hist = Hist.histogram Hist.binFreedmanDiaconis $ fromIntegral <$> xs + opts = Opts.title desc $ Opts.yLabel ylab $ Opts.xLabel "Population" $ + Hist.defOpts hist + + renderPrettySummary :: + Seq SlotStats -> Summary -> [JsonLogfile] -> TextOutputFile -> IO () + renderPrettySummary xs s srcs o = + withFile (unTextOutputFile o) WriteMode $ \hnd -> do + hPutStrLn hnd . Text.pack $ + printf "--- input: %s" (intercalate " " $ unJsonLogfile <$> srcs) + renderSummmaryCDF statsHeadP statsFormatP statsFormatPF s hnd + renderSlotTimeline slotHeadP slotFormatP False xs hnd + renderExportStats :: RunScalars -> Summary -> CsvOutputFile -> IO () + renderExportStats rs s (CsvOutputFile o) = + withFile o WriteMode $ + \h -> do + renderSummmaryCDF statsHeadE statsFormatE statsFormatEF s h + mapM_ (hPutStrLn h) $ + renderChainInfoExport chainInfo + <> + renderRunScalars rs + renderExportTimeline :: Seq SlotStats -> CsvOutputFile -> IO () + renderExportTimeline xs (CsvOutputFile o) = + withFile o WriteMode $ + renderSlotTimeline slotHeadE slotFormatE True xs + + renderSummmaryCDF :: Text -> Text -> Text -> Summary -> Handle -> IO () + renderSummmaryCDF statHead statFmt propFmt summary hnd = do + hPutStrLn hnd statHead + forM_ (toDistribLines statFmt propFmt summary) $ + hPutStrLn hnd + + renderDerivedSlots :: Seq DerivedSlot -> CsvOutputFile -> IO () + renderDerivedSlots slots (CsvOutputFile o) = do + withFile o WriteMode $ \hnd -> do + hPutStrLn hnd derivedSlotsHeader + forM_ slots $ + hPutStrLn hnd . renderDerivedSlot + +dumpLOStream :: [LogObject] -> JsonOutputFile -> IO () +dumpLOStream objs o = + withFile (unJsonOutputFile o) WriteMode $ \hnd -> do + forM_ objs $ LBS.hPutStrLn hnd . Aeson.encode + +data Summary + = Summary + { sMaxChecks :: !Word64 + , sSlotMisses :: !(Seq Word64) + , sSpanLensCPU85 :: !(Seq Int) + , sSpanLensCPU85EBnd :: !(Seq Int) + , sSpanLensCPU85Rwd :: !(Seq Int) + -- distributions + , sMissDistrib :: !(Distribution Float Float) + , sLeadsDistrib :: !(Distribution Float Word64) + , sUtxoDistrib :: !(Distribution Float Word64) + , sDensityDistrib :: !(Distribution Float Float) + , sSpanCheckDistrib :: !(Distribution Float NominalDiffTime) + , sSpanLeadDistrib :: !(Distribution Float NominalDiffTime) + , sBlocklessDistrib :: !(Distribution Float Word64) + , sSpanLensCPU85Distrib + :: !(Distribution Float Int) + , sSpanLensCPU85EBndDistrib :: !(Distribution Float Int) + , sSpanLensCPU85RwdDistrib :: !(Distribution Float Int) + , sResourceDistribs :: !(Resources (Distribution Float Word64)) + } + deriving Show + +renderRunScalars :: RunScalars -> [Text] +renderRunScalars RunScalars{..} = + Text.intercalate "," <$> + [[ "Run time", maybe "---" show rsElapsed ] + ,[ "Txs submitted", maybe "---" show rsSubmitted ] + ,[ "Submission TPS", maybe "---" (show . sum) rsThreadwiseTps] + ] + +instance ToJSON Summary where + toJSON Summary{..} = Aeson.Array $ Vec.fromList + [ Aeson.Object $ HashMap.fromList + [ "kind" .= String "spanLensCPU85EBnd" + , "xs" .= toJSON sSpanLensCPU85EBnd] + , Aeson.Object $ HashMap.fromList + [ "kind" .= String "spanLensCPU85Rwd" + , "xs" .= toJSON sSpanLensCPU85Rwd] + , Aeson.Object $ HashMap.fromList + [ "kind" .= String "spanLensCPU85" + , "xs" .= toJSON sSpanLensCPU85] + , Aeson.Object $ HashMap.fromList + [ "kind" .= String "spanLensCPU85Sorted" + , "xs" .= toJSON (Seq.sort sSpanLensCPU85)] + , extendObject "kind" "spancheck" $ toJSON sSpanCheckDistrib + , extendObject "kind" "spanlead" $ toJSON sSpanLeadDistrib + , extendObject "kind" "cpu" $ toJSON (rCentiCpu sResourceDistribs) + , extendObject "kind" "gc" $ toJSON (rCentiGC sResourceDistribs) + , extendObject "kind" "density" $ toJSON sDensityDistrib + , extendObject "kind" "utxo" $ toJSON sUtxoDistrib + , extendObject "kind" "leads" $ toJSON sLeadsDistrib + , extendObject "kind" "misses" $ toJSON sMissDistrib + , extendObject "kind" "blockless" $ toJSON sBlocklessDistrib + , extendObject "kind" "rss" $ toJSON (rRSS sResourceDistribs) + , extendObject "kind" "heap" $ toJSON (rHeap sResourceDistribs) + , extendObject "kind" "live" $ toJSON (rLive sResourceDistribs) + , extendObject "kind" "spanLensCPU85Distrib" $ + toJSON sSpanLensCPU85Distrib + , extendObject "kind" "spanLensCPU85EBndDistrib" $ + toJSON sSpanLensCPU85EBndDistrib + , extendObject "kind" "spanLensCPU85RwdDistrib" $ + toJSON sSpanLensCPU85RwdDistrib + ] + +slotStatsSummary :: ChainInfo -> Seq SlotStats -> Summary +slotStatsSummary CInfo{} slots = + Summary + { sMaxChecks = maxChecks + , sSlotMisses = misses + , sSpanLensCPU85 = spanLensCPU85 + , sSpanLensCPU85EBnd = sSpanLensCPU85EBnd + , sSpanLensCPU85Rwd = sSpanLensCPU85Rwd + -- + , sMissDistrib = computeDistribution pctiles missRatios + , sLeadsDistrib = + computeDistribution pctiles (slCountLeads <$> slots) + , sUtxoDistrib = + computeDistribution pctiles (slUtxoSize <$> slots) + , sDensityDistrib = + computeDistribution pctiles (slDensity <$> slots) + , sSpanCheckDistrib = + computeDistribution pctiles (slSpanCheck <$> slots) + , sSpanLeadDistrib = + computeDistribution pctiles (slSpanLead <$> slots) + , sBlocklessDistrib = + computeDistribution pctiles (slBlockless <$> slots) + , sSpanLensCPU85Distrib + = computeDistribution pctiles spanLensCPU85 + , sResourceDistribs = + computeResDistrib pctiles resDistProjs slots + , sSpanLensCPU85EBndDistrib = computeDistribution pctiles sSpanLensCPU85EBnd + , sSpanLensCPU85RwdDistrib = computeDistribution pctiles sSpanLensCPU85Rwd + } + where + sSpanLensCPU85EBnd = Seq.fromList $ Vec.length <$> + filter (spanContainsEpochSlot 3) spansCPU85 + sSpanLensCPU85Rwd = Seq.fromList $ Vec.length <$> + filter (spanContainsEpochSlot 803) spansCPU85 + pctiles = sortBy (compare `on` psFrac) + [ Perc 0.01, Perc 0.05 + , Perc 0.1, Perc 0.2, Perc 0.3, Perc 0.4 + , Perc 0.5, Perc 0.6 + , Perc 0.7, Perc 0.75 + , Perc 0.8, Perc 0.85, Perc 0.875 + , Perc 0.9, Perc 0.925, Perc 0.95, Perc 0.97, Perc 0.98, Perc 0.99 + , Perc 0.995, Perc 0.997, Perc 0.998, Perc 0.999 + , Perc 0.9995, Perc 0.9997, Perc 0.9998, Perc 0.9999 + ] + + checkCounts = slCountChecks <$> slots + maxChecks = if length checkCounts == 0 + then 0 else maximum checkCounts + misses = (maxChecks -) <$> checkCounts + missRatios = missRatio <$> misses + spansCPU85 :: [Vector SlotStats] + spansCPU85 = spans + ((/= Just False) . fmap (>=85) . rCentiCpu . slResources) + (toList slots) + spanLensCPU85 = Seq.fromList $ spanLen <$> spansCPU85 + spanContainsEpochSlot :: Word64 -> Vector SlotStats -> Bool + spanContainsEpochSlot s = + uncurry (&&) + . ((s >) . slEpochSlot . Vec.head &&& + (s <) . slEpochSlot . Vec.last) + spanLen :: Vector SlotStats -> Int + spanLen = fromIntegral . unSlotNo . uncurry (-) . (slSlot *** slSlot) . (Vec.last &&& Vec.head) + resDistProjs = + Resources + { rCentiCpu = rCentiCpu . slResources + , rCentiGC = rCentiGC . slResources + , rCentiMut = rCentiMut . slResources + , rGcsMajor = rGcsMajor . slResources + , rGcsMinor = rGcsMinor . slResources + , rRSS = rRSS . slResources + , rHeap = rHeap . slResources + , rLive = rLive . slResources + , rAlloc = rAlloc . slResources + , rCentiBlkIO = rCentiBlkIO . slResources + , rThreads = rThreads . slResources + } + + missRatio :: Word64 -> Float + missRatio = (/ fromIntegral maxChecks) . fromIntegral + +mapSummary :: + Text + -> Summary + -> Text + -> (forall a. Num a => Distribution Float a -> Float) + -> Text +mapSummary statsF Summary{..} desc f = + distribPropertyLine desc + (f sMissDistrib) + (f sSpanCheckDistrib) + (f sSpanLeadDistrib) + (f sBlocklessDistrib) + (f sDensityDistrib) + (f (rCentiCpu sResourceDistribs)) + (f (rCentiGC sResourceDistribs)) + (f (rCentiMut sResourceDistribs)) + (f (rGcsMajor sResourceDistribs)) + (f (rGcsMinor sResourceDistribs)) + (f (rRSS sResourceDistribs)) + (f (rHeap sResourceDistribs)) + (f (rLive sResourceDistribs)) + (f (rAlloc sResourceDistribs)) + (f sSpanLensCPU85Distrib) + (f sSpanLensCPU85EBndDistrib) + (f sSpanLensCPU85RwdDistrib) + where + distribPropertyLine :: + Text + -> Float -> Float -> Float -> Float + -> Float -> Float -> Float + -> Float -> Float + -> Float -> Float -> Float -> Float + -> Float -> Float -> Float + -> Float + -> Text + distribPropertyLine descr miss chkdt leaddt blkl dens cpu gc mut majg ming rss hea liv alc cpu85Sp cpu85SpEBnd cpu85SpRwd = Text.pack $ + printf (Text.unpack statsF) + descr miss chkdt leaddt blkl dens cpu gc mut majg ming rss hea liv alc cpu85Sp cpu85SpEBnd cpu85SpRwd + +toDistribLines :: Text -> Text -> Summary -> [Text] +toDistribLines statsF distPropsF s@Summary{..} = + distribLine + <$> ZipList (pctSpec <$> dPercentiles sMissDistrib) + <*> ZipList (max 1 . ceiling . (* fromIntegral (dCount sMissDistrib)) + . (1.0 -) . pctFrac + <$> dPercentiles sMissDistrib) + <*> ZipList (pctSample <$> dPercentiles sMissDistrib) + <*> ZipList (pctSample <$> dPercentiles sSpanCheckDistrib) + <*> ZipList (pctSample <$> dPercentiles sSpanLeadDistrib) + <*> ZipList (pctSample <$> dPercentiles sBlocklessDistrib) + <*> ZipList (pctSample <$> dPercentiles sDensityDistrib) + <*> ZipList (pctSample <$> dPercentiles (rCentiCpu sResourceDistribs)) + <*> ZipList (min 999 . -- workaround for ghc-8.10.x + pctSample <$> dPercentiles (rCentiGC sResourceDistribs)) + <*> ZipList (min 999 . -- workaround for ghc-8.10.x + pctSample <$> dPercentiles (rCentiMut sResourceDistribs)) + <*> ZipList (pctSample <$> dPercentiles (rGcsMajor sResourceDistribs)) + <*> ZipList (pctSample <$> dPercentiles (rGcsMinor sResourceDistribs)) + -- <*> ZipList (pctSample <$> dPercentiles ( sResourceDistribs)) + <*> ZipList (pctSample <$> dPercentiles (rRSS sResourceDistribs)) + <*> ZipList (pctSample <$> dPercentiles (rHeap sResourceDistribs)) + <*> ZipList (pctSample <$> dPercentiles (rLive sResourceDistribs)) + <*> ZipList (pctSample <$> dPercentiles (rAlloc sResourceDistribs)) + <*> ZipList (pctSample <$> dPercentiles sSpanLensCPU85Distrib) + <*> ZipList (pctSample <$> dPercentiles sSpanLensCPU85EBndDistrib) + <*> ZipList (pctSample <$> dPercentiles sSpanLensCPU85RwdDistrib) + & getZipList + & (<> [ mapSummary distPropsF s "size" (fromIntegral . dCount) + , mapSummary distPropsF s "avg" dAverage + ]) + where + distribLine :: + PercSpec Float -> Int + -> Float -> NominalDiffTime -> NominalDiffTime -> Word64 -> Float + -> Word64 -> Word64 -> Word64 + -> Word64 -> Word64 + -> Word64 -> Word64 -> Word64 -> Word64 + -> Int -> Int -> Int + -> Text + distribLine ps count miss chkdt' leaddt' blkl dens cpu gc mut + majg ming rss hea liv alc cpu85Sp cpu85SpEBnd cpu85SpRwd = Text.pack $ + printf (Text.unpack statsF) + (renderPercSpec 6 ps) count miss chkdt leaddt blkl dens cpu gc mut majg ming rss hea liv alc cpu85Sp cpu85SpEBnd cpu85SpRwd + where chkdt = Text.init $ show chkdt' :: Text + leaddt = Text.init $ show leaddt' :: Text + +statsHeadE, statsFormatE, statsFormatEF :: Text +statsHeadP, statsFormatP, statsFormatPF :: Text +statsHeadP = + "%tile Count MissR CheckΔt LeadΔt BlkLess Density CPU GC MUT Maj Min RSS Heap Live Alloc CPU85%Lens/EBnd/Rwd" +statsHeadE = + "%tile,Count,MissR,CheckΔ,LeadΔ,Blockless,ChainDensity,CPU,GC,MUT,GcMaj,GcMin,RSS,Heap,Live,Alloc,CPU85%Lens,/EpochBoundary,/Rewards" +statsFormatP = + "%6s %5d %0.2f %6s %6s %3d %0.3f %3d %3d %3d %2d %3d %5d %5d %5d %5d %4d %4d %4d" +statsFormatE = + "%s,%d,%0.2f,%s,%s,%d,%0.3f,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d" +statsFormatPF = + "%6s %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f %.2f" +statsFormatEF = + "%s,0,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f,%f" diff --git a/nix/workbench/locli/src/Cardano/Unlog/Timeline.hs b/nix/workbench/locli/src/Cardano/Unlog/Timeline.hs new file mode 100644 index 00000000000..6beaadc8295 --- /dev/null +++ b/nix/workbench/locli/src/Cardano/Unlog/Timeline.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-name-shadowing #-} +module Cardano.Unlog.Timeline (module Cardano.Unlog.Timeline) where + +import Prelude (String, error) +import Cardano.Prelude + +import Control.Arrow ((&&&)) +import qualified Data.Sequence as Seq +import Data.Vector (Vector) +import qualified Data.Map.Strict as Map + +import Data.Time.Clock (NominalDiffTime, UTCTime) +import qualified Data.Time.Clock as Time + +import Ouroboros.Network.Block (SlotNo(..)) + +import Data.Accum +import Cardano.Analysis.Profile +import Cardano.Unlog.LogObject +import Cardano.Unlog.Resources +import Cardano.Unlog.SlotStats + + +-- The "fold" state that accumulates as we process 'LogObject's into a stream +-- of 'SlotStats'. +data TimelineAccum + = TimelineAccum + { aResAccums :: ResAccums + , aResTimestamp :: UTCTime + , aMempoolTxs :: Word64 + , aBlockNo :: Word64 + , aLastBlockSlot :: SlotNo + , aSlotStats :: [SlotStats] + , aRunScalars :: RunScalars + , aTxsCollectedAt:: Map.Map TId UTCTime + } + +data RunScalars + = RunScalars + { rsElapsed :: Maybe NominalDiffTime + , rsSubmitted :: Maybe Word64 + , rsThreadwiseTps :: Maybe (Vector Float) + } + +timelineFromLogObjects :: ChainInfo -> [LogObject] -> (RunScalars, Seq SlotStats) +timelineFromLogObjects ci = + (aRunScalars &&& Seq.reverse . Seq.fromList . aSlotStats) + . foldl (timelineStep ci) zeroTimelineAccum + where + zeroTimelineAccum :: TimelineAccum + zeroTimelineAccum = + TimelineAccum + { aResAccums = mkResAccums + , aResTimestamp = zeroUTCTime + , aMempoolTxs = 0 + , aBlockNo = 0 + , aLastBlockSlot = 0 + , aSlotStats = [zeroSlotStats] + , aRunScalars = zeroRunScalars + , aTxsCollectedAt= mempty + } + zeroRunScalars :: RunScalars + zeroRunScalars = RunScalars Nothing Nothing Nothing + +timelineStep :: ChainInfo -> TimelineAccum -> LogObject -> TimelineAccum +timelineStep ci a@TimelineAccum{aSlotStats=cur:rSLs, ..} = \case + lo@LogObject{loAt, loBody=LOTraceStartLeadershipCheck slot _ _} -> + if slSlot cur > slot + -- Slot log entry for a slot we've supposedly done processing. + then a { aSlotStats = cur + { slOrderViol = slOrderViol cur + 1 + } : case (slSlot cur - slot, rSLs) of + -- Limited back-patching: + (1, p1:rest) -> onLeadershipCheck loAt p1:rest + (2, p1:p2:rest) -> p1:onLeadershipCheck loAt p2:rest + (3, p1:p2:p3:rest) -> p1:p2:onLeadershipCheck loAt p3:rest + _ -> rSLs -- Give up. + } + else if slSlot cur == slot + then a { aSlotStats = onLeadershipCheck loAt cur : rSLs + } + else if slot - slSlot cur > 1 + then let gap = unSlotNo $ slot - slSlot cur - 1 + gapStartSlot = slSlot cur + 1 in + updateOnNewSlot lo $ -- We have a slot check gap to patch: + patchSlotCheckGap gap gapStartSlot a + else updateOnNewSlot lo a + LogObject{loAt, loBody=LOTraceNodeIsLeader _} -> + a { aSlotStats = onLeadershipCertainty loAt True cur : rSLs + } + LogObject{loAt, loBody=LOTraceNodeNotLeader _} -> + a { aSlotStats = onLeadershipCertainty loAt False cur : rSLs + } + LogObject{loAt, loBody=LOResources rs} -> + -- Update resource stats accumulators & record values current slot. + a { aResAccums = accs + , aResTimestamp = loAt + , aSlotStats = cur { slResources = Just <$> extractResAccums accs + } : rSLs + } + where accs = updateResAccums loAt rs aResAccums + LogObject{loBody=LOMempoolTxs txCount} -> + a { aMempoolTxs = txCount + , aSlotStats = cur { slMempoolTxs = txCount + } : rSLs + } + LogObject{loBody=LOBlockContext blockNo} -> + let newBlock = aBlockNo /= blockNo in + a { aBlockNo = blockNo + , aLastBlockSlot = if newBlock + then slSlot cur + else aLastBlockSlot + , aSlotStats = cur { slBlockNo = blockNo + , slBlockless = if newBlock + then 0 + else slBlockless cur + } : rSLs + } + LogObject{loBody=LOLedgerTookSnapshot} -> + a { aSlotStats = cur { slChainDBSnap = slChainDBSnap cur + 1 + } : rSLs + } + LogObject{loBody=LOMempoolRejectedTx} -> + a { aSlotStats = cur { slRejectedTx = slRejectedTx cur + 1 + } : rSLs + } + LogObject{loBody=LOGeneratorSummary _noFails sent elapsed threadwiseTps} -> + a { aRunScalars = + aRunScalars + { rsThreadwiseTps = Just threadwiseTps + , rsElapsed = Just elapsed + , rsSubmitted = Just sent + } + } + LogObject{loBody=LOTxsCollected tid coll, loAt} -> + a { aTxsCollectedAt = + aTxsCollectedAt & + (\case + Just{} -> Just loAt + -- error $ mconcat + -- ["Duplicate LOTxsCollected for tid ", show tid, " at ", show loAt] + Nothing -> Just loAt) + `Map.alter` tid + , aSlotStats = + cur + { slTxsCollected = slTxsCollected cur + max 0 (fromIntegral coll) + } : rSLs + } + LogObject{loBody=LOTxsProcessed tid acc rej, loAt} -> + a { aTxsCollectedAt = tid `Map.delete` aTxsCollectedAt + , aSlotStats = + cur + { slTxsMemSpan = + case tid `Map.lookup` aTxsCollectedAt of + Nothing -> + -- error $ mconcat + -- ["LOTxsProcessed missing LOTxsCollected for tid", show tid, " at ", show loAt] + Just $ + 1.0 + + + fromMaybe 0 (slTxsMemSpan cur) + Just base -> + Just $ + (loAt `Time.diffUTCTime` base) + + + fromMaybe 0 (slTxsMemSpan cur) + , slTxsAccepted = slTxsAccepted cur + acc + , slTxsRejected = slTxsRejected cur + max 0 (fromIntegral rej) + } : rSLs + } + _ -> a + where + updateOnNewSlot :: LogObject -> TimelineAccum -> TimelineAccum + updateOnNewSlot LogObject{loAt, loBody=LOTraceStartLeadershipCheck slot utxo density} a' = + extendTimelineAccum ci slot loAt 1 utxo density a' + updateOnNewSlot _ _ = + error "Internal invariant violated: updateSlot called for a non-LOTraceStartLeadershipCheck LogObject." + + onLeadershipCheck :: UTCTime -> SlotStats -> SlotStats + onLeadershipCheck now sl@SlotStats{..} = + sl { slCountChecks = slCountChecks + 1 + , slSpanCheck = max 0 $ now `Time.diffUTCTime` slStart + } + + onLeadershipCertainty :: UTCTime -> Bool -> SlotStats -> SlotStats + onLeadershipCertainty now lead sl@SlotStats{..} = + sl { slCountLeads = slCountLeads + if lead then 1 else 0 + , slSpanLead = max 0 $ now `Time.diffUTCTime` (slSpanCheck `Time.addUTCTime` slStart) + } + + patchSlotCheckGap :: Word64 -> SlotNo -> TimelineAccum -> TimelineAccum + patchSlotCheckGap 0 _ a' = a' + patchSlotCheckGap n slot a'@TimelineAccum{aSlotStats=cur':_} = + patchSlotCheckGap (n - 1) (slot + 1) $ + extendTimelineAccum ci slot (slotStart ci slot) 0 (slUtxoSize cur') (slDensity cur') a' + patchSlotCheckGap _ _ _ = + error "Internal invariant violated: patchSlotCheckGap called with empty TimelineAccum chain." +timelineStep _ a = const a + +extendTimelineAccum :: + ChainInfo + -> SlotNo -> UTCTime -> Word64 -> Word64 -> Float + -> TimelineAccum -> TimelineAccum +extendTimelineAccum ci@CInfo{..} slot time checks utxo density a@TimelineAccum{..} = + let (epoch, epochSlot) = unSlotNo slot `divMod` epoch_length gsis in + a { aSlotStats = SlotStats + { slSlot = slot + , slEpoch = epoch + , slEpochSlot = epochSlot + , slStart = slotStart ci slot + , slEarliest = time + , slOrderViol = 0 + -- Updated as we see repeats: + , slCountChecks = checks + , slCountLeads = 0 + , slSpanCheck = max 0 $ time `Time.diffUTCTime` slotStart ci slot + , slSpanLead = 0 + , slTxsMemSpan = Nothing + , slTxsCollected= 0 + , slTxsAccepted = 0 + , slTxsRejected = 0 + , slMempoolTxs = aMempoolTxs + , slUtxoSize = utxo + , slDensity = density + , slChainDBSnap = 0 + , slRejectedTx = 0 + , slBlockNo = aBlockNo + , slBlockless = unSlotNo $ slot - aLastBlockSlot + , slResources = maybeDiscard + <$> discardObsoleteValues + <*> extractResAccums aResAccums + } : aSlotStats + } + where maybeDiscard :: (Word64 -> Maybe Word64) -> Word64 -> Maybe Word64 + maybeDiscard f = f + +data DerivedSlot + = DerivedSlot + { dsSlot :: SlotNo + , dsBlockless :: Word64 + } + +derivedSlotsHeader :: String +derivedSlotsHeader = + "Slot,Blockless span" + +renderDerivedSlot :: DerivedSlot -> String +renderDerivedSlot DerivedSlot{..} = + mconcat + [ show (unSlotNo dsSlot), ",", show dsBlockless + ] + +computeDerivedVectors :: Seq SlotStats -> (Seq DerivedSlot, Seq DerivedSlot) +computeDerivedVectors ss = + (\(_,_,d0,d1) -> ( Seq.fromList d0 + , Seq.fromList d1 + )) $ + Seq.foldrWithIndex step (0, 0, [], []) ss + where + step :: + Int + -> SlotStats + -> (Word64, Word64, [DerivedSlot], [DerivedSlot]) + -> (Word64, Word64, [DerivedSlot], [DerivedSlot]) + step _ SlotStats{..} (lastBlockless, spanBLSC, accD0, accD1) = + if lastBlockless < slBlockless + then ( slBlockless + , slBlockless + , DerivedSlot + { dsSlot = slSlot + , dsBlockless = slBlockless + }:accD0 + , DerivedSlot + { dsSlot = slSlot + , dsBlockless = slBlockless + }:accD1 + ) + else ( slBlockless + , spanBLSC + , DerivedSlot + { dsSlot = slSlot + , dsBlockless = spanBLSC + }:accD0 + , accD1 + ) diff --git a/nix/workbench/locli/src/Data/Accum.hs b/nix/workbench/locli/src/Data/Accum.hs new file mode 100644 index 00000000000..ec6f9dc085a --- /dev/null +++ b/nix/workbench/locli/src/Data/Accum.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Accum + ( Accum(..) + , mkAccum + , divAccum + , mulAccum + , updateAccum + , zeroUTCTime + -- Various accumulators + , mkAccumNew + , mkAccumDelta + , mkAccumTicksShare + ) where + +import Cardano.Prelude + +import Data.Time.Clock (UTCTime, NominalDiffTime, diffUTCTime) +import qualified Data.Time.Clock.POSIX as Time + +data Accum a b + = Accum + { aUpdate :: !(NominalDiffTime -> a -> a -> b) + , aPrevStamp :: !UTCTime + , aPrevValue :: !a + , aCurrent :: !b + } + +mkAccum :: a -> b -> (NominalDiffTime -> a -> a -> b) -> Accum a b +mkAccum a b update = Accum update zeroUTCTime a b + +-- | Given an 'Accum', produce one that returns results downscaled by N. +divAccum :: Accum a Word64 -> Word64 -> Accum a Word64 +divAccum a@Accum{..} n = + a { aUpdate = \dt prev val -> aUpdate dt prev val `div` n } + +-- | Given an 'Accum', produce one that returns results upscaled by N. +mulAccum :: Accum a Word64 -> Word64 -> Accum a Word64 +mulAccum a@Accum{..} n = + a { aUpdate = \dt prev val -> aUpdate dt prev val * n } + +updateAccum :: UTCTime -> a -> Accum a b -> Accum a b +updateAccum now val a@Accum{..} = + a + { aPrevStamp = now + , aPrevValue = val + , aCurrent = aUpdate elapsed aPrevValue val + } + where elapsed = now `diffUTCTime` aPrevStamp + +-- updateCounter :: UTCTime -> Word -> CpuTickCounter -> CpuTickCounter +-- updateCounter now newValue CpuTickCounter{..} = +-- Counter +-- { cPrevStamp = now +-- , cPrevValue = newValue +-- , cCurShare = newFraction +-- } +-- where newFraction :: Float +-- newFraction = fromIntegral spentTicks / elapsedTicks +-- spentTicks = newValue - ctcPrevValue +-- elapsedTicks = realToFrac elapsedTime * ticksPerSecond +-- elapsedTime = now `Time.diffUTCTime` ctcPrevStamp +-- ticksPerSecond = 100 :: Float +-- -- ^ 100Hz is a constant on Linux, for practical purposes. + +zeroUTCTime :: UTCTime +zeroUTCTime = Time.posixSecondsToUTCTime $ realToFrac (0 :: Int) + +-- * Basic accumulators +-- + +-- | Just store the latest value. +mkAccumNew :: Accum Word64 Word64 +mkAccumNew = mkAccum 0 0 $ + \_dt _old new -> new + +-- | Simply compute the increase. +mkAccumDelta :: Accum Word64 Word64 +mkAccumDelta = mkAccum 0 0 $ + \_dt old new -> new - old + +-- | Interpret values as centiseconds (ticks, in Linux), +-- and compute ratio of elapsed time, in percents. +mkAccumTicksShare :: Accum Word64 Word64 +mkAccumTicksShare = mkAccum 0 0 $ + \dt old new -> + let spentTicks = new - old + elapsedTicks = realToFrac dt * ticksPerSecond + ticksPerSecond = 100 :: Float + in ceiling $ fromIntegral (spentTicks * 100) / elapsedTicks diff --git a/nix/workbench/locli/src/Data/Distribution.hs b/nix/workbench/locli/src/Data/Distribution.hs new file mode 100644 index 00000000000..5e8f566694c --- /dev/null +++ b/nix/workbench/locli/src/Data/Distribution.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Data.Distribution + ( ToRealFrac(..) + , Distribution(..) + , computeDistribution + , zeroDistribution + , PercSpec(..) + , renderPercSpec + , Percentile(..) + , pctFrac + -- Aux + , spans + ) where + +import Prelude (String, id) +import Cardano.Prelude + +import Control.Arrow +import Data.Aeson (ToJSON(..)) +import qualified Data.Foldable as F +import Data.List (span) +import qualified Data.Sequence as Seq +import Data.Sequence (index) +import Data.Vector (Vector) +import qualified Data.Vector as Vec +import Text.Printf (PrintfArg, printf) + +data Distribution a b = + Distribution + { dAverage :: a + , dCount :: Int + , dPercentiles :: [Percentile a b] + } + deriving (Generic, Show) + +instance (ToJSON a, ToJSON b) => ToJSON (Distribution a b) + +newtype PercSpec a = Perc { psFrac :: a } deriving (Generic, Show) + +renderPercSpec :: PrintfArg a => Int -> PercSpec a -> String +renderPercSpec width = \case + Perc x -> printf ("%0."<>show (width-2)<>"f") x + +data Percentile a b = + Percentile + { pctSpec :: !(PercSpec a) + , pctSampleIndex :: !Int + , pctSamplePrev :: !Int + , pctSample :: !b + } + deriving (Generic, Show) + +pctFrac :: Percentile a b -> a +pctFrac = psFrac . pctSpec + +instance (ToJSON a) => ToJSON (PercSpec a) +instance (ToJSON a, ToJSON b) => ToJSON (Percentile a b) + +zeroDistribution :: Num a => Distribution a b +zeroDistribution = + Distribution + { dAverage = 0 + , dCount = 0 + , dPercentiles = mempty + } + +countSeq :: Eq a => a -> Seq a -> Int +countSeq x = foldl' (\n e -> if e == x then n + 1 else n) 0 + +computeDistribution :: (RealFrac a, Real v, ToRealFrac v a) => [PercSpec a] -> Seq v -> Distribution a v +computeDistribution percentiles (Seq.sort -> sorted) = + Distribution + { dAverage = toRealFrac (F.sum sorted) / fromIntegral (size `max` 1) + , dCount = size + , dPercentiles = + (Percentile (Perc 0) size (countSeq mini sorted) mini:) . + (<> [Percentile (Perc 1.0) 1 (countSeq maxi sorted) maxi]) $ + percentiles <&> + \spec -> + let (sampleIndex :: Int, sample) = + if size == 0 + then (0, 0) + else floor (fromIntegral (size - 1) * psFrac spec) & + (id &&& Seq.index sorted) + in Percentile + spec + (size - sampleIndex) + (countSeq sample sorted) + sample + } + where size = Seq.length sorted + (,) mini maxi = + if size == 0 + then (0, 0) + else (index sorted 0, index sorted $ size - 1) + +class RealFrac b => ToRealFrac a b where + toRealFrac :: a -> b + +instance RealFrac b => ToRealFrac Int b where + toRealFrac = fromIntegral + +instance {-# OVERLAPPABLE #-} (RealFrac b, Real a) => ToRealFrac a b where + toRealFrac = realToFrac + +spans :: forall a. (a -> Bool) -> [a] -> [Vector a] +spans f = go [] + where + go :: [Vector a] -> [a] -> [Vector a] + go acc [] = reverse acc + go acc xs = + case span f $ dropWhile (not . f) xs of + ([], rest) -> go acc rest + (ac, rest) -> + go (Vec.fromList ac:acc) rest diff --git a/nix/workbench/run.sh b/nix/workbench/run.sh index 2e532548bff..a17ae250d8d 100644 --- a/nix/workbench/run.sh +++ b/nix/workbench/run.sh @@ -4,7 +4,6 @@ global_envjson=$global_runsdir/env.json usage_run() { usage "run" "Managing cluster runs" < "$dir"/profile.json profile node-specs "$dir"/profile.json "$global_envjson" > "$dir"/node-specs.json + ## TODO: AWS + local node_commit_desc=$(git_repo_commit_description '.') + local args=( - --arg name $name - --arg batch $batch - --arg prof $prof - --arg epoch $epoch - --arg time $time + --arg tag $tag + --arg batch $batch + --arg profile $prof + --argjson timestamp $timestamp + --arg date $date + --arg node_commit_desc $node_commit_desc + --slurpfile profile_content "$dir"/profile.json ) jq_fmutate "$dir"/meta.json '. * - { name: $name - , batch: $batch - , profile: $prof - , epoch: $epoch - , time: $time + { meta: + { tag: $tag + , batch: $batch + , profile: $profile + , timestamp: $timestamp + , date: $date + , node_commit_desc: $node_commit_desc + , profile_content: $profile_content[0] + } } ' "${args[@]}" @@ -166,22 +174,24 @@ case "$op" in jq '.["'"$node"'"]' "$dir"/node-specs.json > "$node_dir"/node-spec.json done - run describe "$name" + run describe "$tag" profile describe "$dir"/profile.json - run set-current "$name" + run set-current "$tag" + + msg "current run is: $tag / $dir" ;; describe ) - local usage="USAGE: wb run $op RUN-NAME" - local name=${1:?$usage} - local dir=$global_runsdir/$name + local usage="USAGE: wb run $op TAG" + local tag=${1:?$usage} + local dir=$global_runsdir/$tag - if ! run check "$name" - then fatal "run fails sanity checks: $name at $dir"; fi + if ! run check "$tag" + then fatal "run fails sanity checks: $tag at $dir"; fi cat </dev/null | grep ':9001 ' | wc -l)" != "0" - ;; + test "$(sleep 0.5s; netstat -pltn 2>/dev/null | grep ':9001 ' | wc -l)" != "0";; get-node-socket-path ) usage="USAGE: wb supervisor $op STATE-DIR" @@ -78,6 +92,34 @@ EOF then echo "workbench ERROR: state directory exists, but is not a symlink -- please remove it or choose another: $dir"; exit 1; fi ;; + save-pids ) + usage="USAGE: wb supervisor $op RUN-DIR" + dir=${1:?$usage}; shift + + svpid=$dir/supervisor/supervisord.pid pstree=$dir/supervisor/ps.tree + pstree -Ap "$(cat "$svpid")" > "$pstree" + + pidsfile="$dir"/supervisor/cardano-node.pids + grep 'cabal.*cardano-node' "$pstree" | + sed -e 's/^.*-+-cardano-node(\([0-9]*\))-.*$/\1/' \ + > "$pidsfile" + + mapn2p="$dir"/supervisor/node2pid.map; echo '{}' > "$mapn2p" + mapp2n="$dir"/supervisor/pid2node.map; echo '{}' > "$mapp2n" + for node in $(jq_tolist keys "$dir"/node-specs.json) + do cabalpid=$(supervisorctl pid $node) + pid=$(fgrep -e "-cabal($cabalpid)-" "$pstree" | + sed -e 's/^.*-+-cardano-node(\([0-9]*\))-.*$/\1/') + jq_fmutate "$mapn2p" '. * { "'$node'": '$pid' }' + jq_fmutate "$mapp2n" '. * { "'$pid'": "'$node'" }' + done + + msg "supervisor: pid file: $svpid" + msg "supervisor: process tree: $pstree" + msg "supervisor: node pids: $pidsfile" + msg "supervisor: node pid maps: $mapn2p $mapp2n" + ;; + start-run ) usage="USAGE: wb supervisor $op RUN-DIR" dir=${1:?$usage}; shift @@ -104,11 +146,17 @@ EOF sleep 5 done - msg "supervisor: pid file: $dir/supervisor/supervisord.pid" - pstree -Ap "$(cat "$dir"/supervisor/supervisord.pid)" | - grep 'cabal.*cardano-node' | - sed -e 's/^.*-+-{\?cardano-node}\?(\([0-9]*\))$/\1/' \ - > "$dir"/supervisor/cardano-node.pids - ;; + $0 save-pids "$dir";; + + lostream-fixup-jqargs ) + usage="USAGE: wb supervisor $op RUN-DIR" + dir=${1:?$usage} + + echo --compact-output --slurpfile mapp2n "$dir"/supervisor/pid2node.map;; + + lostream-fixup-jqexpr ) + usage="USAGE: wb supervisor $op" + + echo '| $mapp2n[0] as $map | . * { host: $map[.pid] }';; * ) usage_supervisor;; esac diff --git a/nix/workbench/topology.sh b/nix/workbench/topology.sh index 3626eefe429..128d3e18c61 100644 --- a/nix/workbench/topology.sh +++ b/nix/workbench/topology.sh @@ -81,7 +81,7 @@ case "${op}" in args=(--slurpfile profile "$profile_json" --slurpfile topology "$topo_dir"/topology-nixops.json - --null-input + --null-input --compact-output ) jq ' $topology[0] as $topo | $topo.coreNodes diff --git a/nix/workbench/wb b/nix/workbench/wb index f04bbd4693a..d2553e595d3 100755 --- a/nix/workbench/wb +++ b/nix/workbench/wb @@ -12,6 +12,7 @@ global_mode='unknown' . "$global_basedir"/genesis.sh . "$global_basedir"/topology.sh . "$global_basedir"/run.sh +. "$global_basedir"/analyse.sh . "$global_basedir"/explain-mode.sh . "$global_basedir"/backend.sh @@ -26,6 +27,7 @@ usage_main() { profile (p) Cluster profile ops. Default op is 'list' cluster (c) Cluster state ops run (r) Managing cluster runs. Default op is 'list' + analyse (a) Analyse cluster runs explain-mode (x) Explain current mode @@ -85,6 +87,9 @@ main() { run | runs | r ) run "$@";; + analyse | a ) + analyse "$@";; + explain-mode | x ) explain-mode $global_mode;;