hide: LAN-52 add benchmark display executable

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."
+        ))

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:

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:

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=<YOUR 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 `-<hex>.json`, that `<hex>` 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.

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))