diff --git a/app/BenchmarkDisplay.hs b/app/BenchmarkDisplay.hs new file mode 100644 index 0000000..3cf3e2b --- /dev/null +++ b/app/BenchmarkDisplay.hs @@ -0,0 +1,155 @@ +import Data.Aeson (eitherDecodeFileStrict') +import Data.Char (isHexDigit) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy.IO qualified as LTIO +import Database.Persist +import Database.Persist.Sqlite (runMigration, runSqlite) +import Lucid (renderText) +import Options.Applicative +import Perf.DB.Materialize +import Perf.Types.DB qualified as DB +import Perf.Types.External qualified as EX +import Perf.Web.Layout +import Perf.Web.Plot +import System.Directory (makeAbsolute) +import System.Exit (ExitCode (ExitSuccess), die) +import System.FilePath (takeBaseName) +import System.Info (os) +import System.Process (rawSystem) + +data Cli = Cli + { outputPath :: FilePath, + sqlitePath :: Maybe FilePath, + branchName :: Text, + maxCommits :: Int, + jsonFiles :: [FilePath] + } + +data Source + = JsonFiles (NonEmpty FilePath) + | Sqlite FilePath Text Int + +main :: IO () +main = do + cli <- execParser parserInfo + source <- validateSource cli + html <- case source of + JsonFiles files -> do + snapshots <- mapM loadSnapshot $ NonEmpty.toList files + pure $ + staticLayout_ "Benchmarks" $ + generateExternalPlots $ + materializeExternalSnapshots $ + NonEmpty.fromList snapshots + Sqlite sqlite branch limit -> do + benchmarks <- loadBenchmarksFromSqlite sqlite branch limit + pure $ + staticLayout_ ("Benchmarks: " <> branch) $ + generateCommitPlots benchmarks + absoluteOutput <- makeAbsolute cli.outputPath + LTIO.writeFile absoluteOutput (renderText html) + openFile absoluteOutput + +validateSource :: Cli -> IO Source +validateSource cli = + case (cli.sqlitePath, NonEmpty.nonEmpty cli.jsonFiles) of + (Just sqlite, Nothing) -> pure $ Sqlite sqlite cli.branchName cli.maxCommits + (Nothing, Just files) -> pure $ JsonFiles files + (Just _, Just _) -> die "Use either JSON files or --sqlite, not both." + (Nothing, Nothing) -> die "Provide one or more JSON files, or use --sqlite." + +loadSnapshot :: FilePath -> IO (Text, [EX.Benchmark]) +loadSnapshot path = do + decoded <- eitherDecodeFileStrict' path + case decoded of + Left err -> die $ "Failed to decode " <> path <> ": " <> err + Right benchmarks -> pure (labelFromPath path, benchmarks) + +labelFromPath :: FilePath -> Text +labelFromPath path = + let base = takeBaseName path + suffix = reverse $ takeWhile (/= '-') $ reverse base + hasDash = '-' `elem` base + in if hasDash && not (null suffix) && all isHexDigit suffix + then T.pack suffix + else T.pack base + +loadBenchmarksFromSqlite :: FilePath -> Text -> Int -> IO (BenchmarkSeries DB.Commit DB.Metric) +loadBenchmarksFromSqlite sqlite branch limit = + runSqlite (T.pack sqlite) do + runMigration DB.migrateAll + mbranch <- selectFirst [DB.BranchName ==. branch] [] + case mbranch of + Nothing -> pure mempty + Just (Entity branchId _) -> do + mappings <- + selectList + [DB.MapBranchCommitBranchId ==. branchId] + [Desc DB.MapBranchCommitId, LimitTo limit] + commits <- mapM (\mapping -> selectFirst [DB.CommitId ==. mapping.entityVal.mapBranchCommitCommitId] []) mappings + case NonEmpty.nonEmpty $ reverse $ catMaybes commits of + Nothing -> pure mempty + Just existingCommits -> materializeCommits existingCommits + +openFile :: FilePath -> IO () +openFile path = + case os of + "darwin" -> runOpen "open" + "linux" -> runOpen "xdg-open" + _ -> putStrLn $ "Wrote " <> path + where + runOpen command = do + status <- rawSystem command [path] + case status of + ExitSuccess -> pure () + _ -> putStrLn $ "Wrote " <> path + +parserInfo :: ParserInfo Cli +parserInfo = + info (cliParser <**> helper) $ + fullDesc + <> progDesc "Render benchmark graphs into a static HTML file." + +cliParser :: Parser Cli +cliParser = + Cli + <$> strOption + ( long "output" + <> short 'o' + <> metavar "PATH" + <> value "benchmark-display.html" + <> showDefault + <> help "Output HTML path." + ) + <*> optional + (strOption + ( long "sqlite" + <> metavar "PATH" + <> help "Read benchmark data from sqlite database." + )) + <*> ( T.pack + <$> strOption + ( long "branch" + <> metavar "BRANCH" + <> value "master" + <> showDefault + <> help "Branch name to load in sqlite mode." + ) + ) + <*> option + auto + ( long "limit" + <> metavar "INT" + <> value 28 + <> showDefault + <> help "Number of most recent commits in sqlite mode." + ) + <*> many + (strArgument + ( metavar "JSON_FILES..." + <> help "JSON files, each containing a top-level array of Benchmark." + )) diff --git a/package.yaml b/package.yaml index 39751ee..ba9d8ea 100644 --- a/package.yaml +++ b/package.yaml @@ -59,6 +59,14 @@ executables: ghc-options: -threaded -rtsopts -with-rtsopts=-N dependencies: - perfly + benchmark-display: + main: app/BenchmarkDisplay.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + dependencies: + - perfly + - optparse-applicative + - process + - filepath tests: spec: diff --git a/perfly.cabal b/perfly.cabal index 0f84ee4..45794da 100644 --- a/perfly.cabal +++ b/perfly.cabal @@ -25,6 +25,7 @@ library Perf.Web.Dispatch Perf.Web.Foundation Perf.Web.Layout + Perf.Web.Plot Perf.Web.Routes Yesod.Lucid other-modules: @@ -78,6 +79,61 @@ library , yesod default-language: GHC2021 +executable benchmark-display + main-is: app/BenchmarkDisplay.hs + other-modules: + Paths_perfly + default-extensions: + BlockArguments + OverloadedStrings + DuplicateRecordFields + NamedFieldPuns + DeriveGeneric + DerivingStrategies + DeriveAnyClass + TypeApplications + OverloadedRecordDot + ViewPatterns + LambdaCase + ExplicitNamespaces + QuasiQuotes + TypeFamilies + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base + , bytestring + , containers + , criterion-measurement + , directory + , exceptions + , filepath + , formatting + , hspec-discover + , hspec-expectations-lifted + , http-types + , lucid2 + , monad-logger + , mtl + , optparse-applicative + , perfly + , persistent + , persistent-sqlite + , persistent-template + , process + , resourcet + , rio + , text + , time + , transformers + , unix + , unliftio + , wai + , wai-extra + , warp + , yesod + default-language: GHC2021 + executable perfly main-is: app/Main.hs other-modules: diff --git a/readme.md b/readme.md index 69e48f7..9090026 100644 --- a/readme.md +++ b/readme.md @@ -26,6 +26,85 @@ Data is stored in a simple SQLite database. The URL to send data is: https://your-deployed-perfly/branch/$BRANCH_NAME/$COMMIT_HASH?token= +## Static HTML report CLI + +The project also provides a CLI tool that renders benchmark graphs to a +standalone HTML file (using the same Plotly graph style as the web UI) +and opens it locally. + +### Build + +`cabal build benchmark-display` + +### Install + +Install `benchmark-display` to a user's bin directory: + +```sh +mkdir -p "$HOME/.local/bin" +cabal install benchmark-display \ + --install-method=copy \ + --installdir="$HOME/.local/bin" \ + --overwrite-policy=always +``` + +Make sure your shell `PATH` includes that directory (for zsh): + +```sh +echo 'export PATH="$HOME/.local/bin:$PATH"' >> "$HOME/.zshrc" +source "$HOME/.zshrc" +``` + +Then you can run: + +```sh +benchmark-display --help +``` + +If you prefer not to install, use `cabal run benchmark-display -- ...` +from the project directory. + +### Usage + +Run with JSON files (each file must be a top-level JSON array of +`Benchmark` values, not a `Commit` object): + +```sh +benchmark-display run-1.json run-2.json +``` + +Write to a custom output path: + +```sh +benchmark-display --output reports/benchmark-display.html run-1.json run-2.json +``` + +Read data from SQLite (same DB model as the web server): + +```sh +benchmark-display --sqlite perf.sqlite3 --branch master --limit 28 +``` + +If you did not install to the path, the commands need to be modified like this: + +```sh +cabal run benchmark-display -- --output benchmark.html run-1.json run-2.json +``` + +Notes: + +- The generated file defaults to `benchmark-display.html`. +- After writing, the tool runs `open benchmark-display.html` on macOS + (or `xdg-open` on Linux). +- X-axis labels are derived from input files in CLI argument order. +- If a filename ends with `-.json`, that `` suffix + is used as the label; otherwise the `.json`-stripped basename is used. + +Examples of labels: + +- `bench-master-1e2a4b.json` -> `1e2a4b` +- `benchmark_snapshot.json` -> `benchmark_snapshot` + ## Schema The simple idea is that for a given commit we do some benchmarks. diff --git a/src/Perf/DB/Materialize.hs b/src/Perf/DB/Materialize.hs index fee1e10..d205316 100644 --- a/src/Perf/DB/Materialize.hs +++ b/src/Perf/DB/Materialize.hs @@ -1,25 +1,35 @@ module Perf.DB.Materialize where import qualified Data.List as List -import Data.Traversable -import Data.Set (Set) -import qualified Data.Set as Set import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map -import qualified Perf.Types.Prim as Prim +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Traversable import Database.Persist +import qualified Perf.Types.Prim as Prim import qualified Perf.Types.DB as DB +import qualified Perf.Types.External as EX + +type BenchmarkSeries key metric = + Map Prim.SubjectName + (Map (Set Prim.GeneralFactor) + (Map Prim.MetricLabel + (Map key metric))) + +data DisplayMetric = DisplayMetric + { mean :: Double + } + deriving (Eq, Show) -- Materialize a set of commits into a data set we can work with. materializeCommits :: NonEmpty (Entity DB.Commit) -> DB.DB - (Map Prim.SubjectName - (Map (Set Prim.GeneralFactor) - (Map Prim.MetricLabel - (Map DB.Commit DB.Metric)))) + (BenchmarkSeries DB.Commit DB.Metric) materializeCommits commits = do benchmarks <- traverse materializeCommit commits pure $ @@ -58,3 +68,28 @@ materializeCommit commit = do (metric.metricName, (commit.entityVal, metric))) ) + +materializeExternalSnapshots :: + NonEmpty (Text, [EX.Benchmark]) -> + BenchmarkSeries Text DisplayMetric +materializeExternalSnapshots snapshots = + List.foldl1' (Map.unionWith (Map.unionWith (Map.unionWith Map.union))) $ + NonEmpty.toList $ + fmap materializeSnapshot snapshots + where + materializeSnapshot :: (Text, [EX.Benchmark]) -> BenchmarkSeries Text DisplayMetric + materializeSnapshot (label, benchmarks) = + Map.fromList $ + flip map benchmarks \benchmark -> + (Prim.SubjectName benchmark.subject, + Map.fromList $ + flip map benchmark.tests \test -> + let factors = + Set.fromList $ + flip map test.factors \factor -> + Prim.GeneralFactor factor.factor factor.value + metrics = + Map.fromList $ + flip map test.metrics \metric -> + (Prim.MetricLabel metric.metric, Map.singleton label DisplayMetric {mean = metric.mean}) + in (factors, metrics)) diff --git a/src/Perf/Web/Layout.hs b/src/Perf/Web/Layout.hs index 0908496..50ac3d9 100644 --- a/src/Perf/Web/Layout.hs +++ b/src/Perf/Web/Layout.hs @@ -10,20 +10,7 @@ import Yesod.Lucid defaultLayout_ :: Text -> HtmlT (Reader (Page App)) a -> HtmlT (Reader (Page App)) a defaultLayout_ title body = do doctypehtml_ do - head_ do - meta_ [charset_ "utf-8"] - title_ $ toHtml title - style_ $ - T.unwords - [ "body {font-family: monospace; margin: 0 auto; max-width: 800px;}", - "table.metrics td, table.metrics th {border: 1px solid black; padding: 2px;}" - ] - script_ - [ src_ "https://cdn.jsdelivr.net/npm/plotly.js-dist-min@2.35.2/plotly.min.js", - crossorigin_ "anonymous", - makeAttributes "referrerpolicy" "no-referrer" - ] - (mempty :: Text) + headCommon_ title body_ do h1_ $ toHtml title crumbs <- asks (.crumbs) @@ -34,3 +21,28 @@ defaultLayout_ title body = do a_ [href_ (url route)] $ toHtml display sequence_ $ List.intersperse (em_ " / ") loaf body + +staticLayout_ :: Text -> Html () -> Html () +staticLayout_ title body = + doctypehtml_ do + headCommon_ title + body_ do + h1_ $ toHtml title + body + +headCommon_ :: Monad m => Text -> HtmlT m () +headCommon_ title = + head_ do + meta_ [charset_ "utf-8"] + title_ $ toHtml title + style_ $ + T.unwords + [ "body {font-family: monospace; margin: 0 auto; max-width: 800px;}", + "table.metrics td, table.metrics th {border: 1px solid black; padding: 2px;}" + ] + script_ + [ src_ "https://cdn.jsdelivr.net/npm/plotly.js-dist-min@2.35.2/plotly.min.js", + crossorigin_ "anonymous", + makeAttributes "referrerpolicy" "no-referrer" + ] + (mempty :: Text) diff --git a/src/Perf/Web/Plot.hs b/src/Perf/Web/Plot.hs new file mode 100644 index 0000000..798e413 --- /dev/null +++ b/src/Perf/Web/Plot.hs @@ -0,0 +1,107 @@ +module Perf.Web.Plot where + +import Data.Aeson +import Data.Coerce +import Data.Foldable qualified as Foldable +import Data.Map qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Control.Monad +import Lucid +import Perf.DB.Materialize +import Perf.Types.DB qualified as DB +import Perf.Types.Prim qualified as Prim +import Perf.Web.Chart + +generateCommitPlots :: BenchmarkSeries DB.Commit DB.Metric -> Html () +generateCommitPlots = + generatePlotsWith + (T.take 8 . (coerce :: Prim.Hash -> Text) . (.commitHash)) + (.metricMean) + +generateExternalPlots :: BenchmarkSeries Text DisplayMetric -> Html () +generateExternalPlots = + generatePlotsWith id (.mean) + +generatePlotsWith :: + Ord key => + (key -> Text) -> + (metric -> Double) -> + BenchmarkSeries key metric -> + Html () +generatePlotsWith renderKey metricMean benchmarks = do + unless (Map.null benchmarks) $ h1_ "Plots" + Foldable.for_ (zip [0 :: Int ..] (Map.toList benchmarks)) \(benchmarkIdx, (subject, tests)) -> do + h2_ $ toHtml subject + let keys = + Set.fromList $ concatMap (concatMap Map.keys . Map.elems) $ Map.elems tests + let orderedKeys = Set.toList keys + let labels = map renderKey orderedKeys + let metrics :: Set Prim.MetricLabel = + Set.fromList $ concatMap Map.keys $ Map.elems tests + div_ [style_ "display: flex; flex-wrap: wrap;"] do + Foldable.for_ (zip [0 :: Int ..] (Set.toList metrics)) \(metricIdx, metricLabel) -> do + let dataSets = + flip map (Map.toList tests) \(factors, allMetrics) -> + (factors, toSeries orderedKeys (Map.findWithDefault Map.empty metricLabel allMetrics)) + let (plotData, layout) = makePlotlyConfig metricLabel labels dataSets + chart_ (T.pack (show benchmarkIdx) <> "-" <> T.pack (show metricIdx)) plotData layout + where + toSeries orderedKeys metricMap = + flip map orderedKeys \key -> + maybe Null (toJSON . metricMean) $ + Map.lookup key metricMap + +makePlotlyConfig :: + Prim.MetricLabel -> + [Text] -> + [(Set Prim.GeneralFactor, [Value])] -> + (Value, Value) +makePlotlyConfig metricName labels dataSets = + (toJSON traces, layout) + where + traces = + [ object + [ "x" .= labels, + "y" .= series, + "type" .= ("scatter" :: Text), + "mode" .= ("lines+markers" :: Text), + "name" .= factorsSmall factors, + "line" .= object ["color" .= color] + ] + | ((factors, series), color) <- zip dataSets $ cycle colors + ] + layout = + object + [ "title" + .= object + [ "text" .= coerce @_ @Text metricName, + "font" .= object ["family" .= ("monospace" :: Text), "size" .= (16 :: Int)] + ], + "xaxis" + .= object + [ "title" .= ("" :: Text), + "tickfont" .= object ["family" .= ("monospace" :: Text)] + ], + "yaxis" + .= object + [ "title" .= coerce @_ @Text metricName, + "rangemode" .= ("tozero" :: Text), + "tickfont" .= object ["family" .= ("monospace" :: Text)] + ], + "font" .= object ["family" .= ("monospace" :: Text)], + "hovermode" .= ("x unified" :: Text), + "showlegend" .= True, + "legend" .= object ["x" .= (1 :: Int), "y" .= (0 :: Int), "xanchor" .= ("right" :: Text), "bgcolor" .= ("rgba(0,0,0,0)" :: Text), "font" .= object ["color" .= ("rgba(0,0,0,0.4)" :: Text)]], + "margin" .= object ["t" .= (40 :: Int), "b" .= (40 :: Int), "l" .= (60 :: Int), "r" .= (20 :: Int)] + ] + colors :: [Text] = + T.words "#4394E5 #87BB62 #876FD4 #F5921B" + +factorSmall :: Prim.GeneralFactor -> Text +factorSmall factor = T.concat [T.strip factor.name, "=", T.strip factor.value] + +factorsSmall :: Set Prim.GeneralFactor -> Text +factorsSmall = T.intercalate "," . map factorSmall . Set.toList diff --git a/src/Perf/Web/Routes.hs b/src/Perf/Web/Routes.hs index 75f281e..90b7c3a 100644 --- a/src/Perf/Web/Routes.hs +++ b/src/Perf/Web/Routes.hs @@ -1,6 +1,5 @@ module Perf.Web.Routes where -import Data.Bifunctor import Data.Coerce import Data.Containers.ListUtils qualified as List import Data.Foldable @@ -10,7 +9,6 @@ import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe import Data.Set (Set) -import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Traversable @@ -21,11 +19,11 @@ import Perf.DB.Materialize import Perf.Types.DB qualified as DB import Perf.Types.External qualified as EX import Perf.Types.Prim qualified as Prim -import Perf.Types.Web -import Perf.Web.Chart +import Perf.Types.Web import Perf.Web.Db import Perf.Web.Foundation import Perf.Web.Layout +import Perf.Web.Plot import RIO qualified import Text.Printf import Yesod hiding (Html, toHtml) @@ -99,91 +97,10 @@ getBranchR name = do toHtml $ show maxGraph " commits)" -factorSmall :: Prim.GeneralFactor -> Text -factorSmall factor = T.concat [T.strip factor.name, "=", T.strip factor.value] - -factorsSmall :: Set Prim.GeneralFactor -> Text -factorsSmall = T.intercalate "," . map factorSmall . toList - generatePlots :: - ( Map - Prim.SubjectName - ( Map - (Set Prim.GeneralFactor) - ( Map - Prim.MetricLabel - (Map DB.Commit DB.Metric) - ) - ) - ) -> + BenchmarkSeries DB.Commit DB.Metric -> Html () -generatePlots benchmarks = do - unless (Map.null benchmarks) $ h1_ "Plots" - for_ (zip [0 :: Int ..] (Map.toList benchmarks)) \(b_i, (subject, tests)) -> do - h2_ $ toHtml subject - let labels :: Set DB.Commit = - Set.fromList $ concatMap (concatMap Map.keys . Map.elems) $ Map.elems tests - let metrics :: Set Prim.MetricLabel = - Set.fromList $ concatMap Map.keys $ Map.elems tests - -- Produce a chart for each type of metric. - div_ [style_ "display: flex; flex-wrap: wrap;"] do - for_ (zip [0 :: Int ..] (toList metrics)) \(m_i, metricLabel) -> do - let dataSets = - map (second (maybe [] Map.elems . Map.lookup metricLabel)) $ - Map.toList tests - let (plotData, layout) = makePlotlyConfig metricLabel labels dataSets - chart_ (T.pack (show b_i) <> "-" <> T.pack (show m_i)) plotData layout - -makePlotlyConfig :: - Prim.MetricLabel -> - Set DB.Commit -> - [(Set Prim.GeneralFactor, [DB.Metric])] -> - (Value, Value) -makePlotlyConfig metricName commits dataSets = - (toJSON traces, layout) - where - commitLabels = List.map (T.take 8 . (coerce :: Prim.Hash -> Text) . (.commitHash)) (Set.toList commits) - traces = - [ object - [ "x" .= commitLabels, - "y" .= fillLeft (Set.size commits) Null (map (toJSON . (.metricMean)) metrics :: [Value]), - "type" .= ("scatter" :: Text), - "mode" .= ("lines+markers" :: Text), - "name" .= factorsSmall factors, - "line" .= object ["color" .= color] - ] - | ((factors, metrics), color) <- zip dataSets $ cycle colors - ] - layout = - object - [ "title" - .= object - [ "text" .= coerce @_ @Text metricName, - "font" .= object ["family" .= ("monospace" :: Text), "size" .= (16 :: Int)] - ], - "xaxis" - .= object - [ "title" .= ("" :: Text), - "tickfont" .= object ["family" .= ("monospace" :: Text)] - ], - "yaxis" - .= object - [ "title" .= coerce @_ @Text metricName, - "rangemode" .= ("tozero" :: Text), - "tickfont" .= object ["family" .= ("monospace" :: Text)] - ], - "font" .= object ["family" .= ("monospace" :: Text)], - "hovermode" .= ("x unified" :: Text), - "showlegend" .= True, - "legend" .= object ["x" .= (1 :: Int), "y" .= (0 :: Int), "xanchor" .= ("right" :: Text), "bgcolor" .= ("rgba(0,0,0,0)" :: Text), "font" .= object ["color" .= ("rgba(0,0,0,0.4)" :: Text)]], - "margin" .= object ["t" .= (40 :: Int), "b" .= (40 :: Int), "l" .= (60 :: Int), "r" .= (20 :: Int)] - ] - colors :: [Text] = - T.words - "#4394E5 #87BB62 #876FD4 #F5921B" - -fillLeft :: Int -> a -> [a] -> [a] -fillLeft n x xs = replicate (n - length xs) x <> xs +generatePlots = generateCommitPlots getCommitR :: Prim.Hash -> Handler (Html ()) getCommitR hash = do