Skip to content

Commit e87d02f

Browse files
winitzkiwinitzki
authored
Merge pull request #17 from artificialio/sergeiwinitzki/lan-51-add-benchmark-display
hide: LAN-52 add benchmark display executable
2 parents 8dd821a + 69765ca commit e87d02f

8 files changed

Lines changed: 478 additions & 109 deletions

File tree

‎app/BenchmarkDisplay.hs‎

Lines changed: 155 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,155 @@
1+
import Data.Aeson (eitherDecodeFileStrict')
2+
import Data.Char (isHexDigit)
3+
import Data.List.NonEmpty (NonEmpty)
4+
import Data.List.NonEmpty qualified as NonEmpty
5+
import Data.Maybe (catMaybes)
6+
import Data.Text (Text)
7+
import Data.Text qualified as T
8+
import Data.Text.Lazy.IO qualified as LTIO
9+
import Database.Persist
10+
import Database.Persist.Sqlite (runMigration, runSqlite)
11+
import Lucid (renderText)
12+
import Options.Applicative
13+
import Perf.DB.Materialize
14+
import Perf.Types.DB qualified as DB
15+
import Perf.Types.External qualified as EX
16+
import Perf.Web.Layout
17+
import Perf.Web.Plot
18+
import System.Directory (makeAbsolute)
19+
import System.Exit (ExitCode (ExitSuccess), die)
20+
import System.FilePath (takeBaseName)
21+
import System.Info (os)
22+
import System.Process (rawSystem)
23+
24+
data Cli = Cli
25+
{ outputPath :: FilePath,
26+
sqlitePath :: Maybe FilePath,
27+
branchName :: Text,
28+
maxCommits :: Int,
29+
jsonFiles :: [FilePath]
30+
}
31+
32+
data Source
33+
= JsonFiles (NonEmpty FilePath)
34+
| Sqlite FilePath Text Int
35+
36+
main :: IO ()
37+
main = do
38+
cli <- execParser parserInfo
39+
source <- validateSource cli
40+
html <- case source of
41+
JsonFiles files -> do
42+
snapshots <- mapM loadSnapshot $ NonEmpty.toList files
43+
pure $
44+
staticLayout_ "Benchmarks" $
45+
generateExternalPlots $
46+
materializeExternalSnapshots $
47+
NonEmpty.fromList snapshots
48+
Sqlite sqlite branch limit -> do
49+
benchmarks <- loadBenchmarksFromSqlite sqlite branch limit
50+
pure $
51+
staticLayout_ ("Benchmarks: " <> branch) $
52+
generateCommitPlots benchmarks
53+
absoluteOutput <- makeAbsolute cli.outputPath
54+
LTIO.writeFile absoluteOutput (renderText html)
55+
openFile absoluteOutput
56+
57+
validateSource :: Cli -> IO Source
58+
validateSource cli =
59+
case (cli.sqlitePath, NonEmpty.nonEmpty cli.jsonFiles) of
60+
(Just sqlite, Nothing) -> pure $ Sqlite sqlite cli.branchName cli.maxCommits
61+
(Nothing, Just files) -> pure $ JsonFiles files
62+
(Just _, Just _) -> die "Use either JSON files or --sqlite, not both."
63+
(Nothing, Nothing) -> die "Provide one or more JSON files, or use --sqlite."
64+
65+
loadSnapshot :: FilePath -> IO (Text, [EX.Benchmark])
66+
loadSnapshot path = do
67+
decoded <- eitherDecodeFileStrict' path
68+
case decoded of
69+
Left err -> die $ "Failed to decode " <> path <> ": " <> err
70+
Right benchmarks -> pure (labelFromPath path, benchmarks)
71+
72+
labelFromPath :: FilePath -> Text
73+
labelFromPath path =
74+
let base = takeBaseName path
75+
suffix = reverse $ takeWhile (/= '-') $ reverse base
76+
hasDash = '-' `elem` base
77+
in if hasDash && not (null suffix) && all isHexDigit suffix
78+
then T.pack suffix
79+
else T.pack base
80+
81+
loadBenchmarksFromSqlite :: FilePath -> Text -> Int -> IO (BenchmarkSeries DB.Commit DB.Metric)
82+
loadBenchmarksFromSqlite sqlite branch limit =
83+
runSqlite (T.pack sqlite) do
84+
runMigration DB.migrateAll
85+
mbranch <- selectFirst [DB.BranchName ==. branch] []
86+
case mbranch of
87+
Nothing -> pure mempty
88+
Just (Entity branchId _) -> do
89+
mappings <-
90+
selectList
91+
[DB.MapBranchCommitBranchId ==. branchId]
92+
[Desc DB.MapBranchCommitId, LimitTo limit]
93+
commits <- mapM (\mapping -> selectFirst [DB.CommitId ==. mapping.entityVal.mapBranchCommitCommitId] []) mappings
94+
case NonEmpty.nonEmpty $ reverse $ catMaybes commits of
95+
Nothing -> pure mempty
96+
Just existingCommits -> materializeCommits existingCommits
97+
98+
openFile :: FilePath -> IO ()
99+
openFile path =
100+
case os of
101+
"darwin" -> runOpen "open"
102+
"linux" -> runOpen "xdg-open"
103+
_ -> putStrLn $ "Wrote " <> path
104+
where
105+
runOpen command = do
106+
status <- rawSystem command [path]
107+
case status of
108+
ExitSuccess -> pure ()
109+
_ -> putStrLn $ "Wrote " <> path
110+
111+
parserInfo :: ParserInfo Cli
112+
parserInfo =
113+
info (cliParser <**> helper) $
114+
fullDesc
115+
<> progDesc "Render benchmark graphs into a static HTML file."
116+
117+
cliParser :: Parser Cli
118+
cliParser =
119+
Cli
120+
<$> strOption
121+
( long "output"
122+
<> short 'o'
123+
<> metavar "PATH"
124+
<> value "benchmark-display.html"
125+
<> showDefault
126+
<> help "Output HTML path."
127+
)
128+
<*> optional
129+
(strOption
130+
( long "sqlite"
131+
<> metavar "PATH"
132+
<> help "Read benchmark data from sqlite database."
133+
))
134+
<*> ( T.pack
135+
<$> strOption
136+
( long "branch"
137+
<> metavar "BRANCH"
138+
<> value "master"
139+
<> showDefault
140+
<> help "Branch name to load in sqlite mode."
141+
)
142+
)
143+
<*> option
144+
auto
145+
( long "limit"
146+
<> metavar "INT"
147+
<> value 28
148+
<> showDefault
149+
<> help "Number of most recent commits in sqlite mode."
150+
)
151+
<*> many
152+
(strArgument
153+
( metavar "JSON_FILES..."
154+
<> help "JSON files, each containing a top-level array of Benchmark."
155+
))

‎package.yaml‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,14 @@ executables:
5959
ghc-options: -threaded -rtsopts -with-rtsopts=-N
6060
dependencies:
6161
- perfly
62+
benchmark-display:
63+
main: app/BenchmarkDisplay.hs
64+
ghc-options: -threaded -rtsopts -with-rtsopts=-N
65+
dependencies:
66+
- perfly
67+
- optparse-applicative
68+
- process
69+
- filepath
6270

6371
tests:
6472
spec:

‎perfly.cabal‎

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ library
2525
Perf.Web.Dispatch
2626
Perf.Web.Foundation
2727
Perf.Web.Layout
28+
Perf.Web.Plot
2829
Perf.Web.Routes
2930
Yesod.Lucid
3031
other-modules:
@@ -78,6 +79,61 @@ library
7879
, yesod
7980
default-language: GHC2021
8081

82+
executable benchmark-display
83+
main-is: app/BenchmarkDisplay.hs
84+
other-modules:
85+
Paths_perfly
86+
default-extensions:
87+
BlockArguments
88+
OverloadedStrings
89+
DuplicateRecordFields
90+
NamedFieldPuns
91+
DeriveGeneric
92+
DerivingStrategies
93+
DeriveAnyClass
94+
TypeApplications
95+
OverloadedRecordDot
96+
ViewPatterns
97+
LambdaCase
98+
ExplicitNamespaces
99+
QuasiQuotes
100+
TypeFamilies
101+
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
102+
build-depends:
103+
aeson
104+
, base
105+
, bytestring
106+
, containers
107+
, criterion-measurement
108+
, directory
109+
, exceptions
110+
, filepath
111+
, formatting
112+
, hspec-discover
113+
, hspec-expectations-lifted
114+
, http-types
115+
, lucid2
116+
, monad-logger
117+
, mtl
118+
, optparse-applicative
119+
, perfly
120+
, persistent
121+
, persistent-sqlite
122+
, persistent-template
123+
, process
124+
, resourcet
125+
, rio
126+
, text
127+
, time
128+
, transformers
129+
, unix
130+
, unliftio
131+
, wai
132+
, wai-extra
133+
, warp
134+
, yesod
135+
default-language: GHC2021
136+
81137
executable perfly
82138
main-is: app/Main.hs
83139
other-modules:

‎readme.md‎

Lines changed: 79 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,85 @@ Data is stored in a simple SQLite database.
2626
The URL to send data is:
2727
https://your-deployed-perfly/branch/$BRANCH_NAME/$COMMIT_HASH?token=<YOUR TOKEN>
2828

29+
## Static HTML report CLI
30+
31+
The project also provides a CLI tool that renders benchmark graphs to a
32+
standalone HTML file (using the same Plotly graph style as the web UI)
33+
and opens it locally.
34+
35+
### Build
36+
37+
`cabal build benchmark-display`
38+
39+
### Install
40+
41+
Install `benchmark-display` to a user's bin directory:
42+
43+
```sh
44+
mkdir -p "$HOME/.local/bin"
45+
cabal install benchmark-display \
46+
--install-method=copy \
47+
--installdir="$HOME/.local/bin" \
48+
--overwrite-policy=always
49+
```
50+
51+
Make sure your shell `PATH` includes that directory (for zsh):
52+
53+
```sh
54+
echo 'export PATH="$HOME/.local/bin:$PATH"' >> "$HOME/.zshrc"
55+
source "$HOME/.zshrc"
56+
```
57+
58+
Then you can run:
59+
60+
```sh
61+
benchmark-display --help
62+
```
63+
64+
If you prefer not to install, use `cabal run benchmark-display -- ...`
65+
from the project directory.
66+
67+
### Usage
68+
69+
Run with JSON files (each file must be a top-level JSON array of
70+
`Benchmark` values, not a `Commit` object):
71+
72+
```sh
73+
benchmark-display run-1.json run-2.json
74+
```
75+
76+
Write to a custom output path:
77+
78+
```sh
79+
benchmark-display --output reports/benchmark-display.html run-1.json run-2.json
80+
```
81+
82+
Read data from SQLite (same DB model as the web server):
83+
84+
```sh
85+
benchmark-display --sqlite perf.sqlite3 --branch master --limit 28
86+
```
87+
88+
If you did not install to the path, the commands need to be modified like this:
89+
90+
```sh
91+
cabal run benchmark-display -- --output benchmark.html run-1.json run-2.json
92+
```
93+
94+
Notes:
95+
96+
- The generated file defaults to `benchmark-display.html`.
97+
- After writing, the tool runs `open benchmark-display.html` on macOS
98+
(or `xdg-open` on Linux).
99+
- X-axis labels are derived from input files in CLI argument order.
100+
- If a filename ends with `-<hex>.json`, that `<hex>` suffix
101+
is used as the label; otherwise the `.json`-stripped basename is used.
102+
103+
Examples of labels:
104+
105+
- `bench-master-1e2a4b.json` -> `1e2a4b`
106+
- `benchmark_snapshot.json` -> `benchmark_snapshot`
107+
29108
## Schema
30109

31110
The simple idea is that for a given commit we do some benchmarks.

‎src/Perf/DB/Materialize.hs‎

Lines changed: 43 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,25 +1,35 @@
11
module Perf.DB.Materialize where
22

33
import qualified Data.List as List
4-
import Data.Traversable
5-
import Data.Set (Set)
6-
import qualified Data.Set as Set
74
import Data.List.NonEmpty (NonEmpty)
85
import qualified Data.List.NonEmpty as NonEmpty
96
import Data.Map (Map)
107
import qualified Data.Map as Map
11-
import qualified Perf.Types.Prim as Prim
8+
import Data.Set (Set)
9+
import qualified Data.Set as Set
10+
import Data.Text (Text)
11+
import Data.Traversable
1212
import Database.Persist
13+
import qualified Perf.Types.Prim as Prim
1314
import qualified Perf.Types.DB as DB
15+
import qualified Perf.Types.External as EX
16+
17+
type BenchmarkSeries key metric =
18+
Map Prim.SubjectName
19+
(Map (Set Prim.GeneralFactor)
20+
(Map Prim.MetricLabel
21+
(Map key metric)))
22+
23+
data DisplayMetric = DisplayMetric
24+
{ mean :: Double
25+
}
26+
deriving (Eq, Show)
1427

1528
-- Materialize a set of commits into a data set we can work with.
1629
materializeCommits ::
1730
NonEmpty (Entity DB.Commit) ->
1831
DB.DB
19-
(Map Prim.SubjectName
20-
(Map (Set Prim.GeneralFactor)
21-
(Map Prim.MetricLabel
22-
(Map DB.Commit DB.Metric))))
32+
(BenchmarkSeries DB.Commit DB.Metric)
2333
materializeCommits commits = do
2434
benchmarks <- traverse materializeCommit commits
2535
pure $
@@ -58,3 +68,28 @@ materializeCommit commit = do
5868
(metric.metricName,
5969
(commit.entityVal, metric)))
6070
)
71+
72+
materializeExternalSnapshots ::
73+
NonEmpty (Text, [EX.Benchmark]) ->
74+
BenchmarkSeries Text DisplayMetric
75+
materializeExternalSnapshots snapshots =
76+
List.foldl1' (Map.unionWith (Map.unionWith (Map.unionWith Map.union))) $
77+
NonEmpty.toList $
78+
fmap materializeSnapshot snapshots
79+
where
80+
materializeSnapshot :: (Text, [EX.Benchmark]) -> BenchmarkSeries Text DisplayMetric
81+
materializeSnapshot (label, benchmarks) =
82+
Map.fromList $
83+
flip map benchmarks \benchmark ->
84+
(Prim.SubjectName benchmark.subject,
85+
Map.fromList $
86+
flip map benchmark.tests \test ->
87+
let factors =
88+
Set.fromList $
89+
flip map test.factors \factor ->
90+
Prim.GeneralFactor factor.factor factor.value
91+
metrics =
92+
Map.fromList $
93+
flip map test.metrics \metric ->
94+
(Prim.MetricLabel metric.metric, Map.singleton label DisplayMetric {mean = metric.mean})
95+
in (factors, metrics))

0 commit comments

Comments
 (0)