2026-06-09 21:21.03: New job: test ocurrent/ocaml-docs-ci https://github.com/ocurrent/ocaml-docs-ci.git#refs/pull/186/head (46f5a1a1faa82758d1b6fce161dd1dd8ba69b162) (linux-x86_64:(lint-fmt))
Base: ocaml/opam:debian-13-ocaml-4.11@sha256:6c34153b2b07fc0f884e792a60178e250c2d06a45050e01ed0883a67ec11440c
ocamlformat version: version 0.27.0 (from opam)
To reproduce locally:
git clone --recursive "https://github.com/ocurrent/ocaml-docs-ci.git" && cd "ocaml-docs-ci" && git fetch origin "refs/pull/186/head" && git reset --hard 46f5a1a1
cat > Dockerfile <<'END-OF-DOCKERFILE'
FROM ocaml/opam:debian-13-ocaml-4.11@sha256:6c34153b2b07fc0f884e792a60178e250c2d06a45050e01ed0883a67ec11440c
USER 1000:1000
RUN cd ~/opam-repository && (git cat-file -e c180e1630960e0dbb8e30c22b3de89113eb5cc93 || git fetch origin master) && git reset -q --hard c180e1630960e0dbb8e30c22b3de89113eb5cc93 && git log --no-decorate -n1 --oneline && opam update -u
RUN opam depext -i dune
WORKDIR /src
RUN opam depext -i ocamlformat=0.27.0
COPY --chown=1000:1000 . /src/
RUN opam exec -- dune build @fmt --ignore-promoted-rules || (echo "dune build @fmt failed"; exit 2)
END-OF-DOCKERFILE
docker build .
END-REPRO-BLOCK
2026-06-09 21:21.03: Using cache hint "ocurrent/ocaml-docs-ci-ocaml/opam:debian-13-ocaml-4.11@sha256:6c34153b2b07fc0f884e792a60178e250c2d06a45050e01ed0883a67ec11440c-debian-13-4.11_opam-2.5-ocamlformat-c180e1630960e0dbb8e30c22b3de89113eb5cc93"
2026-06-09 21:21.03: Using OBuilder spec:
((from ocaml/opam:debian-13-ocaml-4.11@sha256:6c34153b2b07fc0f884e792a60178e250c2d06a45050e01ed0883a67ec11440c)
(user (uid 1000) (gid 1000))
(run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "cd ~/opam-repository && (git cat-file -e c180e1630960e0dbb8e30c22b3de89113eb5cc93 || git fetch origin master) && git reset -q --hard c180e1630960e0dbb8e30c22b3de89113eb5cc93 && git log --no-decorate -n1 --oneline && opam update -u"))
(run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "opam depext -i dune"))
(workdir /src)
(run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "opam depext -i ocamlformat=0.27.0"))
(copy (src .) (dst /src/))
(run (shell "opam exec -- dune build @fmt --ignore-promoted-rules || (echo \"dune build @fmt failed\"; exit 2)"))
)
2026-06-09 21:21.03: Waiting for resource in pool OCluster
2026-06-09 21:21.03: Waiting for worker…
2026-06-09 21:21.03: Got resource from pool OCluster
Building on asteria.caelum.ci.dev
All commits already cached
HEAD is now at 46f5a1a Add odoc to quick profile
(from ocaml/opam:debian-13-ocaml-4.11@sha256:6c34153b2b07fc0f884e792a60178e250c2d06a45050e01ed0883a67ec11440c)
2026-06-09 21:21.05 ---> using "36abb6db1723167d15c41f53ef05d371444812dc64e2ea7fe109d222db988473" from cache
/: (user (uid 1000) (gid 1000))
/: (run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "cd ~/opam-repository && (git cat-file -e c180e1630960e0dbb8e30c22b3de89113eb5cc93 || git fetch origin master) && git reset -q --hard c180e1630960e0dbb8e30c22b3de89113eb5cc93 && git log --no-decorate -n1 --oneline && opam update -u"))
From https://github.com/ocaml/opam-repository
* branch master -> FETCH_HEAD
fc08333d1b..b860455781 master -> origin/master
c180e16309 Merge pull request #29907 from dra27/host-arch-fixes
<><> Updating package repositories ><><><><><><><><><><><><><><><><><><><><><><>
[default] synchronised from git+file:///home/opam/opam-repository
Everything as up-to-date as possible (run with --verbose to show unavailable upgrades).
The following packages are not being upgraded because the new versions conflict with other installed packages:
- ocaml.5.6.0
- ocaml-config.3
However, you may "opam upgrade" these packages explicitly, which will ask permission to downgrade or uninstall the conflicting packages.
Nothing to do.
# Run eval $(opam env) to update the current shell environment
2026-06-09 21:21.33 ---> saved as "151fdd6a6f64615c4d74766ca524c50c72359e7e763f0f681d3ae0c782b00efb"
/: (run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "opam depext -i dune"))
Since version 2.1, opam now handles external dependencies alongside OCaml ones, and the `depext` plugin interface is provided for backwards compatibility only. Consider using your usual `opam install` command to install both OCaml and system dependencies, or `opam install <pkg> --depext-only` if you want to only install external dependencies.
# Detecting depexts using vars: arch=x86_64, os=linux, os-distribution=debian, os-family=debian
# No extra OS packages requirements found.
The following actions will be performed:
- install ocaml-secondary-compiler 4.14.2 [required by dune]
- install ocamlfind 1.9.6 [required by ocamlfind-secondary]
- install ocamlfind-secondary 1.9.6 [required by dune]
- install dune 3.23.1
===== 4 to install =====
<><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><>
-> retrieved ocamlfind.1.9.6 (cached)
-> retrieved dune.3.23.1 (cached)
-> retrieved ocaml-secondary-compiler.4.14.2 (cached)
-> retrieved ocamlfind-secondary.1.9.6 (cached)
-> installed ocamlfind.1.9.6
-> installed ocaml-secondary-compiler.4.14.2
-> installed ocamlfind-secondary.1.9.6
-> installed dune.3.23.1
Done.
# Run eval $(opam env) to update the current shell environment
2026-06-09 21:23.40 ---> saved as "1c2b3695a14dc2896f8d80c5233e16c59be173f851024cd70e313d708a8a6bea"
/: (workdir /src)
/src: (run (cache (opam-archives (target /home/opam/.opam/download-cache)))
(network host)
(shell "opam depext -i ocamlformat=0.27.0"))
Since version 2.1, opam now handles external dependencies alongside OCaml ones, and the `depext` plugin interface is provided for backwards compatibility only. Consider using your usual `opam install` command to install both OCaml and system dependencies, or `opam install <pkg> --depext-only` if you want to only install external dependencies.
# Detecting depexts using vars: arch=x86_64, os=linux, os-distribution=debian, os-family=debian
# No extra OS packages requirements found.
The following actions will be performed:
- install cmdliner 1.3.0 [required by ocamlformat]
- install ocamlbuild 0.16.1 [required by fpath, astring, uuseg]
- install either 1.0.0 [required by ocamlformat-lib]
- install menhirLib 20260209 [required by ocamlformat-lib]
- install dune-build-info 3.23.1 [required by ocamlformat-lib]
- install csexp 1.5.2 [required by ocamlformat]
- install menhirSdk 20260209 [required by ocamlformat-lib]
- install menhirGLR 20260209 [required by menhir]
- install camlp-streams 5.0.1 [required by ocamlformat-lib]
- install seq base [required by re]
- install ocaml-version 4.1.1 [required by ocamlformat-lib]
- install fix 20250919 [required by ocamlformat-lib]
- install sexplib0 v0.15.1 [required by base]
- install menhirCST 20260209 [required by menhir]
- install ocp-indent 1.9.0 [required by ocamlformat-lib]
- install topkg 1.1.1 [required by fpath, astring, uuseg]
- install dune-configurator 3.22.2 [required by base]
- install re 1.11.0 [required by ocamlformat]
- install menhir 20260209 [required by ocamlformat-lib]
- install uutf 1.0.4 [required by ocamlformat-lib]
- install astring 0.8.5 [required by ocamlformat-lib]
- install base v0.15.2 [required by ocamlformat-lib]
- install uucp 15.0.0 [required by uuseg]
- install fpath 0.7.3 [required by ocamlformat-lib]
- install stdio v0.15.0 [required by ocamlformat-lib]
- install uuseg 15.0.0 [required by ocamlformat-lib]
- install ocamlformat-lib 0.27.0 [required by ocamlformat]
- install ocamlformat 0.27.0
===== 28 to install =====
<><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><>
-> retrieved astring.0.8.5 (cached)
-> retrieved base.v0.15.2 (cached)
-> retrieved camlp-streams.5.0.1 (cached)
-> retrieved cmdliner.1.3.0 (cached)
-> retrieved csexp.1.5.2 (cached)
-> retrieved dune-build-info.3.23.1 (cached)
-> installed camlp-streams.5.0.1
-> retrieved dune-configurator.3.22.2 (cached)
-> retrieved either.1.0.0 (cached)
-> installed csexp.1.5.2
-> retrieved fix.20250919 (cached)
-> retrieved fpath.0.7.3 (cached)
-> retrieved menhir.20260209 (cached)
-> retrieved menhirCST.20260209 (cached)
-> retrieved menhirGLR.20260209 (cached)
-> retrieved menhirLib.20260209 (cached)
-> installed cmdliner.1.3.0
-> installed dune-build-info.3.23.1
-> installed dune-configurator.3.22.2
-> installed either.1.0.0
-> installed fix.20250919
-> retrieved menhirSdk.20260209 (cached)
-> installed menhirCST.20260209
-> retrieved ocaml-version.4.1.1 (cached)
-> retrieved ocamlbuild.0.16.1 (cached)
-> retrieved ocp-indent.1.9.0 (cached)
-> retrieved re.1.11.0 (cached)
-> retrieved seq.base (cached)
-> installed seq.base
-> installed menhirGLR.20260209
-> installed menhirLib.20260209
-> retrieved sexplib0.v0.15.1 (cached)
-> installed ocaml-version.4.1.1
-> retrieved stdio.v0.15.0 (cached)
-> retrieved ocamlformat.0.27.0 (https://opam.ocaml.org/cache)
-> installed menhirSdk.20260209
-> retrieved topkg.1.1.1 (cached)
-> retrieved uuseg.15.0.0 (https://opam.ocaml.org/cache)
-> retrieved uutf.1.0.4 (cached)
-> installed sexplib0.v0.15.1
-> retrieved uucp.15.0.0 (https://opam.ocaml.org/cache)
-> installed re.1.11.0
-> installed ocp-indent.1.9.0
-> retrieved ocamlformat-lib.0.27.0 (https://opam.ocaml.org/cache)
-> installed ocamlbuild.0.16.1
-> installed base.v0.15.2
-> installed stdio.v0.15.0
-> installed menhir.20260209
-> installed topkg.1.1.1
-> installed uutf.1.0.4
-> installed astring.0.8.5
-> installed fpath.0.7.3
-> installed uucp.15.0.0
-> installed uuseg.15.0.0
-> installed ocamlformat-lib.0.27.0
-> installed ocamlformat.0.27.0
Done.
<><> ocp-indent.1.9.0 installed successfully ><><><><><><><><><><><><><><><><><>
=> This package requires additional configuration for use in editors. Install package 'user-setup', or manually:
* for Emacs, add these lines to ~/.emacs:
(add-to-list 'load-path "/home/opam/.opam/4.11/share/emacs/site-lisp")
(require 'ocp-indent)
* for Vim, add this line to ~/.vimrc:
set rtp^="/home/opam/.opam/4.11/share/ocp-indent/vim"
# Run eval $(opam env) to update the current shell environment
2026-06-09 21:24.45 ---> saved as "736f9d0acdcde4da87b44d0d1a1c9551776ecb59f6257be855b675a9e67eefc3"
/src: (copy (src .) (dst /src/))
2026-06-09 21:24.46 ---> saved as "9289c6a1cb1f89eb101ee3eb3b0795612167f6b635fad8274003a28e5f7b4117"
/src: (run (shell "opam exec -- dune build @fmt --ignore-promoted-rules || (echo \"dune build @fmt failed\"; exit 2)"))
File "day11/test-repo/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/test-repo/dune b/_build/default/day11/test-repo/.formatted/dune
index a3b544d..b6d1c82 100644
--- a/_build/default/day11/test-repo/dune
+++ b/_build/default/day11/test-repo/.formatted/dune
@@ -5,4 +5,5 @@
; we mark this directory tree as data_only — dune won't scan into
; it for .opam files (which would otherwise produce duplicate
; package errors, e.g. xref_forward at versions 1.0.0 and 1.0.1).
+
(data_only_dirs sources packages base cache)
File "day11/layer/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/dune b/_build/default/day11/layer/.formatted/dune
index d921da6..a00594a 100644
--- a/_build/default/day11/layer/dune
+++ b/_build/default/day11/layer/.formatted/dune
@@ -3,4 +3,5 @@
(public_name day11.layer)
(libraries day11_sys bos eio eio.unix fpath rresult yojson unix)
(modules_without_implementation)
- (preprocess (pps ppx_deriving_yojson)))
+ (preprocess
+ (pps ppx_deriving_yojson)))
File "day11/solver_pool/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/solver_pool/dune b/_build/default/day11/solver_pool/.formatted/dune
index a0603cc..0e4f2ea 100644
--- a/_build/default/day11/solver_pool/dune
+++ b/_build/default/day11/solver_pool/.formatted/dune
@@ -1,4 +1,13 @@
(library
(name day11_solver_pool)
(public_name day11.solver-pool)
- (libraries bos day11_solution day11_sys eio eio.unix logs opam-format unix yojson))
+ (libraries
+ bos
+ day11_solution
+ day11_sys
+ eio
+ eio.unix
+ logs
+ opam-format
+ unix
+ yojson))
File "day11/runner/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/runner/dune b/_build/default/day11/runner/.formatted/dune
index 477af5b..b1b6915 100644
--- a/_build/default/day11/runner/dune
+++ b/_build/default/day11/runner/.formatted/dune
@@ -1,5 +1,13 @@
(library
(name day11_runner)
(public_name day11.runner)
- (libraries day11_container day11_sys day11_layer
- bos eio fpath logs rresult unix))
+ (libraries
+ day11_container
+ day11_sys
+ day11_layer
+ bos
+ eio
+ fpath
+ logs
+ rresult
+ unix))
File "day11/opam_layer/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/dune b/_build/default/day11/opam_layer/.formatted/dune
index d03f95c..8657460 100644
--- a/_build/default/day11/opam_layer/dune
+++ b/_build/default/day11/opam_layer/.formatted/dune
@@ -1,6 +1,15 @@
(library
(name day11_opam_layer)
(public_name day11.opam-layer)
- (libraries day11_layer day11_sys day11_solution
- bos fpath opam-format rresult yojson unix)
- (preprocess (pps ppx_deriving_yojson)))
+ (libraries
+ day11_layer
+ day11_sys
+ day11_solution
+ bos
+ fpath
+ opam-format
+ rresult
+ yojson
+ unix)
+ (preprocess
+ (pps ppx_deriving_yojson)))
File "day11/solution/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/test/dune b/_build/default/day11/solution/test/.formatted/dune
index 726ba03..67ab0dd 100644
--- a/_build/default/day11/solution/test/dune
+++ b/_build/default/day11/solution/test/.formatted/dune
@@ -1,3 +1,11 @@
(test
(name test_graph)
- (libraries day11_solution day11_test_util alcotest astring bos fpath opam-format yojson))
+ (libraries
+ day11_solution
+ day11_test_util
+ alcotest
+ astring
+ bos
+ fpath
+ opam-format
+ yojson))
File "day11/solver/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/dune b/_build/default/day11/solver/.formatted/dune
index 0fb8f56..fe015b6 100644
--- a/_build/default/day11/solver/dune
+++ b/_build/default/day11/solver/.formatted/dune
@@ -2,8 +2,15 @@
(name day11_solver)
(public_name day11.solver)
(modules :standard \ solver_worker)
- (libraries bos day11_solution day11_opam fmt fpath
- opam-0install opam-format rresult))
+ (libraries
+ bos
+ day11_solution
+ day11_opam
+ fmt
+ fpath
+ opam-0install
+ opam-format
+ rresult))
(executable
(name solver_worker)
File "day11/batch/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/test/dune b/_build/default/day11/batch/test/.formatted/dune
index b6114ec..e1408d6 100644
--- a/_build/default/day11/batch/test/dune
+++ b/_build/default/day11/batch/test/.formatted/dune
@@ -1,26 +1,66 @@
(test
(name test_batch)
- (libraries day11_batch day11_opam_build day11_solution day11_lib day11_test_util
- alcotest bos eio_main fpath opam-format unix))
+ (libraries
+ day11_batch
+ day11_opam_build
+ day11_solution
+ day11_lib
+ day11_test_util
+ alcotest
+ bos
+ eio_main
+ fpath
+ opam-format
+ unix))
(executable
(name test_batch_integration)
- (libraries day11_batch day11_opam_build day11_solution day11_layer day11_lib
- day11_solver day11_test_util git-unix
- alcotest bos eio_main fpath opam-format unix))
+ (libraries
+ day11_batch
+ day11_opam_build
+ day11_solution
+ day11_layer
+ day11_lib
+ day11_solver
+ day11_test_util
+ git-unix
+ alcotest
+ bos
+ eio_main
+ fpath
+ opam-format
+ unix))
(executable
(name test_cmdliner_all)
- (libraries day11_batch day11_opam_build day11_solution day11_layer day11_lib
- day11_solver day11_test_util
- alcotest bos eio_main fpath opam-format unix))
+ (libraries
+ day11_batch
+ day11_opam_build
+ day11_solution
+ day11_layer
+ day11_lib
+ day11_solver
+ day11_test_util
+ alcotest
+ bos
+ eio_main
+ fpath
+ opam-format
+ unix))
(executable
(name test_incremental)
- (libraries day11_batch day11_solution day11_solver day11_test_util
- alcotest bos fpath opam-format unix))
+ (libraries
+ day11_batch
+ day11_solution
+ day11_solver
+ day11_test_util
+ alcotest
+ bos
+ fpath
+ opam-format
+ unix))
(executable
(name test_examined_diff)
- (libraries day11_solver day11_test_util
- bos fpath opam-format unix))
+ (libraries day11_solver day11_test_util bos fpath opam-format unix))
File "day11/benchmark/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/benchmark/dune b/_build/default/day11/benchmark/.formatted/dune
index b59a440..9cbd154 100644
--- a/_build/default/day11/benchmark/dune
+++ b/_build/default/day11/benchmark/.formatted/dune
@@ -1,7 +1,15 @@
(executable
(name benchmark)
- (libraries day11_batch day11_opam_build day11_solution day11_layer day11_solver
- eio_main fpath opam-format unix))
+ (libraries
+ day11_batch
+ day11_opam_build
+ day11_solution
+ day11_layer
+ day11_solver
+ eio_main
+ fpath
+ opam-format
+ unix))
(executable
(name benchmark_day10)
@@ -9,15 +17,48 @@
(executable
(name benchmark_builds)
- (libraries day11_batch day11_opam_build day11_sys day11_layer day11_solver
- bos eio_main fpath opam-format unix))
+ (libraries
+ day11_batch
+ day11_opam_build
+ day11_sys
+ day11_layer
+ day11_solver
+ bos
+ eio_main
+ fpath
+ opam-format
+ unix))
(executable
(name benchmark_docs)
- (libraries day11_opam_build day11_container day11_doc day11_sys day11_layer
- day11_solver bos eio_main fmt logs logs.fmt fpath opam-format unix))
+ (libraries
+ day11_opam_build
+ day11_container
+ day11_doc
+ day11_sys
+ day11_layer
+ day11_solver
+ bos
+ eio_main
+ fmt
+ logs
+ logs.fmt
+ fpath
+ opam-format
+ unix))
(executable
(name trial_run)
- (libraries day11_batch day11_opam_build day11_sys day11_layer day11_solver
- day11_solver_pool bos eio_main fpath git-unix opam-format unix))
+ (libraries
+ day11_batch
+ day11_opam_build
+ day11_sys
+ day11_layer
+ day11_solver
+ day11_solver_pool
+ bos
+ eio_main
+ fpath
+ git-unix
+ opam-format
+ unix))
File "day11/container/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/container/test/dune b/_build/default/day11/container/test/.formatted/dune
index 7650bc8..c0dd9d8 100644
--- a/_build/default/day11/container/test/dune
+++ b/_build/default/day11/container/test/.formatted/dune
@@ -4,10 +4,28 @@
(executable
(name test_integration)
- (libraries day11_container day11_layer day11_sys day11_test_util
- alcotest bos eio_main fpath yojson))
+ (libraries
+ day11_container
+ day11_layer
+ day11_sys
+ day11_test_util
+ alcotest
+ bos
+ eio_main
+ fpath
+ yojson))
(executable
(name test_build_package)
- (libraries day11_container day11_layer day11_opam_layer day11_sys day11_test_util
- alcotest astring bos eio_main fpath yojson))
+ (libraries
+ day11_container
+ day11_layer
+ day11_opam_layer
+ day11_sys
+ day11_test_util
+ alcotest
+ astring
+ bos
+ eio_main
+ fpath
+ yojson))
File "day11/solver/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/test/dune b/_build/default/day11/solver/test/.formatted/dune
index 9cd9eee..fb690ec 100644
--- a/_build/default/day11/solver/test/dune
+++ b/_build/default/day11/solver/test/.formatted/dune
@@ -1,6 +1,16 @@
(test
(name test_solver)
- (libraries day11_solver day11_doc day11_solution day11_test_util alcotest astring bos fpath opam-format yojson))
+ (libraries
+ day11_solver
+ day11_doc
+ day11_solution
+ day11_test_util
+ alcotest
+ astring
+ bos
+ fpath
+ opam-format
+ yojson))
(executable
(name test_doc_deps)
File "day11/solver_pool/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/solver_pool/test/dune b/_build/default/day11/solver_pool/test/.formatted/dune
index 72d6c04..7ff146e 100644
--- a/_build/default/day11/solver_pool/test/dune
+++ b/_build/default/day11/solver_pool/test/.formatted/dune
@@ -1,25 +1,66 @@
(test
(name test_solver_pool)
- (libraries alcotest bos day11_solver_pool day11_solution day11_test_util
- eio eio.unix eio_main fpath opam-format))
+ (libraries
+ alcotest
+ bos
+ day11_solver_pool
+ day11_solution
+ day11_test_util
+ eio
+ eio.unix
+ eio_main
+ fpath
+ opam-format))
(executable
(name test_driver_solve)
- (libraries bos day11_solver_pool day11_solution
- eio eio.unix eio_main fpath opam-format))
+ (libraries
+ bos
+ day11_solver_pool
+ day11_solution
+ eio
+ eio.unix
+ eio_main
+ fpath
+ opam-format))
(executable
(name test_ox_variants)
- (libraries bos day11_batch day11_opam_build day11_opam_layer
- day11_container day11_opam
- eio eio.unix eio_main fpath opam-format rresult))
+ (libraries
+ bos
+ day11_batch
+ day11_opam_build
+ day11_opam_layer
+ day11_container
+ day11_opam
+ eio
+ eio.unix
+ eio_main
+ fpath
+ opam-format
+ rresult))
(executable
(name test_who_wants_odoc_310)
- (libraries bos day11_solver_pool day11_solution day11_opam
- eio eio.unix eio_main fpath opam-format))
+ (libraries
+ bos
+ day11_solver_pool
+ day11_solution
+ day11_opam
+ eio
+ eio.unix
+ eio_main
+ fpath
+ opam-format))
(executable
(name test_why_not_odoc_320)
- (libraries bos day11_solver_pool day11_solution
- eio eio.unix eio_main fpath opam-format))
+ (libraries
+ bos
+ day11_solver_pool
+ day11_solution
+ eio
+ eio.unix
+ eio_main
+ fpath
+ opam-format))
File "day11/opam_build/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/dune b/_build/default/day11/opam_build/.formatted/dune
index 1569660..94b338e 100644
--- a/_build/default/day11/opam_build/dune
+++ b/_build/default/day11/opam_build/.formatted/dune
@@ -1,7 +1,20 @@
(library
(name day11_opam_build)
(public_name day11.opam-build)
- (libraries day11_container day11_sys day11_solution
- day11_layer day11_opam day11_opam_layer day11_runner
- day11_solver_pool
- bos dockerfile eio fpath opam-format rresult yojson unix))
+ (libraries
+ day11_container
+ day11_sys
+ day11_solution
+ day11_layer
+ day11_opam
+ day11_opam_layer
+ day11_runner
+ day11_solver_pool
+ bos
+ dockerfile
+ eio
+ fpath
+ opam-format
+ rresult
+ yojson
+ unix))
File "day11/opam_build/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/test/dune b/_build/default/day11/opam_build/test/.formatted/dune
index bbc3755..e7b68b9 100644
--- a/_build/default/day11/opam_build/test/dune
+++ b/_build/default/day11/opam_build/test/.formatted/dune
@@ -1,29 +1,81 @@
(test
(name test_build)
- (libraries day11_opam_build day11_solution day11_layer
- alcotest bos eio_main fpath opam-format yojson))
+ (libraries
+ day11_opam_build
+ day11_solution
+ day11_layer
+ alcotest
+ bos
+ eio_main
+ fpath
+ opam-format
+ yojson))
(executable
(name test_build_integration)
- (libraries day11_opam_build day11_layer day11_sys day11_test_util
- alcotest astring bos eio_main fpath opam-format))
+ (libraries
+ day11_opam_build
+ day11_layer
+ day11_sys
+ day11_test_util
+ alcotest
+ astring
+ bos
+ eio_main
+ fpath
+ opam-format))
(executable
(name test_layered_build)
- (libraries day11_opam_build day11_layer day11_test_util
- alcotest astring bos eio_main fpath opam-format))
+ (libraries
+ day11_opam_build
+ day11_layer
+ day11_test_util
+ alcotest
+ astring
+ bos
+ eio_main
+ fpath
+ opam-format))
(executable
(name test_from_scratch)
- (libraries day11_opam_build day11_solution day11_layer day11_solver day11_test_util
- alcotest bos eio_main fpath opam-format))
+ (libraries
+ day11_opam_build
+ day11_solution
+ day11_layer
+ day11_solver
+ day11_test_util
+ alcotest
+ bos
+ eio_main
+ fpath
+ opam-format))
(executable
(name test_tools)
- (libraries day11_opam_build day11_sys day11_layer day11_solver day11_test_util
- alcotest astring bos eio_main fpath opam-format))
+ (libraries
+ day11_opam_build
+ day11_sys
+ day11_layer
+ day11_solver
+ day11_test_util
+ alcotest
+ astring
+ bos
+ eio_main
+ fpath
+ opam-format))
(executable
(name test_tools_pinned)
- (libraries day11_opam_build day11_layer day11_solver day11_test_util
- alcotest bos eio_main fpath opam-format))
+ (libraries
+ day11_opam_build
+ day11_layer
+ day11_solver
+ day11_test_util
+ alcotest
+ bos
+ eio_main
+ fpath
+ opam-format))
File "day11/batch/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/dune b/_build/default/day11/batch/.formatted/dune
index a305208..4ad27bd 100644
--- a/_build/default/day11/batch/dune
+++ b/_build/default/day11/batch/.formatted/dune
@@ -1,5 +1,18 @@
(library
(name day11_batch)
(public_name day11.batch)
- (libraries bos day11_opam day11_opam_build day11_sys day11_solution day11_layer
- day11_lib day11_solver eio fpath opam-format rresult yojson unix))
+ (libraries
+ bos
+ day11_opam
+ day11_opam_build
+ day11_sys
+ day11_solution
+ day11_layer
+ day11_lib
+ day11_solver
+ eio
+ fpath
+ opam-format
+ rresult
+ yojson
+ unix))
File "day11/opam_build/test_noop/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/test_noop/dune b/_build/default/day11/opam_build/test_noop/.formatted/dune
index 6463604..5197580 100644
--- a/_build/default/day11/opam_build/test_noop/dune
+++ b/_build/default/day11/opam_build/test_noop/.formatted/dune
@@ -1,3 +1,10 @@
(executable
(name test_executor)
- (libraries day11_opam_build day11_layer eio eio_main opam-format yojson unix))
+ (libraries
+ day11_opam_build
+ day11_layer
+ eio
+ eio_main
+ opam-format
+ yojson
+ unix))
File "day11/opam_layer/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/test/dune b/_build/default/day11/opam_layer/test/.formatted/dune
index a6c0404..70f9952 100644
--- a/_build/default/day11/opam_layer/test/dune
+++ b/_build/default/day11/opam_layer/test/.formatted/dune
@@ -1,4 +1,12 @@
(test
(name test_opam_layer)
- (libraries day11_layer day11_opam_layer day11_test_util
- alcotest bos fpath opam-format str yojson))
+ (libraries
+ day11_layer
+ day11_opam_layer
+ day11_test_util
+ alcotest
+ bos
+ fpath
+ opam-format
+ str
+ yojson))
File "day11/lib/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/dune b/_build/default/day11/lib/.formatted/dune
index 0973664..c053d9c 100644
--- a/_build/default/day11/lib/dune
+++ b/_build/default/day11/lib/.formatted/dune
@@ -1,4 +1,15 @@
(library
(name day11_lib)
(public_name day11.lib)
- (libraries bos day11_layer day11_opam_layer eio fmt fpath logs rresult unix str yojson))
+ (libraries
+ bos
+ day11_layer
+ day11_opam_layer
+ eio
+ fmt
+ fpath
+ logs
+ rresult
+ unix
+ str
+ yojson))
File "day11/lib/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/test/dune b/_build/default/day11/lib/test/.formatted/dune
index cd57130..e882065 100644
--- a/_build/default/day11/lib/test/dune
+++ b/_build/default/day11/lib/test/.formatted/dune
@@ -1,4 +1,13 @@
(test
(name test_lib)
- (libraries day11_lib day11_test_util alcotest astring bos eio eio_main fpath
- opam-format yojson))
+ (libraries
+ day11_lib
+ day11_test_util
+ alcotest
+ astring
+ bos
+ eio
+ eio_main
+ fpath
+ opam-format
+ yojson))
File "day11/doc/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/dune b/_build/default/day11/doc/.formatted/dune
index b223b69..816ca3c 100644
--- a/_build/default/day11/doc/dune
+++ b/_build/default/day11/doc/.formatted/dune
@@ -1,7 +1,21 @@
(library
(name day11_doc)
(public_name day11.doc)
- (libraries astring day11_batch day11_opam_build day11_container
- day11_sys day11_solution day11_layer day11_lib day11_opam_layer
- bos fpath opam-format rresult yojson unix)
- (preprocess (pps ppx_deriving_yojson)))
+ (libraries
+ astring
+ day11_batch
+ day11_opam_build
+ day11_container
+ day11_sys
+ day11_solution
+ day11_layer
+ day11_lib
+ day11_opam_layer
+ bos
+ fpath
+ opam-format
+ rresult
+ yojson
+ unix)
+ (preprocess
+ (pps ppx_deriving_yojson)))
File "day11/jtw/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/dune b/_build/default/day11/jtw/.formatted/dune
index 8d4e03f..455803d 100644
--- a/_build/default/day11/jtw/dune
+++ b/_build/default/day11/jtw/.formatted/dune
@@ -1,5 +1,16 @@
(library
(name day11_jtw)
(public_name day11.jtw)
- (libraries day11_opam_build day11_container day11_doc day11_layer day11_solver
- bos fpath opam-format rresult str yojson unix))
+ (libraries
+ day11_opam_build
+ day11_container
+ day11_doc
+ day11_layer
+ day11_solver
+ bos
+ fpath
+ opam-format
+ rresult
+ str
+ yojson
+ unix))
File "day11/doc/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/test/dune b/_build/default/day11/doc/test/.formatted/dune
index 2a9c3ca..da7f153 100644
--- a/_build/default/day11/doc/test/dune
+++ b/_build/default/day11/doc/test/.formatted/dune
@@ -4,24 +4,70 @@
(executable
(name test_doc_integration)
- (libraries day11_opam_build day11_container day11_doc day11_sys day11_solution
- day11_layer day11_solver day11_test_util
- alcotest astring bos eio_main fpath opam-format yojson))
+ (libraries
+ day11_opam_build
+ day11_container
+ day11_doc
+ day11_sys
+ day11_solution
+ day11_layer
+ day11_solver
+ day11_test_util
+ alcotest
+ astring
+ bos
+ eio_main
+ fpath
+ opam-format
+ yojson))
(executable
(name test_generate_docs)
- (libraries day11_opam_build day11_container day11_doc day11_sys day11_layer
- day11_opam_layer day11_runner day11_solver day11_test_util
- alcotest astring bos eio_main fpath opam-format))
+ (libraries
+ day11_opam_build
+ day11_container
+ day11_doc
+ day11_sys
+ day11_layer
+ day11_opam_layer
+ day11_runner
+ day11_solver
+ day11_test_util
+ alcotest
+ astring
+ bos
+ eio_main
+ fpath
+ opam-format))
(executable
(name test_doc_compile_link)
- (libraries day11_opam_build day11_container day11_doc day11_sys day11_layer
- day11_solver day11_test_util
- alcotest bos eio_main fpath opam-format))
+ (libraries
+ day11_opam_build
+ day11_container
+ day11_doc
+ day11_sys
+ day11_layer
+ day11_solver
+ day11_test_util
+ alcotest
+ bos
+ eio_main
+ fpath
+ opam-format))
(executable
(name test_doc_pipeline)
- (libraries day11_opam_build day11_container day11_doc day11_sys day11_layer
- day11_solver day11_test_util
- alcotest bos eio_main fpath opam-format))
+ (libraries
+ day11_opam_build
+ day11_container
+ day11_doc
+ day11_sys
+ day11_layer
+ day11_solver
+ day11_test_util
+ alcotest
+ bos
+ eio_main
+ fpath
+ opam-format))
File "day11/jtw/test/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/test/dune b/_build/default/day11/jtw/test/.formatted/dune
index 456f64b..2d65eb6 100644
--- a/_build/default/day11/jtw/test/dune
+++ b/_build/default/day11/jtw/test/.formatted/dune
@@ -1,8 +1,26 @@
(test
(name test_jtw)
- (libraries day11_jtw day11_test_util alcotest astring bos fpath opam-format yojson))
+ (libraries
+ day11_jtw
+ day11_test_util
+ alcotest
+ astring
+ bos
+ fpath
+ opam-format
+ yojson))
(executable
(name test_jtw_integration)
- (libraries day11_opam_build day11_jtw day11_layer day11_solver day11_test_util
- alcotest astring bos eio_main fpath opam-format))
+ (libraries
+ day11_opam_build
+ day11_jtw
+ day11_layer
+ day11_solver
+ day11_test_util
+ alcotest
+ astring
+ bos
+ eio_main
+ fpath
+ opam-format))
File "day11/bin/dune", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/dune b/_build/default/day11/bin/.formatted/dune
index 3712722..1322bd8 100644
--- a/_build/default/day11/bin/dune
+++ b/_build/default/day11/bin/.formatted/dune
@@ -2,6 +2,23 @@
(name main)
(public_name day11)
(package day11)
- (libraries day11_batch day11_opam_build day11_doc day11_sys day11_solution
- day11_jtw day11_layer day11_lib day11_solver day11_solver_pool
- bos cmdliner eio_main fpath git-unix logs logs.fmt opam-format unix))
+ (libraries
+ day11_batch
+ day11_opam_build
+ day11_doc
+ day11_sys
+ day11_solution
+ day11_jtw
+ day11_layer
+ day11_lib
+ day11_solver
+ day11_solver_pool
+ bos
+ cmdliner
+ eio_main
+ fpath
+ git-unix
+ logs
+ logs.fmt
+ opam-format
+ unix))
ocamlformat: ignoring "day11/doc-pages/ocurrent_sketch.ml" (syntax error)
File "day11/doc-pages/ocurrent_sketch.ml", line 176, characters 60-62:
176 | let dep_compiles = (* look up deps' compile layers *) in
^^
Error: Syntax error
-> required by _build/default/day11/doc-pages/.formatted/ocurrent_sketch.ml
-> required by alias day11/doc-pages/.formatted/fmt
-> required by alias day11/doc-pages/fmt
File "day11/doc/test/test_doc.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/test/test_doc.ml b/_build/default/day11/doc/test/.formatted/test_doc.ml
index 6df28cf..c30faa1 100644
--- a/_build/default/day11/doc/test/test_doc.ml
+++ b/_build/default/day11/doc/test/.formatted/test_doc.ml
@@ -10,12 +10,13 @@ let _is_ok msg r = ok_or_fail msg r |> ignore
(* ── Phase tests ─────────────────────────────────────────────────── *)
let test_phase_to_string () =
- Alcotest.(check string) "all"
- "all" (Phase.phase_to_string Phase.Doc_all);
- Alcotest.(check string) "compile-only"
- "compile-only" (Phase.phase_to_string Phase.Doc_compile_only);
- Alcotest.(check string) "link-and-gen"
- "link-and-gen" (Phase.phase_to_string Phase.Doc_link_only)
+ Alcotest.(check string) "all" "all" (Phase.phase_to_string Phase.Doc_all);
+ Alcotest.(check string)
+ "compile-only" "compile-only"
+ (Phase.phase_to_string Phase.Doc_compile_only);
+ Alcotest.(check string)
+ "link-and-gen" "link-and-gen"
+ (Phase.phase_to_string Phase.Doc_link_only)
let test_doc_result_roundtrip_success () =
let r = Phase.Doc_success { html_path = "/p/yojson/2.2.2"; blessed = true } in
@@ -50,18 +51,19 @@ let test_command_generation () =
let cmd =
Command.odoc_driver_voodoo
~pkg:(OpamPackage.of_string "yojson.2.2.2")
- ~universe:"abc123"
- ~blessed:true
- ~actions:"all"
+ ~universe:"abc123" ~blessed:true ~actions:"all"
~odoc_bin:"/home/opam/.opam/5.2/bin/odoc"
~odoc_md_bin:"/home/opam/.opam/5.2/bin/odoc-md"
in
- Alcotest.(check bool) "contains yojson"
- true (Astring.String.is_infix ~affix:"yojson" cmd);
- Alcotest.(check bool) "contains all"
- true (Astring.String.is_infix ~affix:"all" cmd);
- Alcotest.(check bool) "contains odoc path"
- true (Astring.String.is_infix ~affix:"/home/opam/.opam/5.2/bin/odoc" cmd)
+ Alcotest.(check bool)
+ "contains yojson" true
+ (Astring.String.is_infix ~affix:"yojson" cmd);
+ Alcotest.(check bool)
+ "contains all" true
+ (Astring.String.is_infix ~affix:"all" cmd);
+ Alcotest.(check bool)
+ "contains odoc path" true
+ (Astring.String.is_infix ~affix:"/home/opam/.opam/5.2/bin/odoc" cmd)
let test_universe_hash_deterministic () =
let h1 = Command.compute_universe_hash [ "aaa"; "bbb"; "ccc" ] in
@@ -76,145 +78,172 @@ let test_universe_hash_different () =
(* ── Tool_layer tests ────────────────────────────────────────────── *)
let test_driver_hash_deterministic () =
- let h1 = Tool_layer.driver_layer_hash
- ~base_hash:"base1" ~compiler_hashes:[ "c1"; "c2" ] in
- let h2 = Tool_layer.driver_layer_hash
- ~base_hash:"base1" ~compiler_hashes:[ "c1"; "c2" ] in
+ let h1 =
+ Tool_layer.driver_layer_hash ~base_hash:"base1"
+ ~compiler_hashes:[ "c1"; "c2" ]
+ in
+ let h2 =
+ Tool_layer.driver_layer_hash ~base_hash:"base1"
+ ~compiler_hashes:[ "c1"; "c2" ]
+ in
Alcotest.(check string) "deterministic" h1 h2
let test_driver_hash_varies () =
- let h1 = Tool_layer.driver_layer_hash
- ~base_hash:"base1" ~compiler_hashes:[ "c1" ] in
- let h2 = Tool_layer.driver_layer_hash
- ~base_hash:"base1" ~compiler_hashes:[ "c2" ] in
+ let h1 =
+ Tool_layer.driver_layer_hash ~base_hash:"base1" ~compiler_hashes:[ "c1" ]
+ in
+ let h2 =
+ Tool_layer.driver_layer_hash ~base_hash:"base1" ~compiler_hashes:[ "c2" ]
+ in
Alcotest.(check bool) "different" true (h1 <> h2)
let test_driver_layer_name () =
- let name = Tool_layer.driver_layer_name
- ~base_hash:"base1" ~compiler_hashes:[ "c1" ] in
- Alcotest.(check bool) "starts with doc-driver-"
- true (Astring.String.is_prefix ~affix:"doc-driver-" name)
+ let name =
+ Tool_layer.driver_layer_name ~base_hash:"base1" ~compiler_hashes:[ "c1" ]
+ in
+ Alcotest.(check bool)
+ "starts with doc-driver-" true
+ (Astring.String.is_prefix ~affix:"doc-driver-" name)
-let test_driver_exists_empty () = with_eio @@ fun ~sw:_ env ->
+let test_driver_exists_empty () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
- Alcotest.(check bool) "not exists"
- false (Tool_layer.driver_exists env ~layer_dir:dir)
+ Alcotest.(check bool)
+ "not exists" false
+ (Tool_layer.driver_exists env ~layer_dir:dir)
-let test_driver_exists_with_layer_json () = with_eio @@ fun ~sw:_ env ->
+let test_driver_exists_with_layer_json () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
write_file Fpath.(dir / "layer.json") "{}";
- Alcotest.(check bool) "exists"
- true (Tool_layer.driver_exists env ~layer_dir:dir)
+ Alcotest.(check bool)
+ "exists" true
+ (Tool_layer.driver_exists env ~layer_dir:dir)
let test_driver_build_script () =
- let script = Tool_layer.driver_build_script
- ~packages:[ "odoc"; "odoc-driver" ]
- ~pin_commands:[] in
- Alcotest.(check bool) "contains opam install"
- true (Astring.String.is_infix ~affix:"opam install" script);
- Alcotest.(check bool) "contains odoc"
- true (Astring.String.is_infix ~affix:"odoc" script)
+ let script =
+ Tool_layer.driver_build_script ~packages:[ "odoc"; "odoc-driver" ]
+ ~pin_commands:[]
+ in
+ Alcotest.(check bool)
+ "contains opam install" true
+ (Astring.String.is_infix ~affix:"opam install" script);
+ Alcotest.(check bool)
+ "contains odoc" true
+ (Astring.String.is_infix ~affix:"odoc" script)
let test_odoc_hash_varies_by_version () =
- let h1 = Tool_layer.odoc_layer_hash
- ~base_hash:"b" ~ocaml_version:"5.1.0" ~compiler_hashes:[] in
- let h2 = Tool_layer.odoc_layer_hash
- ~base_hash:"b" ~ocaml_version:"5.2.0" ~compiler_hashes:[] in
+ let h1 =
+ Tool_layer.odoc_layer_hash ~base_hash:"b" ~ocaml_version:"5.1.0"
+ ~compiler_hashes:[]
+ in
+ let h2 =
+ Tool_layer.odoc_layer_hash ~base_hash:"b" ~ocaml_version:"5.2.0"
+ ~compiler_hashes:[]
+ in
Alcotest.(check bool) "different versions" true (h1 <> h2)
let test_odoc_layer_name () =
- let name = Tool_layer.odoc_layer_name
- ~base_hash:"b" ~ocaml_version:"5.2.0" ~compiler_hashes:[] in
- Alcotest.(check bool) "starts with doc-odoc-"
- true (Astring.String.is_prefix ~affix:"doc-odoc-" name)
+ let name =
+ Tool_layer.odoc_layer_name ~base_hash:"b" ~ocaml_version:"5.2.0"
+ ~compiler_hashes:[]
+ in
+ Alcotest.(check bool)
+ "starts with doc-odoc-" true
+ (Astring.String.is_prefix ~affix:"doc-odoc-" name)
(* ── Prep tests ──────────────────────────────────────────────────── *)
-let test_prep_create () = with_tmp_dir @@ fun dir ->
+let test_prep_create () =
+ with_tmp_dir @@ fun dir ->
let source = Fpath.(dir / "build-layer") in
let dest = Fpath.(dir / "doc-layer") in
(* Create a mock build layer with some .cmti files *)
- let lib_dir = Fpath.(source / "fs" / "home" / "opam" / ".opam" / "5.2" / "lib" / "astring") in
+ let lib_dir =
+ Fpath.(
+ source / "fs" / "home" / "opam" / ".opam" / "5.2" / "lib" / "astring")
+ in
mkdir lib_dir;
write_file Fpath.(lib_dir / "astring.cmti") "cmti content";
write_file Fpath.(lib_dir / "astring.cmt") "cmt content";
write_file Fpath.(lib_dir / "META") "meta content";
let prep_root, _mounts =
- Prep.create_with_mounts
- ~source_layer_dir:source
- ~dest_layer_dir:dest
+ Prep.create_with_mounts ~source_layer_dir:source ~dest_layer_dir:dest
~universe:"abc123"
~pkg:(OpamPackage.of_string "astring.0.8.5")
- ~installed_libs:[ "astring/astring.cmti"; "astring/astring.cmt"; "astring/META" ]
+ ~installed_libs:
+ [ "astring/astring.cmti"; "astring/astring.cmt"; "astring/META" ]
~installed_docs:[]
|> ok_or_fail "prep"
in
- Alcotest.(check bool) "prep dir exists"
- true (Bos.OS.Dir.exists prep_root |> Result.get_ok)
+ Alcotest.(check bool)
+ "prep dir exists" true
+ (Bos.OS.Dir.exists prep_root |> Result.get_ok)
-let test_prep_empty_libs () = with_tmp_dir @@ fun dir ->
+let test_prep_empty_libs () =
+ with_tmp_dir @@ fun dir ->
let source = Fpath.(dir / "build-layer") in
let dest = Fpath.(dir / "doc-layer") in
mkdir Fpath.(source / "fs");
let prep_root, _mounts =
- Prep.create_with_mounts
- ~source_layer_dir:source
- ~dest_layer_dir:dest
+ Prep.create_with_mounts ~source_layer_dir:source ~dest_layer_dir:dest
~universe:"abc123"
~pkg:(OpamPackage.of_string "binary-pkg.1.0")
- ~installed_libs:[]
- ~installed_docs:[]
+ ~installed_libs:[] ~installed_docs:[]
|> ok_or_fail "prep"
in
- Alcotest.(check bool) "prep dir exists (even if empty)"
- true (Bos.OS.Dir.exists prep_root |> Result.get_ok)
+ Alcotest.(check bool)
+ "prep dir exists (even if empty)" true
+ (Bos.OS.Dir.exists prep_root |> Result.get_ok)
(* ── Combine tests ───────────────────────────────────────────────── *)
-let test_scan_cache_empty () = with_eio @@ fun ~sw:_ env ->
+let test_scan_cache_empty () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let layers = Combine.scan_cache env ~os_dir:dir in
Alcotest.(check int) "empty" 0 (List.length layers)
(* ── Sync tests ──────────────────────────────────────────────────── *)
-let test_sync_scan_cache_empty () = with_eio @@ fun ~sw:_ env ->
+let test_sync_scan_cache_empty () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let entries = Sync.scan_cache env ~os_dir:dir in
Alcotest.(check int) "empty" 0 (List.length entries)
(* ── Universe tests ──────────────────────────────────────────────── *)
-let test_universe_manifest_roundtrip () = with_tmp_dir @@ fun dir ->
+let test_universe_manifest_roundtrip () =
+ with_tmp_dir @@ fun dir ->
let path = Fpath.(dir / "universes" / "abc123.json") in
mkdir Fpath.(dir / "universes");
- Universe.save_manifest path
- ~universe_hash:"abc123"
+ Universe.save_manifest path ~universe_hash:"abc123"
~packages:[ "astring.0.8.5"; "fmt.0.9.0" ]
|> ok_or_fail "save_manifest";
- let (hash, pkgs) =
- Universe.load_manifest path |> ok_or_fail "load_manifest" in
+ let hash, pkgs = Universe.load_manifest path |> ok_or_fail "load_manifest" in
Alcotest.(check string) "hash" "abc123" hash;
- Alcotest.(check (list string)) "packages"
- [ "astring.0.8.5"; "fmt.0.9.0" ] pkgs
+ Alcotest.(check (list string))
+ "packages"
+ [ "astring.0.8.5"; "fmt.0.9.0" ]
+ pkgs
-let test_universe_package_refs_roundtrip () = with_tmp_dir @@ fun dir ->
+let test_universe_package_refs_roundtrip () =
+ with_tmp_dir @@ fun dir ->
(* Set up html/p/astring/0.8.5/ directory *)
let pkg_html_dir = Fpath.(dir / "html" / "p" / "astring" / "0.8.5") in
mkdir pkg_html_dir;
- Universe.write_package_refs
- ~pkg_html_dir
+ Universe.write_package_refs ~pkg_html_dir
~universe_hashes:[ "abc123"; "def456" ]
|> ok_or_fail "write_package_refs";
(* collect_referenced scans html/p/*/... for universes.json *)
let html_dir = Fpath.(dir / "html") in
let referenced = Universe.collect_referenced ~html_dir in
- Alcotest.(check bool) "has abc123"
- true (List.mem "abc123" referenced);
- Alcotest.(check bool) "has def456"
- true (List.mem "def456" referenced)
+ Alcotest.(check bool) "has abc123" true (List.mem "abc123" referenced);
+ Alcotest.(check bool) "has def456" true (List.mem "def456" referenced)
-let test_universe_gc () = with_tmp_dir @@ fun dir ->
+let test_universe_gc () =
+ with_tmp_dir @@ fun dir ->
let html_dir = Fpath.(dir / "html") in
(* Create universe dirs under html/u/ *)
mkdir Fpath.(html_dir / "u" / "referenced");
@@ -222,19 +251,17 @@ let test_universe_gc () = with_tmp_dir @@ fun dir ->
(* Create a package that references "referenced" but not "orphaned" *)
let pkg_html_dir = Fpath.(html_dir / "p" / "pkg" / "1.0") in
mkdir pkg_html_dir;
- Universe.write_package_refs
- ~pkg_html_dir
- ~universe_hashes:[ "referenced" ]
+ Universe.write_package_refs ~pkg_html_dir ~universe_hashes:[ "referenced" ]
|> ok_or_fail "write_package_refs";
let deleted = Universe.gc ~html_dir in
(* "orphaned" should be deleted, "referenced" kept *)
Alcotest.(check bool) "deleted at least one" true (deleted >= 1);
- Alcotest.(check bool) "referenced still exists"
- true (Bos.OS.Dir.exists Fpath.(html_dir / "u" / "referenced")
- |> Result.get_ok);
- Alcotest.(check bool) "orphaned removed"
- false (Bos.OS.Dir.exists Fpath.(html_dir / "u" / "orphaned")
- |> Result.get_ok)
+ Alcotest.(check bool)
+ "referenced still exists" true
+ (Bos.OS.Dir.exists Fpath.(html_dir / "u" / "referenced") |> Result.get_ok);
+ Alcotest.(check bool)
+ "orphaned removed" false
+ (Bos.OS.Dir.exists Fpath.(html_dir / "u" / "orphaned") |> Result.get_ok)
(* ── Generate tests ──────────────────────────────────────────────── *)
@@ -243,13 +270,16 @@ let pkg s = OpamPackage.of_string s
let test_find_compiler_base () =
let solution =
OpamPackage.Map.empty
- |> OpamPackage.Map.add (pkg "ocaml-base-compiler.5.4.1") OpamPackage.Set.empty
+ |> OpamPackage.Map.add
+ (pkg "ocaml-base-compiler.5.4.1")
+ OpamPackage.Set.empty
|> OpamPackage.Map.add (pkg "ocaml.5.4.1") OpamPackage.Set.empty
|> OpamPackage.Map.add (pkg "dune.3.21.1") OpamPackage.Set.empty
in
match Generate.find_compiler solution with
- | Some c -> Alcotest.(check string) "found" "ocaml-base-compiler.5.4.1"
- (OpamPackage.to_string c)
+ | Some c ->
+ Alcotest.(check string)
+ "found" "ocaml-base-compiler.5.4.1" (OpamPackage.to_string c)
| None -> Alcotest.fail "expected compiler"
let test_find_compiler_variants () =
@@ -259,8 +289,9 @@ let test_find_compiler_variants () =
|> OpamPackage.Map.add (pkg "ocaml.5.2.0") OpamPackage.Set.empty
in
match Generate.find_compiler solution with
- | Some c -> Alcotest.(check string) "found" "ocaml-variants.5.2.0+ox"
- (OpamPackage.to_string c)
+ | Some c ->
+ Alcotest.(check string)
+ "found" "ocaml-variants.5.2.0+ox" (OpamPackage.to_string c)
| None -> Alcotest.fail "expected compiler"
let test_find_compiler_none () =
@@ -268,42 +299,57 @@ let test_find_compiler_none () =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "dune.3.21.1") OpamPackage.Set.empty
in
- Alcotest.(check bool) "none" true
- (Generate.find_compiler solution = None)
+ Alcotest.(check bool) "none" true (Generate.find_compiler solution = None)
let make_solve_result solution =
- { Day11_solution.Solve_result.
- packages = OpamPackage.Map.fold (fun p _ acc -> OpamPackage.Set.add p acc)
- solution OpamPackage.Set.empty;
+ {
+ Day11_solution.Solve_result.packages =
+ OpamPackage.Map.fold
+ (fun p _ acc -> OpamPackage.Set.add p acc)
+ solution OpamPackage.Set.empty;
build_deps = solution;
doc_deps = solution;
- examined = OpamPackage.Name.Set.empty }
+ examined = OpamPackage.Name.Set.empty;
+ }
let test_unique_compilers () =
let sol1 =
OpamPackage.Map.empty
- |> OpamPackage.Map.add (pkg "ocaml-base-compiler.5.4.1") OpamPackage.Set.empty
+ |> OpamPackage.Map.add
+ (pkg "ocaml-base-compiler.5.4.1")
+ OpamPackage.Set.empty
|> OpamPackage.Map.add (pkg "astring.0.8.5") OpamPackage.Set.empty
in
let sol2 =
OpamPackage.Map.empty
- |> OpamPackage.Map.add (pkg "ocaml-base-compiler.4.14.2") OpamPackage.Set.empty
+ |> OpamPackage.Map.add
+ (pkg "ocaml-base-compiler.4.14.2")
+ OpamPackage.Set.empty
|> OpamPackage.Map.add (pkg "dune.3.21.1") OpamPackage.Set.empty
in
let sol3 =
OpamPackage.Map.empty
- |> OpamPackage.Map.add (pkg "ocaml-base-compiler.5.4.1") OpamPackage.Set.empty
+ |> OpamPackage.Map.add
+ (pkg "ocaml-base-compiler.5.4.1")
+ OpamPackage.Set.empty
|> OpamPackage.Map.add (pkg "fmt.0.11.0") OpamPackage.Set.empty
in
- let compilers = Generate.unique_compilers
- [ (pkg "astring.0.8.5", make_solve_result sol1);
- (pkg "distributed.0.6.0", make_solve_result sol2);
- (pkg "fmt.0.11.0", make_solve_result sol3) ] in
+ let compilers =
+ Generate.unique_compilers
+ [
+ (pkg "astring.0.8.5", make_solve_result sol1);
+ (pkg "distributed.0.6.0", make_solve_result sol2);
+ (pkg "fmt.0.11.0", make_solve_result sol3);
+ ]
+ in
Alcotest.(check int) "two unique" 2 (List.length compilers);
- let strs = List.map OpamPackage.to_string compilers
- |> List.sort String.compare in
- Alcotest.(check (list string)) "versions"
- [ "ocaml-base-compiler.4.14.2"; "ocaml-base-compiler.5.4.1" ] strs
+ let strs =
+ List.map OpamPackage.to_string compilers |> List.sort String.compare
+ in
+ Alcotest.(check (list string))
+ "versions"
+ [ "ocaml-base-compiler.4.14.2"; "ocaml-base-compiler.5.4.1" ]
+ strs
let test_unique_compilers_empty () =
let compilers = Generate.unique_compilers [] in
@@ -313,93 +359,119 @@ let test_unique_compilers_empty () =
(* Helper: build a solution map from a list of (pkg, [dep; dep; ...]) *)
let make_solution entries =
- List.fold_left (fun acc (p, deps) ->
- OpamPackage.Map.add (pkg p)
- (OpamPackage.Set.of_list (List.map pkg deps)) acc
- ) OpamPackage.Map.empty entries
+ List.fold_left
+ (fun acc (p, deps) ->
+ OpamPackage.Map.add (pkg p)
+ (OpamPackage.Set.of_list (List.map pkg deps))
+ acc)
+ OpamPackage.Map.empty entries
let make_result ?(doc_deps = OpamPackage.Map.empty) build_deps =
- { Day11_solution.Solve_result.
- packages = OpamPackage.Map.fold (fun p _ acc ->
- OpamPackage.Set.add p acc) build_deps OpamPackage.Set.empty;
+ {
+ Day11_solution.Solve_result.packages =
+ OpamPackage.Map.fold
+ (fun p _ acc -> OpamPackage.Set.add p acc)
+ build_deps OpamPackage.Set.empty;
build_deps;
doc_deps;
- examined = OpamPackage.Name.Set.empty }
+ examined = OpamPackage.Name.Set.empty;
+ }
(* No {post} deps anywhere — compile and link graphs identical.
Every package can use --actions all. *)
let test_doc_deps_no_post () =
- let deps = make_solution [
- ("fmt.0.11.0", ["ocaml.5.4.1"; "dune.3.21.1"]);
- ("dune.3.21.1", ["ocaml.5.4.1"]);
- ("ocaml.5.4.1", []);
- ] in
+ let deps =
+ make_solution
+ [
+ ("fmt.0.11.0", [ "ocaml.5.4.1"; "dune.3.21.1" ]);
+ ("dune.3.21.1", [ "ocaml.5.4.1" ]);
+ ("ocaml.5.4.1", []);
+ ]
+ in
let result = make_result ~doc_deps:deps deps in
- Alcotest.(check bool) "fmt: single phase" false
+ Alcotest.(check bool)
+ "fmt: single phase" false
(Doc_deps.needs_separate_link result (pkg "fmt.0.11.0"));
- Alcotest.(check bool) "dune: single phase" false
+ Alcotest.(check bool)
+ "dune: single phase" false
(Doc_deps.needs_separate_link result (pkg "dune.3.21.1"))
(* Package has a {post} dep — link graph has an extra dep that the
compile graph doesn't. That package needs separate phases. *)
let test_doc_deps_with_post_dep () =
- let compile_deps = make_solution [
- ("odoc.3.1.0", ["ocaml.5.4.1"; "dune.3.21.1"]);
- ("dune.3.21.1", ["ocaml.5.4.1"]);
- ("ocaml.5.4.1", []);
- ] in
- let doc_deps = make_solution [
- ("odoc.3.1.0", ["ocaml.5.4.1"; "dune.3.21.1"; "odoc-parser.3.0.0"]);
- ("dune.3.21.1", ["ocaml.5.4.1"]);
- ("ocaml.5.4.1", []);
- ] in
+ let compile_deps =
+ make_solution
+ [
+ ("odoc.3.1.0", [ "ocaml.5.4.1"; "dune.3.21.1" ]);
+ ("dune.3.21.1", [ "ocaml.5.4.1" ]);
+ ("ocaml.5.4.1", []);
+ ]
+ in
+ let doc_deps =
+ make_solution
+ [
+ ("odoc.3.1.0", [ "ocaml.5.4.1"; "dune.3.21.1"; "odoc-parser.3.0.0" ]);
+ ("dune.3.21.1", [ "ocaml.5.4.1" ]);
+ ("ocaml.5.4.1", []);
+ ]
+ in
let result = make_result ~doc_deps compile_deps in
- Alcotest.(check bool) "odoc: needs separate" true
+ Alcotest.(check bool)
+ "odoc: needs separate" true
(Doc_deps.needs_separate_link result (pkg "odoc.3.1.0"));
- Alcotest.(check bool) "dune: single phase" false
+ Alcotest.(check bool)
+ "dune: single phase" false
(Doc_deps.needs_separate_link result (pkg "dune.3.21.1"))
(* Package not in either graph — no deps to compare, single phase. *)
let test_doc_deps_absent_pkg () =
- let deps = make_solution [
- ("fmt.0.11.0", ["ocaml.5.4.1"]);
- ("ocaml.5.4.1", []);
- ] in
+ let deps =
+ make_solution [ ("fmt.0.11.0", [ "ocaml.5.4.1" ]); ("ocaml.5.4.1", []) ]
+ in
let result = make_result ~doc_deps:deps deps in
- Alcotest.(check bool) "absent: single phase" false
+ Alcotest.(check bool)
+ "absent: single phase" false
(Doc_deps.needs_separate_link result (pkg "unknown-pkg.1.0"))
(* Single package, no deps in either graph *)
let test_doc_deps_leaf () =
- let deps = make_solution [
- ("astring.0.8.5", []);
- ] in
+ let deps = make_solution [ ("astring.0.8.5", []) ] in
let result = make_result ~doc_deps:deps deps in
- Alcotest.(check bool) "leaf: single phase" false
+ Alcotest.(check bool)
+ "leaf: single phase" false
(Doc_deps.needs_separate_link result (pkg "astring.0.8.5"))
(* Multiple packages in a solution, only the one with {post} deps
needs separate phases — the others are unaffected. *)
let test_doc_deps_mixed () =
- let compile_deps = make_solution [
- ("yojson.2.2.2", ["ocaml.5.4.1"; "dune.3.21.1"]);
- ("ppx_yojson.1.3.0", ["ocaml.5.4.1"; "dune.3.21.1"; "yojson.2.2.2"]);
- ("dune.3.21.1", ["ocaml.5.4.1"]);
- ("ocaml.5.4.1", []);
- ] in
- let doc_deps = make_solution [
- ("yojson.2.2.2", ["ocaml.5.4.1"; "dune.3.21.1"]);
- ("ppx_yojson.1.3.0", ["ocaml.5.4.1"; "dune.3.21.1"; "yojson.2.2.2";
- "ppxlib.0.33.0"]);
- ("dune.3.21.1", ["ocaml.5.4.1"]);
- ("ocaml.5.4.1", []);
- ] in
+ let compile_deps =
+ make_solution
+ [
+ ("yojson.2.2.2", [ "ocaml.5.4.1"; "dune.3.21.1" ]);
+ ("ppx_yojson.1.3.0", [ "ocaml.5.4.1"; "dune.3.21.1"; "yojson.2.2.2" ]);
+ ("dune.3.21.1", [ "ocaml.5.4.1" ]);
+ ("ocaml.5.4.1", []);
+ ]
+ in
+ let doc_deps =
+ make_solution
+ [
+ ("yojson.2.2.2", [ "ocaml.5.4.1"; "dune.3.21.1" ]);
+ ( "ppx_yojson.1.3.0",
+ [ "ocaml.5.4.1"; "dune.3.21.1"; "yojson.2.2.2"; "ppxlib.0.33.0" ] );
+ ("dune.3.21.1", [ "ocaml.5.4.1" ]);
+ ("ocaml.5.4.1", []);
+ ]
+ in
let result = make_result ~doc_deps compile_deps in
- Alcotest.(check bool) "yojson: single phase" false
+ Alcotest.(check bool)
+ "yojson: single phase" false
(Doc_deps.needs_separate_link result (pkg "yojson.2.2.2"));
- Alcotest.(check bool) "ppx_yojson: needs separate" true
+ Alcotest.(check bool)
+ "ppx_yojson: needs separate" true
(Doc_deps.needs_separate_link result (pkg "ppx_yojson.1.3.0"));
- Alcotest.(check bool) "dune: single phase" false
+ Alcotest.(check bool)
+ "dune: single phase" false
(Doc_deps.needs_separate_link result (pkg "dune.3.21.1"))
(* ── Odoc_store tests ────────────────────────────────────────────── *)
@@ -412,36 +484,45 @@ let test_rel_path_blessed () =
Alcotest.(check string) "blessed" "p/astring/0.8.5" (Fpath.to_string p)
let test_rel_path_non_blessed () =
- let p = Odoc_store.rel_path (loc ~blessed:false ~universe:"abc123" "astring.0.8.5") in
- Alcotest.(check string) "non-blessed" "u/abc123/astring/0.8.5" (Fpath.to_string p)
+ let p =
+ Odoc_store.rel_path (loc ~blessed:false ~universe:"abc123" "astring.0.8.5")
+ in
+ Alcotest.(check string)
+ "non-blessed" "u/abc123/astring/0.8.5" (Fpath.to_string p)
let test_container_html () =
- Alcotest.(check string) "container_html" "/home/opam/html"
- Odoc_store.container_html
+ Alcotest.(check string)
+ "container_html" "/home/opam/html" Odoc_store.container_html
(* ── Doc_meta tests ─────────────────────────────────────────────── *)
-let test_doc_meta_roundtrip () = with_tmp_dir @@ fun layer_dir ->
- let m : Doc_meta.t = {
- package = "fmt.0.9.0";
- phase = Doc_meta.Doc_all;
- deps = [ "ocaml.5.4.1"; "fmt.0.9.0" ];
- } in
+let test_doc_meta_roundtrip () =
+ with_tmp_dir @@ fun layer_dir ->
+ let m : Doc_meta.t =
+ {
+ package = "fmt.0.9.0";
+ phase = Doc_meta.Doc_all;
+ deps = [ "ocaml.5.4.1"; "fmt.0.9.0" ];
+ }
+ in
Doc_meta.save layer_dir m |> _is_ok "save";
Alcotest.(check bool) "exists" true (Doc_meta.exists layer_dir);
let loaded = Doc_meta.load layer_dir |> ok_or_fail "load" in
Alcotest.(check string) "package" "fmt.0.9.0" loaded.package;
Alcotest.(check bool) "phase doc-all" true (loaded.phase = Doc_meta.Doc_all)
-let test_doc_meta_phases () = with_tmp_dir @@ fun layer_dir ->
- List.iter (fun phase ->
- let m : Doc_meta.t = { package = "x.1"; phase; deps = [] } in
- Doc_meta.save layer_dir m |> _is_ok "save";
- let loaded = Doc_meta.load layer_dir |> ok_or_fail "load" in
- Alcotest.(check bool) "phase round-trip" true (loaded.phase = phase)
- ) [ Doc_meta.Compile; Doc_meta.Link; Doc_meta.Doc_all ]
-
-let test_doc_meta_missing () = with_tmp_dir @@ fun layer_dir ->
+let test_doc_meta_phases () =
+ with_tmp_dir @@ fun layer_dir ->
+ List.iter
+ (fun phase ->
+ let m : Doc_meta.t = { package = "x.1"; phase; deps = [] } in
+ Doc_meta.save layer_dir m |> _is_ok "save";
+ let loaded = Doc_meta.load layer_dir |> ok_or_fail "load" in
+ Alcotest.(check bool) "phase round-trip" true (loaded.phase = phase))
+ [ Doc_meta.Compile; Doc_meta.Link; Doc_meta.Doc_all ]
+
+let test_doc_meta_missing () =
+ with_tmp_dir @@ fun layer_dir ->
Alcotest.(check bool) "exists false" false (Doc_meta.exists layer_dir);
match Doc_meta.load layer_dir with
| Ok _ -> Alcotest.fail "should not load missing"
@@ -474,10 +555,8 @@ let () =
[
Alcotest.test_case "driver hash deterministic" `Quick
test_driver_hash_deterministic;
- Alcotest.test_case "driver hash varies" `Quick
- test_driver_hash_varies;
- Alcotest.test_case "driver layer name" `Quick
- test_driver_layer_name;
+ Alcotest.test_case "driver hash varies" `Quick test_driver_hash_varies;
+ Alcotest.test_case "driver layer name" `Quick test_driver_layer_name;
Alcotest.test_case "driver exists empty" `Quick
test_driver_exists_empty;
Alcotest.test_case "driver exists with json" `Quick
@@ -486,8 +565,7 @@ let () =
test_driver_build_script;
Alcotest.test_case "odoc hash varies by version" `Quick
test_odoc_hash_varies_by_version;
- Alcotest.test_case "odoc layer name" `Quick
- test_odoc_layer_name;
+ Alcotest.test_case "odoc layer name" `Quick test_odoc_layer_name;
] );
( "Prep",
[
@@ -495,9 +573,8 @@ let () =
Alcotest.test_case "empty libs" `Quick test_prep_empty_libs;
] );
( "Combine",
- [
- Alcotest.test_case "scan empty cache" `Quick test_scan_cache_empty;
- ] );
+ [ Alcotest.test_case "scan empty cache" `Quick test_scan_cache_empty ]
+ );
( "Sync",
[
Alcotest.test_case "scan empty cache" `Quick
@@ -509,19 +586,15 @@ let () =
test_universe_manifest_roundtrip;
Alcotest.test_case "package refs roundtrip" `Quick
test_universe_package_refs_roundtrip;
- Alcotest.test_case "gc removes unreferenced" `Quick
- test_universe_gc;
+ Alcotest.test_case "gc removes unreferenced" `Quick test_universe_gc;
] );
( "Generate",
[
- Alcotest.test_case "find_compiler base" `Quick
- test_find_compiler_base;
+ Alcotest.test_case "find_compiler base" `Quick test_find_compiler_base;
Alcotest.test_case "find_compiler variants" `Quick
test_find_compiler_variants;
- Alcotest.test_case "find_compiler none" `Quick
- test_find_compiler_none;
- Alcotest.test_case "unique_compilers" `Quick
- test_unique_compilers;
+ Alcotest.test_case "find_compiler none" `Quick test_find_compiler_none;
+ Alcotest.test_case "unique_compilers" `Quick test_unique_compilers;
Alcotest.test_case "unique_compilers empty" `Quick
test_unique_compilers_empty;
] );
@@ -536,7 +609,8 @@ let () =
( "Odoc_store",
[
Alcotest.test_case "rel_path blessed" `Quick test_rel_path_blessed;
- Alcotest.test_case "rel_path non-blessed" `Quick test_rel_path_non_blessed;
+ Alcotest.test_case "rel_path non-blessed" `Quick
+ test_rel_path_non_blessed;
Alcotest.test_case "container_html" `Quick test_container_html;
] );
( "Doc_meta",
File "day11/doc/test/test_doc_compile_link.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/test/test_doc_compile_link.ml b/_build/default/day11/doc/test/.formatted/test_doc_compile_link.ml
index e0e7f61..085102f 100644
--- a/_build/default/day11/doc/test/test_doc_compile_link.ml
+++ b/_build/default/day11/doc/test/.formatted/test_doc_compile_link.ml
@@ -10,7 +10,9 @@
open Day11_opam_build
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
+
type build = Build.t
+
open Day11_test_util.Test_util
let scratch_cache_dir = Fpath.v "/tmp/day11-scratch-cache"
@@ -18,39 +20,41 @@ let scratch_cache_dir = Fpath.v "/tmp/day11-scratch-cache"
(** Build docs for a package using bind-mounted tool binaries *)
let build_docs ~sw env benv ~os_dir ~odoc_tool ~pkg_build ~pkg =
let tool_mounts, odoc_bin, odoc_md_bin =
- Day11_doc.Tool_binaries.doc_tool_mounts odoc_tool in
+ Day11_doc.Tool_binaries.doc_tool_mounts odoc_tool
+ in
(* odoc_driver_voodoo is also bind-mounted *)
let voodoo_bin = "/home/opam/doc-tools/bin/odoc_driver_voodoo" in
let pkg_dir = Build.dir ~os_dir pkg_build in
- let installed_libs = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:pkg_dir in
- let installed_docs = Day11_opam_layer.Installed_files.scan_docs
- ~layer_dir:pkg_dir in
- let universe = Day11_doc.Command.compute_universe_hash
- (List.map (fun (b : build) -> b.hash) odoc_tool.builds) in
+ let installed_libs =
+ Day11_opam_layer.Installed_files.scan_libs ~layer_dir:pkg_dir
+ in
+ let installed_docs =
+ Day11_opam_layer.Installed_files.scan_docs ~layer_dir:pkg_dir
+ in
+ let universe =
+ Day11_doc.Command.compute_universe_hash
+ (List.map (fun (b : build) -> b.hash) odoc_tool.builds)
+ in
Printf.printf " prep: %d lib files, %d doc files\n%!"
- (List.length installed_libs) (List.length installed_docs);
+ (List.length installed_libs)
+ (List.length installed_docs);
let prep_dir = Bos.OS.Dir.tmp "day11_doctest_%s" |> Result.get_ok in
let _prep_root =
- Day11_doc.Prep.create_with_mounts
- ~source_layer_dir:pkg_dir ~dest_layer_dir:prep_dir
- ~universe ~pkg
- ~installed_libs ~installed_docs
+ Day11_doc.Prep.create_with_mounts ~source_layer_dir:pkg_dir
+ ~dest_layer_dir:prep_dir ~universe ~pkg ~installed_libs ~installed_docs
|> ok_or_fail "prep"
in
- let prep_mount = Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
- "/home/opam/prep" in
+ let prep_mount =
+ Day11_container.Mount.bind_ro
+ ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
+ "/home/opam/prep"
+ in
let all_mounts = prep_mount :: tool_mounts in
(* Use the bind-mounted voodoo binary directly *)
let make_cmd actions =
Printf.sprintf
- "eval $(opam env) && %s %s \
- --odoc-dir /home/opam/odoc-out \
- --html-dir /home/opam/html \
- --actions %s -j $(nproc) -v \
- --blessed \
- --odoc %s \
+ "eval $(opam env) && %s %s --odoc-dir /home/opam/odoc-out --html-dir \
+ /home/opam/html --actions %s -j $(nproc) -v --blessed --odoc %s \
--odoc-md %s"
voodoo_bin
(OpamPackage.name_to_string pkg)
@@ -58,80 +62,128 @@ let build_docs ~sw env benv ~os_dir ~odoc_tool ~pkg_build ~pkg =
in
(* Compile — only package's real deps, no tool layers *)
let compile_cmd = make_cmd "compile-only" in
- let compile_hash = Day11_layer.Hash.of_strings
- [ "compile"; pkg_build.hash; odoc_tool.hash ] in
+ let compile_hash =
+ Day11_layer.Hash.of_strings [ "compile"; pkg_build.hash; odoc_tool.hash ]
+ in
let compile_node : build =
- { hash = compile_hash; pkg;
- deps = pkg_build.deps @ [ pkg_build ]; universe = Day11_solution.Universe.dummy } in
- let compile_build = match
- Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:all_mounts
- compile_node ~strategy:{ cmd = compile_cmd; cleanup = fun ~sw:_ _ _ -> () } ()
- with
+ {
+ hash = compile_hash;
+ pkg;
+ deps = pkg_build.deps @ [ pkg_build ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ let compile_build =
+ match
+ Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:all_mounts
+ compile_node
+ ~strategy:{ cmd = compile_cmd; cleanup = (fun ~sw:_ _ _ -> ()) }
+ ()
+ with
| Types.Success bl ->
- let cd = Build.dir ~os_dir bl in
- let find_run = Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "find" % Fpath.to_string Fpath.(cd / "fs")
- % "-name" % "*.odoc" % "-type" % "f") None in
- let n = List.length (String.split_on_char '\n' (String.trim find_run.output)
- |> List.filter (fun s -> s <> "")) in
- Printf.printf " compile: %d .odoc files\n%!" n;
- bl
+ let cd = Build.dir ~os_dir bl in
+ let find_run =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(
+ v "find"
+ % Fpath.to_string Fpath.(cd / "fs")
+ % "-name"
+ % "*.odoc"
+ % "-type"
+ % "f")
+ None
+ in
+ let n =
+ List.length
+ (String.split_on_char '\n' (String.trim find_run.output)
+ |> List.filter (fun s -> s <> ""))
+ in
+ Printf.printf " compile: %d .odoc files\n%!" n;
+ bl
| Types.Failure name ->
- let log = Fpath.(Build.dir ~os_dir compile_node / "layer.log") in
- (match Bos.OS.File.read log with
- | Ok s -> Printf.printf "COMPILE LOG:\n%s\n%!" s | Error _ -> ());
- Alcotest.fail ("compile failed: " ^ name)
+ let log = Fpath.(Build.dir ~os_dir compile_node / "layer.log") in
+ (match Bos.OS.File.read log with
+ | Ok s -> Printf.printf "COMPILE LOG:\n%s\n%!" s
+ | Error _ -> ());
+ Alcotest.fail ("compile failed: " ^ name)
| _ -> Alcotest.fail "compile unexpected"
in
(* Link — same package deps + compile layer, still no tool layers *)
let link_cmd = make_cmd "link-and-gen" in
- let link_hash = Day11_layer.Hash.of_strings
- [ "link"; compile_build.hash; universe ] in
+ let link_hash =
+ Day11_layer.Hash.of_strings [ "link"; compile_build.hash; universe ]
+ in
let link_node : build =
- { hash = link_hash; pkg;
- deps = pkg_build.deps @ [ pkg_build; compile_build ]; universe = Day11_solution.Universe.dummy } in
- let html_count = match
- Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:all_mounts
- link_node ~strategy:{ cmd = link_cmd; cleanup = fun ~sw:_ _ _ -> () } ()
- with
+ {
+ hash = link_hash;
+ pkg;
+ deps = pkg_build.deps @ [ pkg_build; compile_build ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ let html_count =
+ match
+ Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:all_mounts
+ link_node
+ ~strategy:{ cmd = link_cmd; cleanup = (fun ~sw:_ _ _ -> ()) }
+ ()
+ with
| Types.Success bl ->
- let ld = Build.dir ~os_dir bl in
- let find_run = Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "find" % Fpath.to_string Fpath.(ld / "fs")
- % "-name" % "*.html" % "-type" % "f") None in
- let files = String.split_on_char '\n' (String.trim find_run.output)
- |> List.filter (fun s -> s <> "") in
- Printf.printf " link: %d HTML files\n%!" (List.length files);
- List.length files
+ let ld = Build.dir ~os_dir bl in
+ let find_run =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(
+ v "find"
+ % Fpath.to_string Fpath.(ld / "fs")
+ % "-name"
+ % "*.html"
+ % "-type"
+ % "f")
+ None
+ in
+ let files =
+ String.split_on_char '\n' (String.trim find_run.output)
+ |> List.filter (fun s -> s <> "")
+ in
+ Printf.printf " link: %d HTML files\n%!" (List.length files);
+ List.length files
| Types.Failure name ->
- let log = Fpath.(Build.dir ~os_dir link_node / "layer.log") in
- (match Bos.OS.File.read log with
- | Ok s -> Printf.printf "LINK LOG:\n%s\n%!" s | Error _ -> ());
- Alcotest.fail ("link failed: " ^ name)
+ let log = Fpath.(Build.dir ~os_dir link_node / "layer.log") in
+ (match Bos.OS.File.read log with
+ | Ok s -> Printf.printf "LINK LOG:\n%s\n%!" s
+ | Error _ -> ());
+ Alcotest.fail ("link failed: " ^ name)
| _ -> Alcotest.fail "link unexpected"
in
ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir);
html_count
let setup () =
- let base = match Base.load_cached ~cache_dir:scratch_cache_dir
- ~os_distribution:"debian" ~os_version:"bookworm" with
+ let base =
+ match
+ Base.load_cached ~cache_dir:scratch_cache_dir ~os_distribution:"debian"
+ ~os_version:"bookworm"
+ with
| Some b -> b
- | None -> Printf.printf "No cache\n%!"; Alcotest.skip ()
+ | None ->
+ Printf.printf "No cache\n%!";
+ Alcotest.skip ()
in
let opam_repository = opam_repository () in
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
Types.ensure_dirs benv;
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
(base, os_dir, benv, git_packages, repos_with_shas, opam_env)
-let test_astring_docs () = with_eio @@ fun ~sw env ->
+let test_astring_docs () =
+ with_eio @@ fun ~sw env ->
let base, os_dir, benv, git_packages, repos_with_shas, opam_env = setup () in
Printf.printf "Building odoc-driver tools...\n%!";
let odoc_tool =
@@ -144,27 +196,42 @@ let test_astring_docs () = with_eio @@ fun ~sw env ->
let astring_pkg = OpamPackage.of_string "astring.0.8.5" in
let find_opam = Day11_opam.Git_packages.find_package git_packages in
let cache = Hash_cache.create ~find_opam () in
- let astring_solution = match Day11_solver.Solve.solve ~packages:git_packages
- ~env:opam_env astring_pkg with
+ let astring_solution =
+ match
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env astring_pkg
+ with
| Ok result -> result.Day11_solution.Solve_result.build_deps
- | Error (e, _) -> Alcotest.fail ("solve astring: " ^ e) in
- let astring_nodes = Dag.build_dag cache ~base_hash:base.hash
- [ (astring_pkg, astring_solution, astring_solution) ] in
+ | Error (e, _) -> Alcotest.fail ("solve astring: " ^ e)
+ in
+ let astring_nodes =
+ Dag.build_dag cache ~base_hash:base.hash
+ [ (astring_pkg, astring_solution, astring_solution) ]
+ in
Dag_executor.execute env ~np:4
~on_complete:(fun ~stats:_ ~cached:_ _ _ -> ())
~on_cascade:(fun ~failed:_ ~failed_dep:_ -> ())
astring_nodes
- (fun node -> match Build_layer.build ~sw env benv ~opam_repositories:[] node () with
- | Types.Success _ -> true | _ -> false);
- let astring_build = List.find (fun (n : build) ->
- OpamPackage.equal n.pkg astring_pkg) astring_nodes in
+ (fun node ->
+ match Build_layer.build ~sw env benv ~opam_repositories:[] node () with
+ | Types.Success _ -> true
+ | _ -> false);
+ let astring_build =
+ List.find
+ (fun (n : build) -> OpamPackage.equal n.pkg astring_pkg)
+ astring_nodes
+ in
Printf.printf "Generating astring docs (bind-mounted tools)...\n%!";
- let html = build_docs ~sw env benv ~os_dir ~odoc_tool
- ~pkg_build:astring_build ~pkg:astring_pkg in
+ let html =
+ build_docs ~sw env benv ~os_dir ~odoc_tool ~pkg_build:astring_build
+ ~pkg:astring_pkg
+ in
Alcotest.(check bool) "astring has HTML" true (html > 0)
-let test_odoc_docs () = with_eio @@ fun ~sw env ->
- let _base, os_dir, benv, git_packages, repos_with_shas, _opam_env = setup () in
+let test_odoc_docs () =
+ with_eio @@ fun ~sw env ->
+ let _base, os_dir, benv, git_packages, repos_with_shas, _opam_env =
+ setup ()
+ in
Printf.printf "Building odoc-driver tools...\n%!";
let odoc_tool =
Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas
@@ -173,15 +240,21 @@ let test_odoc_docs () = with_eio @@ fun ~sw env ->
in
Printf.printf " odoc-driver: %d layers\n%!" (List.length odoc_tool.builds);
let odoc_pkg = OpamPackage.of_string "odoc.3.1.0" in
- let odoc_build = match List.find_opt (fun (b : build) ->
- OpamPackage.equal b.pkg odoc_pkg) odoc_tool.builds with
+ let odoc_build =
+ match
+ List.find_opt
+ (fun (b : build) -> OpamPackage.equal b.pkg odoc_pkg)
+ odoc_tool.builds
+ with
| Some b -> b
| None -> Alcotest.fail "odoc not found in tool builds"
in
Printf.printf "Generating odoc docs (bind-mounted tools, %d real deps)...\n%!"
(List.length odoc_build.deps);
- let html = build_docs ~sw env benv ~os_dir ~odoc_tool
- ~pkg_build:odoc_build ~pkg:odoc_pkg in
+ let html =
+ build_docs ~sw env benv ~os_dir ~odoc_tool ~pkg_build:odoc_build
+ ~pkg:odoc_pkg
+ in
Printf.printf " odoc: %d HTML files\n%!" html;
Alcotest.(check bool) "odoc has HTML" true (html > 0)
@@ -190,6 +263,10 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_doc_compile_link"
- [ ( "Doc phases",
- [ Alcotest.test_case "astring docs" `Slow test_astring_docs;
- Alcotest.test_case "odoc docs" `Slow test_odoc_docs ] ) ]
+ [
+ ( "Doc phases",
+ [
+ Alcotest.test_case "astring docs" `Slow test_astring_docs;
+ Alcotest.test_case "odoc docs" `Slow test_odoc_docs;
+ ] );
+ ]
File "day11/doc/test/test_doc_integration.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/test/test_doc_integration.ml b/_build/default/day11/doc/test/.formatted/test_doc_integration.ml
index 249b6a8..8405d0b 100644
--- a/_build/default/day11/doc/test/test_doc_integration.ml
+++ b/_build/default/day11/doc/test/.formatted/test_doc_integration.ml
@@ -12,95 +12,122 @@ let os_dir = Fpath.(cache_dir / "linux-x86_64")
let packages_dir = Fpath.(os_dir / "packages")
let base_dir = Fpath.(cache_dir / "base")
let switch = "default"
+
let make_base () : Day11_layer.Base.t =
- { hash = Day11_opam_build.Base.build_hash ~os_distribution:"debian"
- ~os_version:"bookworm" ~arch:"x86_64" ();
+ {
+ hash =
+ Day11_opam_build.Base.build_hash ~os_distribution:"debian"
+ ~os_version:"bookworm" ~arch:"x86_64" ();
dir = base_dir;
- image = "debian:bookworm" }
+ image = "debian:bookworm";
+ }
(** Find a build layer for a package *)
let find_layer_for env pkg_str =
- let symlinks = Day11_layer.Scan.list_package_symlinks
- ~exclude:[] env packages_dir pkg_str in
- match List.find_opt (fun (name, _) ->
- Astring.String.is_prefix ~affix:"build-" name) symlinks with
+ let symlinks =
+ Day11_layer.Scan.list_package_symlinks ~exclude:[] env packages_dir pkg_str
+ in
+ match
+ List.find_opt
+ (fun (name, _) -> Astring.String.is_prefix ~affix:"build-" name)
+ symlinks
+ with
| Some (name, _) -> Some name
| None -> None
(* ── Prep test ───────────────────────────────────────────────────── *)
-let test_prep_from_real_layer () = with_eio @@ fun ~sw:_ env ->
- let astring_layer_name = match find_layer_for env "astring.0.8.5" with
+let test_prep_from_real_layer () =
+ with_eio @@ fun ~sw:_ env ->
+ let astring_layer_name =
+ match find_layer_for env "astring.0.8.5" with
| Some name -> name
| None -> Alcotest.skip ()
in
let astring_layer = Fpath.(os_dir / astring_layer_name) in
- let installed_libs = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:astring_layer in
- let installed_docs = Day11_opam_layer.Installed_files.scan_docs
- ~layer_dir:astring_layer in
+ let installed_libs =
+ Day11_opam_layer.Installed_files.scan_libs ~layer_dir:astring_layer
+ in
+ let installed_docs =
+ Day11_opam_layer.Installed_files.scan_docs ~layer_dir:astring_layer
+ in
let dest_dir = Bos.OS.Dir.tmp "day11_doc_prep_%s" |> Result.get_ok in
- Fun.protect ~finally:(fun () ->
- Bos.OS.Dir.delete ~recurse:true dest_dir |> ignore)
+ Fun.protect
+ ~finally:(fun () -> Bos.OS.Dir.delete ~recurse:true dest_dir |> ignore)
(fun () ->
let prep_root, _mounts =
- Prep.create_with_mounts
- ~source_layer_dir:astring_layer
- ~dest_layer_dir:dest_dir
- ~universe:"test-universe"
+ Prep.create_with_mounts ~source_layer_dir:astring_layer
+ ~dest_layer_dir:dest_dir ~universe:"test-universe"
~pkg:(OpamPackage.of_string "astring.0.8.5")
~installed_libs ~installed_docs
|> ok_or_fail "prep"
in
- let prep_lib = Fpath.(prep_root / "universes" / "test-universe"
- / "astring" / "0.8.5" / "lib") in
- Alcotest.(check bool) "prep dir exists" true
+ let prep_lib =
+ Fpath.(
+ prep_root
+ / "universes"
+ / "test-universe"
+ / "astring"
+ / "0.8.5"
+ / "lib")
+ in
+ Alcotest.(check bool)
+ "prep dir exists" true
(Bos.OS.Dir.exists prep_lib |> Result.get_ok))
let test_command_generation () =
- let cmd = Command.odoc_driver_voodoo
- ~pkg:(OpamPackage.of_string "astring.0.8.5")
- ~universe:"abc123" ~blessed:true
- ~actions:(Phase.phase_to_string Phase.Doc_all)
- ~odoc_bin:"/home/opam/.opam/default/bin/odoc"
- ~odoc_md_bin:"/home/opam/.opam/default/bin/odoc-md"
+ let cmd =
+ Command.odoc_driver_voodoo
+ ~pkg:(OpamPackage.of_string "astring.0.8.5")
+ ~universe:"abc123" ~blessed:true
+ ~actions:(Phase.phase_to_string Phase.Doc_all)
+ ~odoc_bin:"/home/opam/.opam/default/bin/odoc"
+ ~odoc_md_bin:"/home/opam/.opam/default/bin/odoc-md"
in
- Alcotest.(check bool) "has astring"
- true (Astring.String.is_infix ~affix:"astring" cmd)
+ Alcotest.(check bool)
+ "has astring" true
+ (Astring.String.is_infix ~affix:"astring" cmd)
(* ── Build odoc ──────────────────────────────────────────────────── *)
-let test_build_odoc () = with_eio @@ fun ~sw env ->
- if not (Bos.OS.Dir.exists base_dir |> Result.get_ok) then
- Alcotest.skip ();
+let test_build_odoc () =
+ with_eio @@ fun ~sw env ->
+ if not (Bos.OS.Dir.exists base_dir |> Result.get_ok) then Alcotest.skip ();
let opam_repository = opam_repository () in
let base = make_base () in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
let odoc_versions =
Day11_opam.Git_packages.get_versions git_packages
- (OpamPackage.Name.of_string "odoc") in
- let odoc_pkg = match OpamPackage.Version.Map.max_binding_opt odoc_versions with
- | Some (v, _) ->
- OpamPackage.create (OpamPackage.Name.of_string "odoc") v
+ (OpamPackage.Name.of_string "odoc")
+ in
+ let odoc_pkg =
+ match OpamPackage.Version.Map.max_binding_opt odoc_versions with
+ | Some (v, _) -> OpamPackage.create (OpamPackage.Name.of_string "odoc") v
| None -> Alcotest.skip ()
in
Printf.printf "Building %s...\n%!" (OpamPackage.to_string odoc_pkg);
let benv : Day11_opam_build.Types.build_env =
- { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None } in
+ { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None }
+ in
let tool =
- Day11_opam_build.Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas
- odoc_pkg
+ Day11_opam_build.Tools.build_tool ~sw env benv ~packages:git_packages
+ ~repos:repos_with_shas odoc_pkg
|> ok_or_fail "build_tool"
in
Printf.printf "odoc built: %d layers\n%!" (List.length tool.builds);
- let _ = Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "chmod" % "-R" % "a+rX"
- % Fpath.to_string Fpath.(tool.dir / "fs")) in
- let odoc_bin = Fpath.(tool.dir / "fs" / "home" / "opam" / ".opam"
- / switch / "bin" / "odoc") in
- Alcotest.(check bool) "odoc binary built" true
+ let _ =
+ Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "chmod" % "-R" % "a+rX" % Fpath.to_string Fpath.(tool.dir / "fs"))
+ in
+ let odoc_bin =
+ Fpath.(
+ tool.dir / "fs" / "home" / "opam" / ".opam" / switch / "bin" / "odoc")
+ in
+ Alcotest.(check bool)
+ "odoc binary built" true
(Bos.OS.File.exists odoc_bin |> Result.get_ok)
(* ── Registration ────────────────────────────────────────────────── *)
@@ -110,11 +137,13 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_doc_integration"
- [ ( "Prep",
- [ Alcotest.test_case "from real layer" `Quick
- test_prep_from_real_layer ] );
+ [
+ ( "Prep",
+ [
+ Alcotest.test_case "from real layer" `Quick
+ test_prep_from_real_layer;
+ ] );
( "Command",
- [ Alcotest.test_case "generation" `Quick
- test_command_generation ] );
- ( "Doc_build",
- [ Alcotest.test_case "build odoc" `Slow test_build_odoc ] ) ]
+ [ Alcotest.test_case "generation" `Quick test_command_generation ] );
+ ("Doc_build", [ Alcotest.test_case "build odoc" `Slow test_build_odoc ]);
+ ]
File "day11/doc/test/test_doc_pipeline.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/test/test_doc_pipeline.ml b/_build/default/day11/doc/test/.formatted/test_doc_pipeline.ml
index 78ae018..b89b8c5 100644
--- a/_build/default/day11/doc/test/test_doc_pipeline.ml
+++ b/_build/default/day11/doc/test/.formatted/test_doc_pipeline.ml
@@ -10,24 +10,32 @@
open Day11_opam_build
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
+
type build = Build.t
+
open Day11_test_util.Test_util
let scratch_cache_dir = Fpath.v "/tmp/day11-scratch-cache"
-let test_full_doc_pipeline () = with_eio @@ fun ~sw env ->
- let base = match Base.load_cached ~cache_dir:scratch_cache_dir
- ~os_distribution:"debian" ~os_version:"bookworm" with
+let test_full_doc_pipeline () =
+ with_eio @@ fun ~sw env ->
+ let base =
+ match
+ Base.load_cached ~cache_dir:scratch_cache_dir ~os_distribution:"debian"
+ ~os_version:"bookworm"
+ with
| Some b -> b
- | None -> Printf.printf "No cache\n%!"; Alcotest.skip ()
+ | None ->
+ Printf.printf "No cache\n%!";
+ Alcotest.skip ()
in
let opam_repository = opam_repository () in
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
Types.ensure_dirs benv;
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
let switch = Types.switch in
let odoc_bin = Printf.sprintf "/home/opam/.opam/%s/bin/odoc" switch in
let odoc_md_bin = Printf.sprintf "/home/opam/.opam/%s/bin/odoc-md" switch in
@@ -43,157 +51,226 @@ let test_full_doc_pipeline () = with_eio @@ fun ~sw env ->
(* Step 2: All packages use compile+link split in unified DAG *)
let no_split = odoc_tool.builds in
let needs_split = [] in
- Printf.printf " %d packages for doc generation\n%!"
- (List.length no_split);
+ Printf.printf " %d packages for doc generation\n%!" (List.length no_split);
(* Step 3: Generate docs for non-split packages (--actions all) *)
- let universe = Day11_doc.Command.compute_universe_hash
- (List.map (fun (b : build) -> b.hash) odoc_tool.builds) in
+ let universe =
+ Day11_doc.Command.compute_universe_hash
+ (List.map (fun (b : build) -> b.hash) odoc_tool.builds)
+ in
let doc_all_count = ref 0 in
let doc_all_html = ref 0 in
Printf.printf "\nGenerating docs (single phase)...\n%!";
- List.iter (fun (b : build) ->
- let pkg_dir = Build.dir ~os_dir b in
- let installed_libs = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:pkg_dir in
- if installed_libs = [] then
- Printf.printf " %s: no libs, skipping\n%!"
- (OpamPackage.to_string b.pkg)
- else begin
- let installed_docs = Day11_opam_layer.Installed_files.scan_docs
- ~layer_dir:pkg_dir in
- let prep_dir = Bos.OS.Dir.tmp "day11_doc_%s" |> Result.get_ok in
- ignore (Day11_doc.Prep.create_with_mounts ~source_layer_dir:pkg_dir
- ~dest_layer_dir:prep_dir ~universe ~pkg:b.pkg
- ~installed_libs ~installed_docs);
- let prep_mount = Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
- "/home/opam/prep" in
- let cmd =
- "eval $(opam env) && " ^
- Day11_doc.Command.odoc_driver_voodoo ~pkg:b.pkg ~universe
- ~blessed:true ~actions:"all" ~odoc_bin ~odoc_md_bin
+ List.iter
+ (fun (b : build) ->
+ let pkg_dir = Build.dir ~os_dir b in
+ let installed_libs =
+ Day11_opam_layer.Installed_files.scan_libs ~layer_dir:pkg_dir
in
- let doc_hash = Day11_layer.Hash.of_strings
- [ "doc-all"; b.hash; odoc_tool.hash; universe ] in
- let doc_node : build =
- { hash = doc_hash; pkg = b.pkg;
- deps = odoc_tool.builds @ [ b ]; universe = Day11_solution.Universe.dummy } in
- (match Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:[ prep_mount ]
- doc_node ~strategy:{ cmd; cleanup = fun ~sw:_ _ _ -> () } () with
- | Types.Success bl ->
- let dd = Build.dir ~os_dir bl in
- let find_run = Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "find" % Fpath.to_string Fpath.(dd / "fs")
- % "-name" % "*.html" % "-type" % "f") None in
- let n = List.length (String.split_on_char '\n'
- (String.trim find_run.output)
- |> List.filter (fun s -> s <> "")) in
- Printf.printf " %s: %d HTML\n%!"
- (OpamPackage.to_string b.pkg) n;
- incr doc_all_count;
- doc_all_html := !doc_all_html + n
- | Types.Failure _ ->
- Printf.printf " %s: FAILED\n%!" (OpamPackage.to_string b.pkg)
- | _ -> ());
- ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir)
- end
- ) no_split;
+ if installed_libs = [] then
+ Printf.printf " %s: no libs, skipping\n%!"
+ (OpamPackage.to_string b.pkg)
+ else
+ let installed_docs =
+ Day11_opam_layer.Installed_files.scan_docs ~layer_dir:pkg_dir
+ in
+ let prep_dir = Bos.OS.Dir.tmp "day11_doc_%s" |> Result.get_ok in
+ ignore
+ (Day11_doc.Prep.create_with_mounts ~source_layer_dir:pkg_dir
+ ~dest_layer_dir:prep_dir ~universe ~pkg:b.pkg ~installed_libs
+ ~installed_docs);
+ let prep_mount =
+ Day11_container.Mount.bind_ro
+ ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
+ "/home/opam/prep"
+ in
+ let cmd =
+ "eval $(opam env) && "
+ ^ Day11_doc.Command.odoc_driver_voodoo ~pkg:b.pkg ~universe
+ ~blessed:true ~actions:"all" ~odoc_bin ~odoc_md_bin
+ in
+ let doc_hash =
+ Day11_layer.Hash.of_strings
+ [ "doc-all"; b.hash; odoc_tool.hash; universe ]
+ in
+ let doc_node : build =
+ {
+ hash = doc_hash;
+ pkg = b.pkg;
+ deps = odoc_tool.builds @ [ b ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ (match
+ Build_layer.build ~sw env benv ~opam_repositories:[]
+ ~mounts:[ prep_mount ] doc_node
+ ~strategy:{ cmd; cleanup = (fun ~sw:_ _ _ -> ()) }
+ ()
+ with
+ | Types.Success bl ->
+ let dd = Build.dir ~os_dir bl in
+ let find_run =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(
+ v "find"
+ % Fpath.to_string Fpath.(dd / "fs")
+ % "-name"
+ % "*.html"
+ % "-type"
+ % "f")
+ None
+ in
+ let n =
+ List.length
+ (String.split_on_char '\n' (String.trim find_run.output)
+ |> List.filter (fun s -> s <> ""))
+ in
+ Printf.printf " %s: %d HTML\n%!" (OpamPackage.to_string b.pkg) n;
+ incr doc_all_count;
+ doc_all_html := !doc_all_html + n
+ | Types.Failure _ ->
+ Printf.printf " %s: FAILED\n%!" (OpamPackage.to_string b.pkg)
+ | _ -> ());
+ ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir))
+ no_split;
Printf.printf " → %d packages documented, %d total HTML files\n%!"
!doc_all_count !doc_all_html;
(* Step 4: Compile phase for split packages *)
Printf.printf "\nGenerating docs (split phase — compile)...\n%!";
- let compile_builds = List.filter_map (fun (b : build) ->
- let pkg_dir = Build.dir ~os_dir b in
- let installed_libs = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:pkg_dir in
- if installed_libs = [] then None
- else begin
- let installed_docs = Day11_opam_layer.Installed_files.scan_docs
- ~layer_dir:pkg_dir in
- let prep_dir = Bos.OS.Dir.tmp "day11_doc_%s" |> Result.get_ok in
- ignore (Day11_doc.Prep.create_with_mounts ~source_layer_dir:pkg_dir
- ~dest_layer_dir:prep_dir ~universe ~pkg:b.pkg
- ~installed_libs ~installed_docs);
- let prep_mount = Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
- "/home/opam/prep" in
- let cmd =
- "eval $(opam env) && " ^
- Day11_doc.Command.odoc_driver_voodoo ~pkg:b.pkg ~universe
- ~blessed:true ~actions:"compile-only" ~odoc_bin ~odoc_md_bin
- in
- let compile_hash = Day11_layer.Hash.of_strings
- [ "compile"; b.hash; odoc_tool.hash ] in
- let compile_node : build =
- { hash = compile_hash; pkg = b.pkg;
- deps = odoc_tool.builds @ [ b ]; universe = Day11_solution.Universe.dummy } in
- match Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:[ prep_mount ]
- compile_node
- ~strategy:{ cmd; cleanup = fun ~sw:_ _ _ -> () } () with
- | Types.Success bl ->
- Printf.printf " %s: compile OK\n%!"
- (OpamPackage.to_string b.pkg);
- ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir);
- Some (b, bl)
- | _ ->
- Printf.printf " %s: compile FAILED\n%!"
- (OpamPackage.to_string b.pkg);
- ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir);
- None
- end
- ) needs_split in
+ let compile_builds =
+ List.filter_map
+ (fun (b : build) ->
+ let pkg_dir = Build.dir ~os_dir b in
+ let installed_libs =
+ Day11_opam_layer.Installed_files.scan_libs ~layer_dir:pkg_dir
+ in
+ if installed_libs = [] then None
+ else
+ let installed_docs =
+ Day11_opam_layer.Installed_files.scan_docs ~layer_dir:pkg_dir
+ in
+ let prep_dir = Bos.OS.Dir.tmp "day11_doc_%s" |> Result.get_ok in
+ ignore
+ (Day11_doc.Prep.create_with_mounts ~source_layer_dir:pkg_dir
+ ~dest_layer_dir:prep_dir ~universe ~pkg:b.pkg ~installed_libs
+ ~installed_docs);
+ let prep_mount =
+ Day11_container.Mount.bind_ro
+ ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
+ "/home/opam/prep"
+ in
+ let cmd =
+ "eval $(opam env) && "
+ ^ Day11_doc.Command.odoc_driver_voodoo ~pkg:b.pkg ~universe
+ ~blessed:true ~actions:"compile-only" ~odoc_bin ~odoc_md_bin
+ in
+ let compile_hash =
+ Day11_layer.Hash.of_strings [ "compile"; b.hash; odoc_tool.hash ]
+ in
+ let compile_node : build =
+ {
+ hash = compile_hash;
+ pkg = b.pkg;
+ deps = odoc_tool.builds @ [ b ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ match
+ Build_layer.build ~sw env benv ~opam_repositories:[]
+ ~mounts:[ prep_mount ] compile_node
+ ~strategy:{ cmd; cleanup = (fun ~sw:_ _ _ -> ()) }
+ ()
+ with
+ | Types.Success bl ->
+ Printf.printf " %s: compile OK\n%!" (OpamPackage.to_string b.pkg);
+ ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir);
+ Some (b, bl)
+ | _ ->
+ Printf.printf " %s: compile FAILED\n%!"
+ (OpamPackage.to_string b.pkg);
+ ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir);
+ None)
+ needs_split
+ in
(* Step 5: Link phase for split packages
These now have access to their deps' doc-all layers AND their
own compile layer *)
Printf.printf "\nGenerating docs (split phase — link)...\n%!";
let split_html = ref 0 in
- List.iter (fun ((b : build), (compile_bl : build)) ->
- let pkg_dir = Build.dir ~os_dir b in
- let installed_libs = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:pkg_dir in
- let installed_docs = Day11_opam_layer.Installed_files.scan_docs
- ~layer_dir:pkg_dir in
- let prep_dir = Bos.OS.Dir.tmp "day11_doc_%s" |> Result.get_ok in
- ignore (Day11_doc.Prep.create_with_mounts ~source_layer_dir:pkg_dir
- ~dest_layer_dir:prep_dir ~universe ~pkg:b.pkg
- ~installed_libs ~installed_docs);
- let prep_mount = Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
- "/home/opam/prep" in
- let cmd =
- "eval $(opam env) && " ^
- Day11_doc.Command.odoc_driver_voodoo ~pkg:b.pkg ~universe
- ~blessed:true ~actions:"link-and-gen" ~odoc_bin ~odoc_md_bin
- in
- let link_hash = Day11_layer.Hash.of_strings
- [ "link"; compile_bl.hash; universe ] in
- (* Link deps include: tool layers + build + compile layer *)
- let link_node : build =
- { hash = link_hash; pkg = b.pkg;
- deps = odoc_tool.builds @ [ b; compile_bl ]; universe = Day11_solution.Universe.dummy } in
- (match Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:[ prep_mount ]
- link_node ~strategy:{ cmd; cleanup = fun ~sw:_ _ _ -> () } () with
- | Types.Success bl ->
- let dd = Build.dir ~os_dir bl in
- let find_run = Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "find" % Fpath.to_string Fpath.(dd / "fs")
- % "-name" % "*.html" % "-type" % "f") None in
- let n = List.length (String.split_on_char '\n'
- (String.trim find_run.output)
- |> List.filter (fun s -> s <> "")) in
- Printf.printf " %s: link → %d HTML\n%!"
- (OpamPackage.to_string b.pkg) n;
- split_html := !split_html + n
- | Types.Failure _ ->
- Printf.printf " %s: link FAILED\n%!" (OpamPackage.to_string b.pkg)
- | _ -> ());
- ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir)
- ) compile_builds;
+ List.iter
+ (fun ((b : build), (compile_bl : build)) ->
+ let pkg_dir = Build.dir ~os_dir b in
+ let installed_libs =
+ Day11_opam_layer.Installed_files.scan_libs ~layer_dir:pkg_dir
+ in
+ let installed_docs =
+ Day11_opam_layer.Installed_files.scan_docs ~layer_dir:pkg_dir
+ in
+ let prep_dir = Bos.OS.Dir.tmp "day11_doc_%s" |> Result.get_ok in
+ ignore
+ (Day11_doc.Prep.create_with_mounts ~source_layer_dir:pkg_dir
+ ~dest_layer_dir:prep_dir ~universe ~pkg:b.pkg ~installed_libs
+ ~installed_docs);
+ let prep_mount =
+ Day11_container.Mount.bind_ro
+ ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
+ "/home/opam/prep"
+ in
+ let cmd =
+ "eval $(opam env) && "
+ ^ Day11_doc.Command.odoc_driver_voodoo ~pkg:b.pkg ~universe
+ ~blessed:true ~actions:"link-and-gen" ~odoc_bin ~odoc_md_bin
+ in
+ let link_hash =
+ Day11_layer.Hash.of_strings [ "link"; compile_bl.hash; universe ]
+ in
+ (* Link deps include: tool layers + build + compile layer *)
+ let link_node : build =
+ {
+ hash = link_hash;
+ pkg = b.pkg;
+ deps = odoc_tool.builds @ [ b; compile_bl ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ (match
+ Build_layer.build ~sw env benv ~opam_repositories:[]
+ ~mounts:[ prep_mount ] link_node
+ ~strategy:{ cmd; cleanup = (fun ~sw:_ _ _ -> ()) }
+ ()
+ with
+ | Types.Success bl ->
+ let dd = Build.dir ~os_dir bl in
+ let find_run =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(
+ v "find"
+ % Fpath.to_string Fpath.(dd / "fs")
+ % "-name"
+ % "*.html"
+ % "-type"
+ % "f")
+ None
+ in
+ let n =
+ List.length
+ (String.split_on_char '\n' (String.trim find_run.output)
+ |> List.filter (fun s -> s <> ""))
+ in
+ Printf.printf " %s: link → %d HTML\n%!"
+ (OpamPackage.to_string b.pkg)
+ n;
+ spli_html := !split_html + n
+ | Types.Failure _ ->
+ Printf.printf " %s: link FAILED\n%!" (OpamPackage.to_string b.pkg)
+ | _ -> ());
+ ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir))
+ compile_builds;
Printf.printf "\n=== Summary ===\n%!";
- Printf.printf " Single-phase: %d packages, %d HTML\n%!"
- !doc_all_count !doc_all_html;
+ Printf.printf " Single-phase: %d packages, %d HTML\n%!" !doc_all_count
+ !doc_all_html;
Printf.printf " Split-phase: %d packages, %d HTML\n%!"
- (List.length compile_builds) !split_html;
+ (List.length compile_builds)
+ !split_html;
Printf.printf " Total HTML: %d\n%!" (!doc_all_html + !split_html);
Alcotest.(check bool) "some single-phase docs" true (!doc_all_count > 0)
@@ -202,6 +279,8 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_doc_pipeline"
- [ ( "Full pipeline",
- [ Alcotest.test_case "odoc-driver docs" `Slow
- test_full_doc_pipeline ] ) ]
+ [
+ ( "Full pipeline",
+ [ Alcotest.test_case "odoc-driver docs" `Slow test_full_doc_pipeline ]
+ );
+ ]
File "day11/doc/test/test_generate_docs.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/test/test_generate_docs.ml b/_build/default/day11/doc/test/.formatted/test_generate_docs.ml
index 6c413d2..acef15a 100644
--- a/_build/default/day11/doc/test/test_generate_docs.ml
+++ b/_build/default/day11/doc/test/.formatted/test_generate_docs.ml
@@ -10,31 +10,36 @@ let os_dir = Fpath.(cache_dir / "linux-x86_64")
let _packages_dir = Fpath.(os_dir / "packages")
let base_dir = Fpath.(cache_dir / "base")
let _switch = "default"
+
let make_base () : Day11_layer.Base.t =
- { hash = Day11_opam_build.Base.build_hash ~os_distribution:"debian"
- ~os_version:"bookworm" ~arch:"x86_64" ();
+ {
+ hash =
+ Day11_opam_build.Base.build_hash ~os_distribution:"debian"
+ ~os_version:"bookworm" ~arch:"x86_64" ();
dir = base_dir;
- image = "debian:bookworm" }
+ image = "debian:bookworm";
+ }
-let test_voodoo_astring () = with_eio @@ fun ~sw env ->
- if not (Bos.OS.Dir.exists base_dir |> Result.get_ok) then
- Alcotest.skip ();
+let test_voodoo_astring () =
+ with_eio @@ fun ~sw env ->
+ if not (Bos.OS.Dir.exists base_dir |> Result.get_ok) then Alcotest.skip ();
let opam_repository = opam_repository () in
let base = make_base () in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
(* Step 1: Build odoc-driver *)
Printf.printf "Building odoc-driver.3.1.0...\n%!";
let benv : Day11_opam_build.Types.build_env =
- { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None } in
+ { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None }
+ in
let driver_tool =
- Day11_opam_build.Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas
+ Day11_opam_build.Tools.build_tool ~sw env benv ~packages:git_packages
+ ~repos:repos_with_shas
(OpamPackage.of_string "odoc-driver.3.1.0")
|> ok_or_fail "build odoc-driver"
in
- Printf.printf "odoc-driver: %d layers\n%!"
- (List.length driver_tool.builds);
+ Printf.printf "odoc-driver: %d layers\n%!" (List.length driver_tool.builds);
(* Step 2: Build astring on top of driver layers *)
Printf.printf "Building astring...\n%!";
let find_opam pkg =
@@ -45,57 +50,70 @@ let test_voodoo_astring () = with_eio @@ fun ~sw env ->
let cache = Day11_opam_build.Hash_cache.create ~find_opam () in
let astring_layer_hash =
Day11_opam_build.Hash_cache.layer_hash cache ~base_hash:base.hash
- [ astring_pkg ] in
+ [ astring_pkg ]
+ in
let astring_node : Day11_opam_layer.Build.t =
- { hash = astring_layer_hash; pkg = astring_pkg;
- deps = driver_tool.builds; universe = Day11_solution.Universe.dummy } in
+ {
+ hash = astring_layer_hash;
+ pkg = astring_pkg;
+ deps = driver_tool.builds;
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
let astring_result =
- Day11_opam_build.Build_layer.build ~sw env benv
- ~opam_repositories:[] astring_node ()
+ Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[]
+ astring_node ()
in
(match astring_result with
- | Day11_opam_build.Types.Success bl ->
- Printf.printf "astring: %s\n%!" bl.hash
- | _ -> Alcotest.fail "astring build failed");
+ | Day11_opam_build.Types.Success bl -> Printf.printf "astring: %s\n%!" bl.hash
+ | _ -> Alcotest.fail "astring build failed");
(* Step 3: Create prep structure *)
let astring_layer = Day11_opam_layer.Build.dir ~os_dir astring_node in
- let _ = Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "chmod" % "-R" % "a+rX"
- % Fpath.to_string Fpath.(astring_layer / "fs")) in
- let installed_libs = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:astring_layer in
- let installed_docs = Day11_opam_layer.Installed_files.scan_docs
- ~layer_dir:astring_layer in
+ let _ =
+ Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "chmod" % "-R" % "a+rX" % Fpath.to_string Fpath.(astring_layer / "fs"))
+ in
+ let installed_libs =
+ Day11_opam_layer.Installed_files.scan_libs ~layer_dir:astring_layer
+ in
+ let installed_docs =
+ Day11_opam_layer.Installed_files.scan_docs ~layer_dir:astring_layer
+ in
let prep_dir = Bos.OS.Dir.tmp "day11_prep_%s" |> Result.get_ok in
let _prep_root =
- Day11_doc.Prep.create_with_mounts
- ~source_layer_dir:astring_layer
- ~dest_layer_dir:prep_dir
- ~universe:"test" ~pkg:astring_pkg
- ~installed_libs ~installed_docs
+ Day11_doc.Prep.create_with_mounts ~source_layer_dir:astring_layer
+ ~dest_layer_dir:prep_dir ~universe:"test" ~pkg:astring_pkg ~installed_libs
+ ~installed_docs
|> ok_or_fail "prep"
in
(* Step 4: Run odoc_driver_voodoo via Run_in_layers *)
- let all_builds = driver_tool.builds @
- (match astring_result with
- | Day11_opam_build.Types.Success bl -> [ bl ]
- | _ -> []) in
+ let all_builds =
+ driver_tool.builds
+ @
+ match astring_result with
+ | Day11_opam_build.Types.Success bl -> [ bl ]
+ | _ -> []
+ in
let voodoo_cmd =
- "eval $(opam env) && " ^
- "odoc_driver_voodoo astring " ^
- "--odoc-dir /home/opam/odoc-out " ^
- "--html-dir /home/opam/html " ^
- "--actions all -v"
- in
- let mounts = [
- Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
- "/home/opam/prep";
- ] in
- let build_dirs = List.map
- (Day11_opam_layer.Build.dir ~os_dir) all_builds in
- let spec = Day11_opam_build.Build_layer.opam_build_spec
- ~cmd:voodoo_cmd ~mounts ~uid:1000 ~gid:1000 () in
+ "eval $(opam env) && "
+ ^ "odoc_driver_voodoo astring "
+ ^ "--odoc-dir /home/opam/odoc-out "
+ ^ "--html-dir /home/opam/html "
+ ^ "--actions all -v"
+ in
+ let mounts =
+ [
+ Day11_container.Mount.bind_ro
+ ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
+ "/home/opam/prep";
+ ]
+ in
+ let build_dirs = List.map (Day11_opam_layer.Build.dir ~os_dir) all_builds in
+ let spec =
+ Day11_opam_build.Build_layer.opam_build_spec ~cmd:voodoo_cmd ~mounts
+ ~uid:1000 ~gid:1000 ()
+ in
let run, upper, _timing =
Day11_runner.Run_in_layers.run ~sw env ~base ~build_dirs spec
|> ok_or_fail "run voodoo"
@@ -105,26 +123,36 @@ let test_voodoo_astring () = with_eio @@ fun ~sw env ->
ignore (Day11_sys.Sudo.rm_rf ~sw env (Fpath.parent upper));
ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir))
(fun () ->
- let exit_code = match run.status with
- | `Exited n -> n | `Signaled n -> 128 + n in
- Printf.printf "odoc_driver_voodoo exit: %d (%.1fs)\n%!"
- exit_code run.time;
- if exit_code <> 0 then
- Printf.printf "STDERR:\n%s\n%!" run.errors;
- let _ = Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "chmod" % "-R" % "a+rX"
- % Fpath.to_string upper) in
+ let exit_code =
+ match run.status with `Exited n -> n | `Signaled n -> 128 + n
+ in
+ Printf.printf "odoc_driver_voodoo exit: %d (%.1fs)\n%!" exit_code run.time;
+ if exit_code <> 0 then Printf.printf "STDERR:\n%s\n%!" run.errors;
+ let _ =
+ Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(v "chmod" % "-R" % "a+rX" % Fpath.to_string upper)
+ in
let html_dir = Fpath.(upper / "home" / "opam" / "html") in
let html_count =
- if Bos.OS.Dir.exists html_dir |> Result.get_ok then begin
- let find_run = Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "find" % Fpath.to_string html_dir
- % "-name" % "*.html" % "-type" % "f") None in
- let files = String.split_on_char '\n' (String.trim find_run.output)
- |> List.filter (fun s -> s <> "") in
+ if Bos.OS.Dir.exists html_dir |> Result.get_ok then (
+ let find_run =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(
+ v "find"
+ % Fpath.to_string html_dir
+ % "-name"
+ % "*.html"
+ % "-type"
+ % "f")
+ None
+ in
+ let files =
+ String.split_on_char '\n' (String.trim find_run.output)
+ |> List.filter (fun s -> s <> "")
+ in
Printf.printf "HTML files: %d\n%!" (List.length files);
- List.length files
- end else 0
+ List.length files)
+ else 0
in
Alcotest.(check bool) "voodoo exit 0" true (exit_code = 0);
Alcotest.(check bool) "HTML generated" true (html_count > 0))
@@ -134,5 +162,7 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_generate_docs"
- [ ( "Voodoo",
- [ Alcotest.test_case "astring docs" `Slow test_voodoo_astring ] ) ]
+ [
+ ( "Voodoo",
+ [ Alcotest.test_case "astring docs" `Slow test_voodoo_astring ] );
+ ]
File "day11/jtw/test/test_jtw.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/test/test_jtw.ml b/_build/default/day11/jtw/test/.formatted/test_jtw.ml
index fc60581..458ee07 100644
--- a/_build/default/day11/jtw/test/test_jtw.ml
+++ b/_build/default/day11/jtw/test/.formatted/test_jtw.ml
@@ -16,64 +16,85 @@ let test_layer_hash_varies () =
Alcotest.(check bool) "different" true (h1 <> h2)
let test_dynamic_cmis_json () =
- let json = Gen.generate_dynamic_cmis_json
- ~dcs_url:"/lib/astring/"
- [ "Astring.cmi"; "Astring_base.cmi"; "Astring__Config.cmi" ] in
- Alcotest.(check bool) "has dcs_url"
- true (Astring.String.is_infix ~affix:"dcs_url" json);
- Alcotest.(check bool) "has toplevel Astring"
- true (Astring.String.is_infix ~affix:"Astring" json);
- Alcotest.(check bool) "has Astring_base"
- true (Astring.String.is_infix ~affix:"Astring_base" json)
+ let json =
+ Gen.generate_dynamic_cmis_json ~dcs_url:"/lib/astring/"
+ [ "Astring.cmi"; "Astring_base.cmi"; "Astring__Config.cmi" ]
+ in
+ Alcotest.(check bool)
+ "has dcs_url" true
+ (Astring.String.is_infix ~affix:"dcs_url" json);
+ Alcotest.(check bool)
+ "has toplevel Astring" true
+ (Astring.String.is_infix ~affix:"Astring" json);
+ Alcotest.(check bool)
+ "has Astring_base" true
+ (Astring.String.is_infix ~affix:"Astring_base" json)
let test_dynamic_cmis_json_empty () =
let json = Gen.generate_dynamic_cmis_json ~dcs_url:"/lib/" [] in
- Alcotest.(check bool) "valid json"
- true (Astring.String.is_infix ~affix:"dcs_url" json);
- Alcotest.(check bool) "empty modules"
- true (Astring.String.is_infix ~affix:"[]" json)
+ Alcotest.(check bool)
+ "valid json" true
+ (Astring.String.is_infix ~affix:"dcs_url" json);
+ Alcotest.(check bool)
+ "empty modules" true
+ (Astring.String.is_infix ~affix:"[]" json)
let test_findlib_index () =
- let compiler = `Assoc [
- ("version", `String "5.2.0");
- ("content_hash", `String "abc123");
- ] in
- let json = Gen.generate_findlib_index ~compiler
- [ "../../p/astring/0.8.5/hash/lib/astring/META" ] in
- Alcotest.(check bool) "has compiler"
- true (Astring.String.is_infix ~affix:"5.2.0" json);
- Alcotest.(check bool) "has meta path"
- true (Astring.String.is_infix ~affix:"astring/META" json)
+ let compiler =
+ `Assoc [ ("version", `String "5.2.0"); ("content_hash", `String "abc123") ]
+ in
+ let json =
+ Gen.generate_findlib_index ~compiler
+ [ "../../p/astring/0.8.5/hash/lib/astring/META" ]
+ in
+ Alcotest.(check bool)
+ "has compiler" true
+ (Astring.String.is_infix ~affix:"5.2.0" json);
+ Alcotest.(check bool)
+ "has meta path" true
+ (Astring.String.is_infix ~affix:"astring/META" json)
let test_findlib_names () =
- let names = Gen.findlib_names_of_installed_libs
- [ "astring/astring.cmi"; "astring/META";
- "hmap/hmap.cmi"; "hmap/META";
- "fmt/fmt.cmi" (* no META *) ] in
- Alcotest.(check (list string)) "findlib names"
- [ "astring"; "hmap" ] names
+ let names =
+ Gen.findlib_names_of_installed_libs
+ [
+ "astring/astring.cmi";
+ "astring/META";
+ "hmap/hmap.cmi";
+ "hmap/META";
+ "fmt/fmt.cmi" (* no META *);
+ ]
+ in
+ Alcotest.(check (list string)) "findlib names" [ "astring"; "hmap" ] names
let test_findlib_names_empty () =
let names = Gen.findlib_names_of_installed_libs [] in
Alcotest.(check (list string)) "empty" [] names
let test_container_script () =
- let script = Gen.container_script
- ~pkg:(OpamPackage.of_string "astring.0.8.5")
- ~installed_libs:[ "astring/META"; "astring/astring.cmi" ] in
- Alcotest.(check bool) "has jtw opam"
- true (Astring.String.is_infix ~affix:"jtw opam" script);
- Alcotest.(check bool) "has astring"
- true (Astring.String.is_infix ~affix:"astring" script)
+ let script =
+ Gen.container_script
+ ~pkg:(OpamPackage.of_string "astring.0.8.5")
+ ~installed_libs:[ "astring/META"; "astring/astring.cmi" ]
+ in
+ Alcotest.(check bool)
+ "has jtw opam" true
+ (Astring.String.is_infix ~affix:"jtw opam" script);
+ Alcotest.(check bool)
+ "has astring" true
+ (Astring.String.is_infix ~affix:"astring" script)
let test_container_script_no_libs () =
- let script = Gen.container_script
- ~pkg:(OpamPackage.of_string "binary.1.0")
- ~installed_libs:[ "binary/binary.cmi" ] in
+ let script =
+ Gen.container_script
+ ~pkg:(OpamPackage.of_string "binary.1.0")
+ ~installed_libs:[ "binary/binary.cmi" ]
+ in
(* No META → no findlib packages → returns "true" *)
Alcotest.(check string) "no-op" "true" script
-let test_content_hash () = with_tmp_dir @@ fun dir ->
+let test_content_hash () =
+ with_tmp_dir @@ fun dir ->
let lib = Fpath.to_string dir in
mkdir Fpath.(dir / "astring");
write_file Fpath.(dir / "astring" / "astring.cmi") "cmi content";
@@ -94,49 +115,67 @@ let test_jtw_result_to_yojson () =
(* ── Tool_layer tests ────────────────────────────────────────────── *)
let test_tool_hash_deterministic () =
- let h1 = Tool_layer.layer_hash
- ~base_hash:"b" ~ocaml_version:"5.2.0" ~compiler_hashes:[ "c1" ] in
- let h2 = Tool_layer.layer_hash
- ~base_hash:"b" ~ocaml_version:"5.2.0" ~compiler_hashes:[ "c1" ] in
+ let h1 =
+ Tool_layer.layer_hash ~base_hash:"b" ~ocaml_version:"5.2.0"
+ ~compiler_hashes:[ "c1" ]
+ in
+ let h2 =
+ Tool_layer.layer_hash ~base_hash:"b" ~ocaml_version:"5.2.0"
+ ~compiler_hashes:[ "c1" ]
+ in
Alcotest.(check string) "deterministic" h1 h2
let test_tool_hash_varies () =
- let h1 = Tool_layer.layer_hash
- ~base_hash:"b" ~ocaml_version:"5.1.0" ~compiler_hashes:[] in
- let h2 = Tool_layer.layer_hash
- ~base_hash:"b" ~ocaml_version:"5.2.0" ~compiler_hashes:[] in
+ let h1 =
+ Tool_layer.layer_hash ~base_hash:"b" ~ocaml_version:"5.1.0"
+ ~compiler_hashes:[]
+ in
+ let h2 =
+ Tool_layer.layer_hash ~base_hash:"b" ~ocaml_version:"5.2.0"
+ ~compiler_hashes:[]
+ in
Alcotest.(check bool) "different" true (h1 <> h2)
let test_tool_layer_name () =
- let name = Tool_layer.layer_name
- ~base_hash:"b" ~ocaml_version:"5.2.0" ~compiler_hashes:[] in
- Alcotest.(check bool) "starts with jtw-tools-"
- true (Astring.String.is_prefix ~affix:"jtw-tools-" name)
-
-let test_tool_exists_empty () = with_tmp_dir @@ fun dir ->
- Alcotest.(check bool) "not exists"
- false (Tool_layer.exists ~layer_dir:dir)
-
-let test_tool_has_jsoo_empty () = with_tmp_dir @@ fun dir ->
- Alcotest.(check bool) "no jsoo"
- false (Tool_layer.has_jsoo ~layer_dir:dir)
-
-let test_tool_has_worker_empty () = with_tmp_dir @@ fun dir ->
- Alcotest.(check bool) "no worker"
- false (Tool_layer.has_worker_js ~layer_dir:dir)
+ let name =
+ Tool_layer.layer_name ~base_hash:"b" ~ocaml_version:"5.2.0"
+ ~compiler_hashes:[]
+ in
+ Alcotest.(check bool)
+ "starts with jtw-tools-" true
+ (Astring.String.is_prefix ~affix:"jtw-tools-" name)
+
+let test_tool_exists_empty () =
+ with_tmp_dir @@ fun dir ->
+ Alcotest.(check bool) "not exists" false (Tool_layer.exists ~layer_dir:dir)
+
+let test_tool_has_jsoo_empty () =
+ with_tmp_dir @@ fun dir ->
+ Alcotest.(check bool) "no jsoo" false (Tool_layer.has_jsoo ~layer_dir:dir)
+
+let test_tool_has_worker_empty () =
+ with_tmp_dir @@ fun dir ->
+ Alcotest.(check bool)
+ "no worker" false
+ (Tool_layer.has_worker_js ~layer_dir:dir)
let test_tool_packages () =
- Alcotest.(check bool) "has js_top_worker"
- true (List.mem "js_top_worker" Tool_layer.jtw_packages)
+ Alcotest.(check bool)
+ "has js_top_worker" true
+ (List.mem "js_top_worker" Tool_layer.jtw_packages)
let test_build_script () =
- let script = Tool_layer.build_script
- ~packages:[ "js_of_ocaml"; "js_top_worker-bin" ]
- ~pin_commands:[] ~needs_compiler:false ~compiler_pkg:"" in
- Alcotest.(check bool) "has opam install"
- true (Astring.String.is_infix ~affix:"opam install" script);
- Alcotest.(check bool) "has jtw"
- true (Astring.String.is_infix ~affix:"jtw" script)
+ let script =
+ Tool_layer.build_script
+ ~packages:[ "js_of_ocaml"; "js_top_worker-bin" ]
+ ~pin_commands:[] ~needs_compiler:false ~compiler_pkg:""
+ in
+ Alcotest.(check bool)
+ "has opam install" true
+ (Astring.String.is_infix ~affix:"opam install" script);
+ Alcotest.(check bool)
+ "has jtw" true
+ (Astring.String.is_infix ~affix:"jtw" script)
(* ── Test registration ───────────────────────────────────────────── *)
@@ -147,10 +186,8 @@ let () =
[
Alcotest.test_case "layer hash deterministic" `Quick
test_layer_hash_deterministic;
- Alcotest.test_case "layer hash varies" `Quick
- test_layer_hash_varies;
- Alcotest.test_case "dynamic_cmis_json" `Quick
- test_dynamic_cmis_json;
+ Alcotest.test_case "layer hash varies" `Quick test_layer_hash_varies;
+ Alcotest.test_case "dynamic_cmis_json" `Quick test_dynamic_cmis_json;
Alcotest.test_case "dynamic_cmis_json empty" `Quick
test_dynamic_cmis_json_empty;
Alcotest.test_case "findlib_index" `Quick test_findlib_index;
File "day11/jtw/test/test_jtw_integration.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/test/test_jtw_integration.ml b/_build/default/day11/jtw/test/.formatted/test_jtw_integration.ml
index afa2214..755067c 100644
--- a/_build/default/day11/jtw/test/test_jtw_integration.ml
+++ b/_build/default/day11/jtw/test/.formatted/test_jtw_integration.ml
@@ -13,26 +13,33 @@ let scratch_cache_dir = Fpath.v "/tmp/day11-scratch-cache"
let jtw_local_source = "/home/jjl25/monopam-myspace/js_top_worker"
let jtw_container_path = "/home/opam/local/js_top_worker"
-let test_build_jsoo () = with_eio @@ fun ~sw env ->
- let base = match Base.load_cached ~cache_dir:scratch_cache_dir
- ~os_distribution:"debian" ~os_version:"bookworm" with
+let test_build_jsoo () =
+ with_eio @@ fun ~sw env ->
+ let base =
+ match
+ Base.load_cached ~cache_dir:scratch_cache_dir ~os_distribution:"debian"
+ ~os_version:"bookworm"
+ with
| Some b -> b
- | None -> Printf.printf "No cache\n%!"; Alcotest.skip ()
+ | None ->
+ Printf.printf "No cache\n%!";
+ Alcotest.skip ()
in
let opam_repository = opam_repository () in
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
Types.ensure_dirs benv;
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
let jsoo_versions =
Day11_opam.Git_packages.get_versions git_packages
- (OpamPackage.Name.of_string "js_of_ocaml") in
+ (OpamPackage.Name.of_string "js_of_ocaml")
+ in
let jsoo_pkg =
match OpamPackage.Version.Map.max_binding_opt jsoo_versions with
| Some (v, _) ->
- OpamPackage.create (OpamPackage.Name.of_string "js_of_ocaml") v
+ OpamPackage.create (OpamPackage.Name.of_string "js_of_ocaml") v
| None -> Alcotest.skip ()
in
Printf.printf "Building %s...\n%!" (OpamPackage.to_string jsoo_pkg);
@@ -42,39 +49,57 @@ let test_build_jsoo () = with_eio @@ fun ~sw env ->
|> ok_or_fail "build_tool"
in
Printf.printf " %d layers\n%!" (List.length tool.builds);
- Alcotest.(check bool) "has layers" true
- (List.length tool.builds > 0);
- let has_jsoo_bin = List.exists (fun (bl : Day11_opam_layer.Build.t) ->
- let bl_dir = Day11_opam_layer.Build.dir ~os_dir bl in
- let bin = Fpath.(bl_dir / "fs" / "home" / "opam" / ".opam"
- / Types.switch / "bin" / "js_of_ocaml") in
- Bos.OS.File.exists bin |> Result.get_ok
- ) tool.builds in
+ Alcotest.(check bool) "has layers" true (List.length tool.builds > 0);
+ let has_jsoo_bin =
+ List.exists
+ (fun (bl : Day11_opam_layer.Build.t) ->
+ let bl_dir = Day11_opam_layer.Build.dir ~os_dir bl in
+ let bin =
+ Fpath.(
+ bl_dir
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / Types.switch
+ / "bin"
+ / "js_of_ocaml")
+ in
+ Bos.OS.File.exists bin |> Result.get_ok)
+ tool.builds
+ in
Printf.printf " js_of_ocaml binary found: %b\n%!" has_jsoo_bin;
Alcotest.(check bool) "js_of_ocaml binary" true has_jsoo_bin
-let test_build_jtw_tools () = with_eio @@ fun ~sw env ->
- let base = match Base.load_cached ~cache_dir:scratch_cache_dir
- ~os_distribution:"debian" ~os_version:"bookworm" with
+let test_build_jtw_tools () =
+ with_eio @@ fun ~sw env ->
+ let base =
+ match
+ Base.load_cached ~cache_dir:scratch_cache_dir ~os_distribution:"debian"
+ ~os_version:"bookworm"
+ with
| Some b -> b
- | None -> Printf.printf "No cache\n%!"; Alcotest.skip ()
+ | None ->
+ Printf.printf "No cache\n%!";
+ Alcotest.skip ()
in
let opam_repository = opam_repository () in
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
Types.ensure_dirs benv;
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
(* First build the compiler + jsoo deps via Tools.build_tool *)
Printf.printf "Building js_of_ocaml toolchain...\n%!";
let jsoo_versions =
Day11_opam.Git_packages.get_versions git_packages
- (OpamPackage.Name.of_string "js_of_ocaml") in
+ (OpamPackage.Name.of_string "js_of_ocaml")
+ in
let jsoo_pkg =
match OpamPackage.Version.Map.max_binding_opt jsoo_versions with
| Some (v, _) ->
- OpamPackage.create (OpamPackage.Name.of_string "js_of_ocaml") v
+ OpamPackage.create (OpamPackage.Name.of_string "js_of_ocaml") v
| None -> Alcotest.skip ()
in
let tool =
@@ -84,74 +109,114 @@ let test_build_jtw_tools () = with_eio @@ fun ~sw env ->
in
Printf.printf " jsoo: %d layers\n%!" (List.length tool.builds);
(* Now build the full JTW tools layer on top, using local source *)
- if not (Sys.file_exists jtw_local_source) then
- (Printf.printf "No local js_top_worker at %s\n%!" jtw_local_source;
- Alcotest.skip ());
+ if not (Sys.file_exists jtw_local_source) then (
+ Printf.printf "No local js_top_worker at %s\n%!" jtw_local_source;
+ Alcotest.skip ());
Printf.printf "Building JTW tools (local: %s)...\n%!" jtw_local_source;
- let extra_pins = Day11_jtw.Tool_layer.[
- { package = "mime_printer";
- url = "git+https://github.com/jonludlam/mime_printer.git#odoc_notebook" }
- ] in
- let cmd = Day11_jtw.Tool_layer.build_cmd_local
- ~container_path:jtw_container_path ~extra_pins in
- let strategy : Types.build_strategy = {
- cmd;
- cleanup = Build_layer.opam_build_cleanup;
- } in
- let jtw_mount = Day11_container.Mount.bind_ro
- ~src:jtw_local_source jtw_container_path in
+ let extra_pins =
+ Day11_jtw.Tool_layer.
+ [
+ {
+ package = "mime_printer";
+ url =
+ "git+https://github.com/jonludlam/mime_printer.git#odoc_notebook";
+ };
+ ]
+ in
+ let cmd =
+ Day11_jtw.Tool_layer.build_cmd_local ~container_path:jtw_container_path
+ ~extra_pins
+ in
+ let strategy : Types.build_strategy =
+ { cmd; cleanup = Build_layer.opam_build_cleanup }
+ in
+ let jtw_mount =
+ Day11_container.Mount.bind_ro ~src:jtw_local_source jtw_container_path
+ in
(* Use a dummy package for the layer *)
let jtw_pkg = OpamPackage.of_string "jtw-tools.0" in
- let layer_hash = Day11_layer.Hash.of_strings
- [ "jtw-tools"; base.hash; jtw_local_source ] in
+ let layer_hash =
+ Day11_layer.Hash.of_strings [ "jtw-tools"; base.hash; jtw_local_source ]
+ in
let jtw_node : Day11_opam_layer.Build.t =
- { hash = layer_hash; pkg = jtw_pkg; deps = tool.builds; universe = Day11_solution.Universe.dummy } in
+ {
+ hash = layer_hash;
+ pkg = jtw_pkg;
+ deps = tool.builds;
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
let result =
- Build_layer.build ~sw env benv
- ~opam_repositories:[]
- ~mounts:[ jtw_mount ]
- jtw_node
- ~strategy ()
+ Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:[ jtw_mount ]
+ jtw_node ~strategy ()
in
match result with
| Types.Success bl ->
- Printf.printf " JTW tools layer: %s\n%!" bl.hash;
- let bl_dir = Day11_opam_layer.Build.dir ~os_dir bl in
- (* Check for jtw binary *)
- let has_jtw = Bos.OS.File.exists
- Fpath.(bl_dir / "fs" / "home" / "opam" / ".opam"
- / Types.switch / "bin" / "jtw")
- |> Result.get_ok in
- Printf.printf " jtw binary: %b\n%!" has_jtw;
- Alcotest.(check bool) "jtw binary" true has_jtw;
- (* Check for stdlib artifacts (--no-worker produces CMIs, not worker.js) *)
- let dynamic_cmis = Fpath.(bl_dir / "fs" / "home" / "opam"
- / "jtw-tools-output" / "lib" / "ocaml" / "dynamic_cmis.json") in
- let has_dynamic_cmis = Bos.OS.File.exists dynamic_cmis |> Result.get_ok in
- Printf.printf " dynamic_cmis.json: %b\n%!" has_dynamic_cmis;
- Alcotest.(check bool) "dynamic_cmis.json" true has_dynamic_cmis;
- let stdlib_js = Fpath.(bl_dir / "fs" / "home" / "opam"
- / "jtw-tools-output" / "lib" / "ocaml" / "stdlib.cma.js") in
- let has_stdlib_js = Bos.OS.File.exists stdlib_js |> Result.get_ok in
- Printf.printf " stdlib.cma.js: %b\n%!" has_stdlib_js;
- Alcotest.(check bool) "stdlib.cma.js" true has_stdlib_js
+ Printf.printf " JTW tools layer: %s\n%!" bl.hash;
+ let bl_dir = Day11_opam_layer.Build.dir ~os_dir bl in
+ (* Check for jtw binary *)
+ let has_jtw =
+ Bos.OS.File.exists
+ Fpath.(
+ bl_dir
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / Types.switch
+ / "bin"
+ / "jtw")
+ |> Result.get_ok
+ in
+ Printf.printf " jtw binary: %b\n%!" has_jtw;
+ Alcotest.(check bool) "jtw binary" true has_jtw;
+ (* Check for stdlib artifacts (--no-worker produces CMIs, not worker.js) *)
+ let dynamic_cmis =
+ Fpath.(
+ bl_dir
+ / "fs"
+ / "home"
+ / "opam"
+ / "jtw-tools-output"
+ / "lib"
+ / "ocaml"
+ / "dynamic_cmis.json")
+ in
+ let has_dynamic_cmis = Bos.OS.File.exists dynamic_cmis |> Result.get_ok in
+ Printf.printf " dynamic_cmis.json: %b\n%!" has_dynamic_cmis;
+ Alcotest.(check bool) "dynamic_cmis.json" true has_dynamic_cmis;
+ let stdlib_js =
+ Fpath.(
+ bl_dir
+ / "fs"
+ / "home"
+ / "opam"
+ / "jtw-tools-output"
+ / "lib"
+ / "ocaml"
+ / "stdlib.cma.js")
+ in
+ let has_stdlib_js = Bos.OS.File.exists stdlib_js |> Result.get_ok in
+ Printf.printf " stdlib.cma.js: %b\n%!" has_stdlib_js;
+ Alcotest.(check bool) "stdlib.cma.js" true has_stdlib_js
| Types.Failure name ->
- (* Print the build log for debugging *)
- let log_path = Fpath.(benv.os_dir / name / "layer.log") in
- (match Bos.OS.File.read log_path with
- | Ok log -> Printf.printf "BUILD LOG:\n%s\n%!" log
- | Error _ -> ());
- Alcotest.fail (Printf.sprintf "JTW tools build failed: %s" name)
- | _ ->
- Alcotest.fail "Unexpected build result"
+ (* Print the build log for debugging *)
+ let log_path = Fpath.(benv.os_dir / name / "layer.log") in
+ (match Bos.OS.File.read log_path with
+ | Ok log -> Printf.printf "BUILD LOG:\n%s\n%!" log
+ | Error _ -> ());
+ Alcotest.fail (Printf.sprintf "JTW tools build failed: %s" name)
+ | _ -> Alcotest.fail "Unexpected build result"
let () =
if not (is_integration ()) then
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_jtw_integration"
- [ ( "JTW",
- [ Alcotest.test_case "build js_of_ocaml" `Slow
- test_build_jsoo;
- Alcotest.test_case "build jtw tools" `Slow
- test_build_jtw_tools ] ) ]
+ [
+ ( "JTW",
+ [
+ Alcotest.test_case "build js_of_ocaml" `Slow test_build_jsoo;
+ Alcotest.test_case "build jtw tools" `Slow test_build_jtw_tools;
+ ] );
+ ]
File "src/solver/git_context.ml", line 1, characters 0-0:
diff --git a/_build/default/src/solver/git_context.ml b/_build/default/src/solver/.formatted/git_context.ml
index e805f22..728e10f 100644
--- a/_build/default/src/solver/git_context.ml
+++ b/_build/default/src/solver/.formatted/git_context.ml
@@ -160,6 +160,6 @@ let read_packages store commit =
OpamPackage.Name.Map.empty)
let create ?(test = OpamPackage.Name.Set.empty)
- ?(pins = OpamPackage.Name.Map.empty) ?(doc = false)
- ~constraints ~env ~packages () =
+ ?(pins = OpamPackage.Name.Map.empty) ?(doc = false) ~constraints ~env
+ ~packages () =
{ env; packages; pins; constraints; test; doc }
File "src/solver/main.ml", line 1, characters 0-0:
diff --git a/_build/default/src/solver/main.ml b/_build/default/src/solver/.formatted/main.ml
index d791ee1..fb6d7f5 100644
--- a/_build/default/src/solver/main.ml
+++ b/_build/default/src/solver/.formatted/main.ml
@@ -79,10 +79,8 @@ let () =
| [| _prog; "test" |] ->
Solver.test
(Git_unix.Store.Hash.of_hex "ac01ad6037c0bdcca9f67fe49cd54475b585f9b2")
- | [| _prog; "test-fake" |] ->
- Solver.test_fake ()
- | [| _prog; "test-real"; repo_path |] ->
- Solver.test_real repo_path
+ | [| _prog; "test-fake" |] -> Solver.test_fake ()
+ | [| _prog; "test-real"; repo_path |] -> Solver.test_real repo_path
| args ->
Fmt.failwith "Usage: ocaml-ci-solver (got %a)"
Fmt.(array (quote string))
File "src/solver/opam_repository.ml", line 1, characters 0-0:
diff --git a/_build/default/src/solver/opam_repository.ml b/_build/default/src/solver/.formatted/opam_repository.ml
index 05e9f3a..4492e3e 100644
--- a/_build/default/src/solver/opam_repository.ml
+++ b/_build/default/src/solver/.formatted/opam_repository.ml
@@ -21,7 +21,8 @@ let open_store_at path =
Git_unix.Store.v ~dotgit fpath >|= function
| Ok x -> x
| Error e ->
- Fmt.failwith "Failed to open opam-repository at %s: %a" path Store.pp_error e
+ Fmt.failwith "Failed to open opam-repository at %s: %a" path
+ Store.pp_error e
let clone () =
match Unix.lstat clone_path with
File "src/solver/solver.ml", line 1, characters 0-0:
diff --git a/_build/default/src/solver/solver.ml b/_build/default/src/solver/.formatted/solver.ml
index bc93853..f28e5ba 100644
--- a/_build/default/src/solver/solver.ml
+++ b/_build/default/src/solver/.formatted/solver.ml
@@ -13,8 +13,10 @@ let env (vars : Worker.Vars.t) =
let get_names = OpamFormula.fold_left (fun a (name, _) -> name :: a) []
-let universes ?(post = false) ?(doc = false) ~packages (resolutions : OpamPackage.t list) =
- Printf.eprintf "DEBUG universes: post=%b doc=%b resolutions=%d\n%!" post doc (List.length resolutions);
+let universes ?(post = false) ?(doc = false) ~packages
+ (resolutions : OpamPackage.t list) =
+ Printf.eprintf "DEBUG universes: post=%b doc=%b resolutions=%d\n%!" post doc
+ (List.length resolutions);
let aux root =
let name, version = (OpamPackage.name root, OpamPackage.version root) in
let opamfile : OpamFile.OPAM.t =
@@ -23,15 +25,16 @@ let universes ?(post = false) ?(doc = false) ~packages (resolutions : OpamPackag
|> OpamPackage.Name.Map.find name
|> OpamPackage.Version.Map.find version
with Not_found ->
- Printf.eprintf "DEBUG: Package not found in packages map: %s\n%!" (OpamPackage.to_string root);
+ Printf.eprintf "DEBUG: Package not found in packages map: %s\n%!"
+ (OpamPackage.to_string root);
raise Not_found
in
let deps =
opamfile
|> OpamFile.OPAM.depends
|> OpamFilter.partial_filter_formula
- (OpamFilter.deps_var_env ~build:true ~post ~test:false
- ~doc ~dev_setup:false ~dev:false)
+ (OpamFilter.deps_var_env ~build:true ~post ~test:false ~doc
+ ~dev_setup:false ~dev:false)
|> get_names
|> OpamPackage.Name.Set.of_list
in
@@ -39,8 +42,8 @@ let universes ?(post = false) ?(doc = false) ~packages (resolutions : OpamPackag
opamfile
|> OpamFile.OPAM.depopts
|> OpamFilter.partial_filter_formula
- (OpamFilter.deps_var_env ~build:true ~post ~test:false
- ~doc ~dev_setup:false ~dev:false)
+ (OpamFilter.deps_var_env ~build:true ~post ~test:false ~doc
+ ~dev_setup:false ~dev:false)
|> get_names
|> OpamPackage.Name.Set.of_list
in
@@ -113,11 +116,15 @@ let solve ~packages ~constraints ~root_pkgs (vars : Worker.Vars.t) =
on odoc/documentation tools that create cycles (e.g., camlp-streams -> odoc -> odoc-parser -> camlp-streams) *)
Printf.eprintf "DEBUG: Computing compile_universes...\n%!";
let compile_universes = universes ~post:false ~doc:false ~packages pkgs in
- Printf.eprintf "DEBUG: compile_universes done (%d entries)\n%!" (List.length compile_universes);
+ Printf.eprintf "DEBUG: compile_universes done (%d entries)\n%!"
+ (List.length compile_universes);
(* link_universes: use extended packages, include all deps *)
Printf.eprintf "DEBUG: Computing link_universes...\n%!";
- let link_universes = universes ~post:true ~doc:true ~packages:extended pkgs in
- Printf.eprintf "DEBUG: link_universes done (%d entries)\n%!" (List.length link_universes);
+ let link_universes =
+ universes ~post:true ~doc:true ~packages:extended pkgs
+ in
+ Printf.eprintf "DEBUG: link_universes done (%d entries)\n%!"
+ (List.length link_universes);
let map_universes univs =
List.map
(fun (pkg, str, univ) ->
@@ -232,7 +239,8 @@ let main commit =
(* Test with fake packages - no git needed *)
let test_fake () =
(* Helper to create a simple opam with unfiltered depends *)
- let make_opam ?(depends = []) ?(doc_depends = []) ?(x_extra_doc_deps = []) () =
+ let make_opam ?(depends = []) ?(doc_depends = []) ?(x_extra_doc_deps = []) ()
+ =
let empty = OpamFile.OPAM.empty in
let mk_dep name =
let name = OpamPackage.Name.of_string name in
@@ -245,7 +253,9 @@ let test_fake () =
List.map
(fun name ->
let name = OpamPackage.Name.of_string name in
- let filter = OpamTypes.FIdent ([], OpamVariable.of_string "with-doc", None) in
+ let filter =
+ OpamTypes.FIdent ([], OpamVariable.of_string "with-doc", None)
+ in
OpamFormula.Atom (name, OpamFormula.Atom (OpamTypes.Filter filter)))
doc_depends
|> OpamFormula.ands
@@ -258,7 +268,10 @@ let test_fake () =
if x_extra_doc_deps = [] then opam
else
let ext_value =
- let deps_str = String.concat " & " (List.map (fun s -> "\"" ^ s ^ "\"") x_extra_doc_deps) in
+ let deps_str =
+ String.concat " & "
+ (List.map (fun s -> "\"" ^ s ^ "\"") x_extra_doc_deps)
+ in
OpamParser.FullPos.value_from_string deps_str "<test>"
in
let extensions =
@@ -295,19 +308,18 @@ let test_fake () =
("base", "2.0", make_opam ());
("doc-helper", "1.0", make_opam ());
("extra-helper", "1.0", make_opam ());
- ( "mylib", "1.0",
- make_opam
- ~depends:[ "base" ]
- ~doc_depends:[ "doc-helper" ]
- ~x_extra_doc_deps:[ "extra-helper" ]
- () );
+ ( "mylib",
+ "1.0",
+ make_opam ~depends:[ "base" ] ~doc_depends:[ "doc-helper" ]
+ ~x_extra_doc_deps:[ "extra-helper" ] () );
]
in
let constraints = OpamPackage.Name.Map.empty in
let root_pkgs = [ OpamPackage.Name.of_string "mylib" ] in
Printf.printf "=== Testing two-phase solve with fake packages ===\n%!";
- Printf.printf "Testing both {with-doc} filtered deps AND x-extra-doc-deps extension\n%!";
+ Printf.printf
+ "Testing both {with-doc} filtered deps AND x-extra-doc-deps extension\n%!";
(* First solve: no doc deps *)
let context =
@@ -318,7 +330,7 @@ let test_fake () =
| Error e ->
Printf.printf "First solve failed: %s\n" (Solver.diagnostics e);
exit 1
- | Ok sels ->
+ | Ok sels -> (
let pkgs = Solver.packages_of_result sels in
Printf.printf "\n[1] First solve (no with-doc deps):\n%!";
List.iter (fun p -> Printf.printf " %s\n" (OpamPackage.to_string p)) pkgs;
@@ -334,10 +346,13 @@ let test_fake () =
List.exists (fun p -> OpamPackage.name_to_string p = "doc-helper") pkgs
in
let has_extra_helper =
- List.exists (fun p -> OpamPackage.name_to_string p = "extra-helper") pkgs
+ List.exists
+ (fun p -> OpamPackage.name_to_string p = "extra-helper")
+ pkgs
in
if has_doc_helper || has_extra_helper then (
- Printf.printf "FAILURE: First solve should not include doc/extra helpers\n%!";
+ Printf.printf
+ "FAILURE: First solve should not include doc/extra helpers\n%!";
exit 1);
(* Use extended packages (processes x-extra-doc-deps) *)
@@ -361,21 +376,23 @@ let test_fake () =
~constraints ~pins ~doc:true
in
let extended_result = Solver.solve extended_context root_pkgs in
- (match extended_result with
+ match extended_result with
| Error e ->
- Printf.printf "Extended solve failed: %s\n%!"
- (Solver.diagnostics e);
+ Printf.printf "Extended solve failed: %s\n%!" (Solver.diagnostics e);
exit 1
| Ok extended_sels ->
let extended_pkgs = Solver.packages_of_result extended_sels in
- Printf.printf "\n[2] Extended solve (doc=true, post=true, with pins):\n%!";
+ Printf.printf
+ "\n[2] Extended solve (doc=true, post=true, with pins):\n%!";
List.iter
(fun p -> Printf.printf " %s\n" (OpamPackage.to_string p))
extended_pkgs;
(* Verify base version is still the same (pinned) *)
let extended_base_pkg =
- List.find (fun p -> OpamPackage.name_to_string p = "base") extended_pkgs
+ List.find
+ (fun p -> OpamPackage.name_to_string p = "base")
+ extended_pkgs
in
let base_version_preserved =
OpamPackage.Version.equal
@@ -392,16 +409,23 @@ let test_fake () =
extra;
let has_doc_helper =
- List.exists (fun p -> OpamPackage.name_to_string p = "doc-helper") extra
+ List.exists
+ (fun p -> OpamPackage.name_to_string p = "doc-helper")
+ extra
in
let has_extra_helper =
- List.exists (fun p -> OpamPackage.name_to_string p = "extra-helper") extra
+ List.exists
+ (fun p -> OpamPackage.name_to_string p = "extra-helper")
+ extra
in
Printf.printf "\n[4] Results:\n%!";
- Printf.printf " Base version preserved (pinning works): %b\n%!" base_version_preserved;
- Printf.printf " doc-helper added ({doc} filter works): %b\n%!" has_doc_helper;
- Printf.printf " extra-helper added (x-extra-doc-deps works): %b\n%!" has_extra_helper;
+ Printf.printf " Base version preserved (pinning works): %b\n%!"
+ base_version_preserved;
+ Printf.printf " doc-helper added ({doc} filter works): %b\n%!"
+ has_doc_helper;
+ Printf.printf " extra-helper added (x-extra-doc-deps works): %b\n%!"
+ has_extra_helper;
if base_version_preserved && has_doc_helper && has_extra_helper then (
Printf.printf "\nSUCCESS: Both mechanisms work!\n%!";
@@ -435,9 +459,7 @@ let test_real repo_path =
(OpamPackage.Name.Map.cardinal packages);
(* Test with odoc.3.1.0 which has x-extra-doc-deps *)
- let root_pkgs =
- List.map OpamPackage.Name.of_string [ "odoc" ]
- in
+ let root_pkgs = List.map OpamPackage.Name.of_string [ "odoc" ] in
let constraints =
[ ("odoc", `Eq, "3.1.0"); ("ocaml", `Geq, "5.2.0") ]
|> List.map (fun (name, rel, version) ->
@@ -468,7 +490,9 @@ let test_real repo_path =
result.compile_universes
in
let link_pkgs =
- List.find_opt (fun (name, _, _) -> name = "odoc.3.1.0") result.link_universes
+ List.find_opt
+ (fun (name, _, _) -> name = "odoc.3.1.0")
+ result.link_universes
in
(match compile_pkgs with
| Some (_, _, deps) ->
@@ -492,17 +516,31 @@ let test_real repo_path =
let extra_in_link =
List.filter
(fun name ->
- List.exists (fun dep -> String.sub dep 0 (min (String.length name) (String.length dep)) = name) link_deps
- && not (List.exists (fun dep -> String.sub dep 0 (min (String.length name) (String.length dep)) = name) compile_deps))
+ List.exists
+ (fun dep ->
+ String.sub dep 0 (min (String.length name) (String.length dep))
+ = name)
+ link_deps
+ && not
+ (List.exists
+ (fun dep ->
+ String.sub dep 0
+ (min (String.length name) (String.length dep))
+ = name)
+ compile_deps))
expected_extra
in
- Printf.printf "\nExtra packages in link but not compile (from x-extra-doc-deps):\n%!";
+ Printf.printf
+ "\nExtra packages in link but not compile (from x-extra-doc-deps):\n%!";
List.iter (fun p -> Printf.printf " %s\n%!" p) extra_in_link;
if List.length extra_in_link >= 2 then (
- Printf.printf "\nSUCCESS: x-extra-doc-deps packages found in link universe!\n%!";
+ Printf.printf
+ "\nSUCCESS: x-extra-doc-deps packages found in link universe!\n%!";
exit 0)
else (
- Printf.printf "\nNote: Some x-extra-doc-deps packages may not be available.\n%!";
- Printf.printf "Check if odoc-driver, sherlodoc, odig exist in the repo.\n%!";
+ Printf.printf
+ "\nNote: Some x-extra-doc-deps packages may not be available.\n%!";
+ Printf.printf
+ "Check if odoc-driver, sherlodoc, odig exist in the repo.\n%!";
exit 0)
File "src/solver/solver.mli", line 1, characters 0-0:
diff --git a/_build/default/src/solver/solver.mli b/_build/default/src/solver/.formatted/solver.mli
index 14734ad..a9f7034 100644
--- a/_build/default/src/solver/solver.mli
+++ b/_build/default/src/solver/.formatted/solver.mli
@@ -11,7 +11,8 @@ val test_fake : unit -> unit
(** [test_fake ()] runs a test with fake packages, no git needed. *)
val test_real : string -> unit
-(** [test_real repo_path] runs a test with the real opam-repository at [repo_path]. *)
+(** [test_real repo_path] runs a test with the real opam-repository at
+ [repo_path]. *)
val main : Git_unix.Store.Hash.t -> unit
(** [main hash] runs a worker process that reads requests from stdin and writes
File "day11/test_util/test_util.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/test_util/test_util.ml b/_build/default/day11/test_util/.formatted/test_util.ml
index 4a40204..78b2cf2 100644
--- a/_build/default/day11/test_util/test_util.ml
+++ b/_build/default/day11/test_util/.formatted/test_util.ml
@@ -1,37 +1,31 @@
let with_tmp_dir f =
let dir = Bos.OS.Dir.tmp "day11_test_%s" |> Result.get_ok in
- Fun.protect ~finally:(fun () ->
- Bos.OS.Dir.delete ~recurse:true dir |> ignore)
+ Fun.protect
+ ~finally:(fun () -> Bos.OS.Dir.delete ~recurse:true dir |> ignore)
(fun () -> f dir)
let with_eio f =
Eio_main.run @@ fun env ->
- Eio.Switch.run @@ fun sw ->
- f ~sw (env :> Eio_unix.Stdenv.base)
+ Eio.Switch.run @@ fun sw -> f ~sw (env :> Eio_unix.Stdenv.base)
let ok_or_fail msg = function
| Ok v -> v
| Error (`Msg e) -> Alcotest.fail (msg ^ ": " ^ e)
-let mkdir path =
- Bos.OS.Dir.create ~path:true path |> Result.get_ok |> ignore
-
-let write_file path contents =
- Bos.OS.File.write path contents |> Result.get_ok
+let mkdir path = Bos.OS.Dir.create ~path:true path |> Result.get_ok |> ignore
+let write_file path contents = Bos.OS.File.write path contents |> Result.get_ok
let is_integration () =
- try Sys.getenv "DAY11_INTEGRATION" = "true"
- with Not_found -> false
+ try Sys.getenv "DAY11_INTEGRATION" = "true" with Not_found -> false
-let sudo_available () =
- Sys.command "sudo -n true >/dev/null 2>&1" = 0
+let sudo_available () = Sys.command "sudo -n true >/dev/null 2>&1" = 0
let opam_repository () =
match Sys.getenv_opt "OPAM_REPOSITORY" with
| Some path when Sys.file_exists path -> path
| Some path ->
- Printf.printf "OPAM_REPOSITORY=%s does not exist\n%!" path;
- Alcotest.skip ()
+ Printf.printf "OPAM_REPOSITORY=%s does not exist\n%!" path;
+ Alcotest.skip ()
| None ->
- Printf.printf "OPAM_REPOSITORY not set\n%!";
- Alcotest.skip ()
+ Printf.printf "OPAM_REPOSITORY not set\n%!";
+ Alcotest.skip ()
File "day11/test_util/test_util.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/test_util/test_util.mli b/_build/default/day11/test_util/.formatted/test_util.mli
index a921855..f3e9663 100644
--- a/_build/default/day11/test_util/test_util.mli
+++ b/_build/default/day11/test_util/.formatted/test_util.mli
@@ -1,12 +1,12 @@
(** Shared test helpers for day11 test suites. *)
val with_tmp_dir : (Fpath.t -> 'a) -> 'a
-(** [with_tmp_dir f] creates a temporary directory, calls [f dir],
- then removes the directory. *)
+(** [with_tmp_dir f] creates a temporary directory, calls [f dir], then removes
+ the directory. *)
val with_eio : (sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> 'a) -> 'a
-(** [with_eio f] runs [f] inside an Eio event loop, opening a root
- switch to which long-running resources can be attached. *)
+(** [with_eio f] runs [f] inside an Eio event loop, opening a root switch to
+ which long-running resources can be attached. *)
val ok_or_fail : string -> ('a, [< `Msg of string ]) result -> 'a
(** [ok_or_fail msg r] extracts [Ok v] or calls [Alcotest.fail]. *)
@@ -21,10 +21,10 @@ val is_integration : unit -> bool
(** Returns [true] if [DAY11_INTEGRATION=true] is set. *)
val sudo_available : unit -> bool
-(** Returns [true] if [sudo -n true] succeeds — i.e. the test process
- can run sudo without prompting for a password. Use to gate tests
- that require privileged execution. *)
+(** Returns [true] if [sudo -n true] succeeds — i.e. the test process can run
+ sudo without prompting for a password. Use to gate tests that require
+ privileged execution. *)
val opam_repository : unit -> string
-(** Returns the path to the opam-repository from [OPAM_REPOSITORY]
- environment variable. Calls [Alcotest.skip] if not set. *)
+(** Returns the path to the opam-repository from [OPAM_REPOSITORY] environment
+ variable. Calls [Alcotest.skip] if not set. *)
File "day11/opam/git_packages.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam/git_packages.ml b/_build/default/day11/opam/.formatted/git_packages.ml
index ced0642..9a63156 100644
--- a/_build/default/day11/opam/git_packages.ml
+++ b/_build/default/day11/opam/.formatted/git_packages.ml
@@ -8,8 +8,7 @@ let empty = OpamPackage.Name.Map.empty
let read_dir store hash =
Store.read store hash >|= function
- | Error e ->
- Fmt.failwith "Failed to read tree: %a" Store.pp_error e
+ | Error e -> Fmt.failwith "Failed to read tree: %a" Store.pp_error e
| Ok (Git.Value.Tree tree) -> Some tree
| Ok _ -> None
@@ -22,18 +21,19 @@ let read_package store pkg hash =
Search.find store hash (`Path [ "opam" ]) >>= function
| None ->
Fmt.failwith "opam file not found for %s" (OpamPackage.to_string pkg)
- | Some hash ->
+ | Some hash -> (
Store.read store hash >|= function
- | Ok (Git.Value.Blob blob) ->
- (try
+ | Ok (Git.Value.Blob blob) -> (
+ try
let opam_content = Store.Value.Blob.to_string blob in
load_opam_from_string pkg opam_content
with ex ->
Fmt.failwith "Error parsing %s: %s"
- (OpamPackage.to_string pkg) (Printexc.to_string ex))
+ (OpamPackage.to_string pkg)
+ (Printexc.to_string ex))
| _ ->
- Fmt.failwith "Bad Git object type for %s!"
- (OpamPackage.to_string pkg)
+ Fmt.failwith "Bad Git object type for %s!" (OpamPackage.to_string pkg)
+ )
let read_versions_lwt store (entry : Store.Value.Tree.entry) =
read_dir store entry.node >>= function
@@ -49,8 +49,7 @@ let read_versions_lwt store (entry : Store.Value.Tree.entry) =
read_package store pkg entry.node >|= fun opam ->
OpamPackage.Version.Map.add pkg.version opam acc)
(fun _exn -> Lwt.return acc)
- | None ->
- Lwt.return acc)
+ | None -> Lwt.return acc)
OpamPackage.Version.Map.empty
let read_packages_eager ~store tree =
@@ -63,10 +62,10 @@ let read_packages_eager ~store tree =
Some (name, versions))
let overlay v1 v2 =
- lazy (
- let v1 = Lazy.force v1 in
- let v2 = Lazy.force v2 in
- OpamPackage.Version.Map.union (fun _ v2 -> v2) v1 v2)
+ lazy
+ (let v1 = Lazy.force v1 in
+ let v2 = Lazy.force v2 in
+ OpamPackage.Version.Map.union (fun _ v2 -> v2) v1 v2)
(* Eager version: force all version maps inside the Lwt event loop
before wrapping in [Lazy.t]. When the resulting [t] is later
@@ -76,78 +75,77 @@ let overlay v1 v2 =
let of_commit_lwt ?(super = empty) store commit : t Lwt.t =
Search.find store commit (`Commit (`Path [ "packages" ])) >>= function
| None -> Fmt.failwith "Failed to find packages directory!"
- | Some tree_hash ->
+ | Some tree_hash -> (
read_dir store tree_hash >>= function
| None -> Fmt.failwith "'packages' is not a directory!"
| Some tree ->
let entries = read_packages_eager ~store tree in
- Lwt_list.map_s (fun (name, versions_lwt) ->
- versions_lwt >|= fun versions ->
- (name, lazy versions)
- ) entries >|= fun resolved ->
+ Lwt_list.map_s
+ (fun (name, versions_lwt) ->
+ versions_lwt >|= fun versions -> (name, lazy versions))
+ entries
+ >|= fun resolved ->
let packages = OpamPackage.Name.Map.of_list resolved in
- OpamPackage.Name.Map.union overlay super packages
+ OpamPackage.Name.Map.union overlay super packages)
let of_commit ?(super = empty) store commit : t =
Lwt_main.run (of_commit_lwt ~super store commit)
let of_commit_eager store commit : t =
- Lwt_main.run @@
- (Search.find store commit (`Commit (`Path [ "packages" ])) >>= function
- | None -> Fmt.failwith "Failed to find packages directory!"
- | Some tree_hash ->
- read_dir store tree_hash >>= function
- | None -> Fmt.failwith "'packages' is not a directory!"
- | Some tree ->
- let entries = read_packages_eager ~store tree in
- Lwt_list.map_s (fun (name, versions_lwt) ->
- versions_lwt >|= fun versions ->
- (name, lazy versions)
- ) entries >|= fun resolved ->
- OpamPackage.Name.Map.of_list resolved)
+ Lwt_main.run
+ @@ ( Search.find store commit (`Commit (`Path [ "packages" ])) >>= function
+ | None -> Fmt.failwith "Failed to find packages directory!"
+ | Some tree_hash -> (
+ read_dir store tree_hash >>= function
+ | None -> Fmt.failwith "'packages' is not a directory!"
+ | Some tree ->
+ let entries = read_packages_eager ~store tree in
+ Lwt_list.map_s
+ (fun (name, versions_lwt) ->
+ versions_lwt >|= fun versions -> (name, lazy versions))
+ entries
+ >|= fun resolved -> OpamPackage.Name.Map.of_list resolved) )
let of_opam_repository repo_path =
- let store, commit =
- Git_utils.get_git_repo_store_and_hash repo_path in
+ let store, commit = Git_utils.get_git_repo_store_and_hash repo_path in
let packages = of_commit store commit in
(packages, store, commit)
let of_repositories_lwt repos =
assert (repos <> []);
- Lwt_list.map_s (fun (repo_path, commit_opt) ->
- Git_utils.get_git_repo_store_and_hash_lwt repo_path
- >>= fun (store, head) ->
- (match commit_opt with
- | Some sha ->
- Git_utils.resolve_commit_in_store_lwt store (Some sha)
- | None -> Lwt.return head)
- >|= fun commit -> (repo_path, store, commit)
- ) repos
+ Lwt_list.map_s
+ (fun (repo_path, commit_opt) ->
+ Git_utils.get_git_repo_store_and_hash_lwt repo_path
+ >>= fun (store, head) ->
+ (match commit_opt with
+ | Some sha -> Git_utils.resolve_commit_in_store_lwt store (Some sha)
+ | None -> Lwt.return head)
+ >|= fun commit -> (repo_path, store, commit))
+ repos
>>= fun stores_and_commits ->
- Lwt_list.fold_left_s (fun super (_, store, commit) ->
- of_commit_lwt ~super store commit
- ) empty stores_and_commits
+ Lwt_list.fold_left_s
+ (fun super (_, store, commit) -> of_commit_lwt ~super store commit)
+ empty stores_and_commits
>|= fun packages ->
- let repos_with_shas = List.map (fun (repo_path, _store, commit) ->
- (repo_path, Store.Hash.to_hex commit)
- ) stores_and_commits in
+ let repos_with_shas =
+ List.map
+ (fun (repo_path, _store, commit) -> (repo_path, Store.Hash.to_hex commit))
+ stores_and_commits
+ in
(packages, repos_with_shas)
-let of_repositories repos =
- Lwt_main.run (of_repositories_lwt repos)
+let of_repositories repos = Lwt_main.run (of_repositories_lwt repos)
let force_all (t : t) =
- OpamPackage.Name.Map.iter (fun _name versions ->
- try ignore (Lazy.force versions)
- with _ -> ()
- ) t
+ OpamPackage.Name.Map.iter
+ (fun _name versions -> try ignore (Lazy.force versions) with _ -> ())
+ t
let get_versions (t : t) name =
match OpamPackage.Name.Map.find_opt name t with
| None -> OpamPackage.Version.Map.empty
- | Some versions ->
- try Lazy.force versions
- with _ -> OpamPackage.Version.Map.empty
+ | Some versions -> (
+ try Lazy.force versions with _ -> OpamPackage.Version.Map.empty)
let get_package (t : t) pkg =
let versions = get_versions t (OpamPackage.name pkg) in
@@ -161,33 +159,38 @@ let all_names (t : t) =
OpamPackage.Name.Map.fold (fun name _ acc -> name :: acc) t []
let diff_packages ~store commit1 commit2 =
- Lwt_main.run @@
- (Search.find store commit1 (`Commit (`Path [ "packages" ])) >>= function
- | None -> Fmt.failwith "Failed to find packages directory in commit1"
- | Some tree1_hash ->
- read_dir store tree1_hash >>= function
- | None -> Fmt.failwith "'packages' is not a directory in commit1"
- | Some tree1 ->
- Search.find store commit2 (`Commit (`Path [ "packages" ])) >>= function
- | None ->
- Fmt.failwith "Failed to find packages directory in commit2"
- | Some tree2_hash ->
- read_dir store tree2_hash >>= function
- | None ->
- Fmt.failwith "'packages' is not a directory in commit2"
- | Some tree2 ->
- let tree1_list = Store.Value.Tree.to_list tree1 in
- let htbl = Hashtbl.create (List.length tree1_list) in
- let tree2_list = Store.Value.Tree.to_list tree2 in
- List.iter (fun (entry : Store.Value.Tree.entry) ->
- Hashtbl.add htbl entry.name entry) tree2_list;
- Lwt.return
- (List.fold_left
- (fun acc (entry : Store.Value.Tree.entry) ->
- match Hashtbl.find_opt htbl entry.name with
- | Some entry2 when entry.node = entry2.node -> acc
- | _ ->
- (match OpamPackage.Name.of_string entry.name with
- | exception _ -> acc
- | name -> name :: acc))
- [] tree1_list))
+ Lwt_main.run
+ @@ ( Search.find store commit1 (`Commit (`Path [ "packages" ])) >>= function
+ | None -> Fmt.failwith "Failed to find packages directory in commit1"
+ | Some tree1_hash -> (
+ read_dir store tree1_hash >>= function
+ | None -> Fmt.failwith "'packages' is not a directory in commit1"
+ | Some tree1 -> (
+ Search.find store commit2 (`Commit (`Path [ "packages" ]))
+ >>= function
+ | None ->
+ Fmt.failwith "Failed to find packages directory in commit2"
+ | Some tree2_hash -> (
+ read_dir store tree2_hash >>= function
+ | None ->
+ Fmt.failwith "'packages' is not a directory in commit2"
+ | Some tree2 ->
+ let tree1_list = Store.Value.Tree.to_list tree1 in
+ let htbl = Hashtbl.create (List.length tree1_list) in
+ let tree2_list = Store.Value.Tree.to_list tree2 in
+ List.iter
+ (fun (entry : Store.Value.Tree.entry) ->
+ Hashtbl.add htbl entry.name entry)
+ tree2_list;
+ Lwt.return
+ (List.fold_left
+ (fun acc (entry : Store.Value.Tree.entry) ->
+ match Hashtbl.find_opt htbl entry.name with
+ | Some entry2 when entry.node = entry2.node -> acc
+ | _ -> (
+ match
+ OpamPackage.Name.of_string entry.name
+ with
+ | exception _ -> acc
+ | name -> name :: acc))
+ [] tree1_list)))) )
File "day11/opam/git_packages.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam/git_packages.mli b/_build/default/day11/opam/.formatted/git_packages.mli
index c4368a0..acb7b7e 100644
--- a/_build/default/day11/opam/git_packages.mli
+++ b/_build/default/day11/opam/.formatted/git_packages.mli
@@ -1,8 +1,8 @@
(** Package index from git commits.
- Reads opam packages directly from git tree objects without needing
- a working tree checkout. Supports lazy loading (packages read on
- demand) and eager loading (all at once). *)
+ Reads opam packages directly from git tree objects without needing a working
+ tree checkout. Supports lazy loading (packages read on demand) and eager
+ loading (all at once). *)
module Store = Git_unix.Store
@@ -12,51 +12,48 @@ type t
val empty : t
val of_commit : ?super:t -> Store.t -> Store.Hash.t -> t
-(** [of_commit ?super store commit] builds a package index from the
- [packages/] tree at [commit]. If [super] is provided, packages
- from [super] are included as a base (overridden by [commit]). *)
+(** [of_commit ?super store commit] builds a package index from the [packages/]
+ tree at [commit]. If [super] is provided, packages from [super] are included
+ as a base (overridden by [commit]). *)
val of_commit_eager : Store.t -> Store.Hash.t -> t
-(** [of_commit_eager store commit] reads all packages eagerly within
- a single Lwt run. Safer for use with Domains. *)
+(** [of_commit_eager store commit] reads all packages eagerly within a single
+ Lwt run. Safer for use with Domains. *)
val of_opam_repository : string -> t * Store.t * Store.Hash.t
-(** [of_opam_repository repo_path] opens the repo, reads HEAD, and
- returns the package index along with the store and commit hash. *)
-
-val of_repositories : (string * string option) list ->
- t * (string * string) list
-(** [of_repositories repos] loads packages from multiple repositories.
- Each element is [(repo_path, commit_sha_opt)]. Repositories are
- layered in order — later repos override earlier ones.
- Returns the merged package index and a list of
- [(repo_path, commit_sha_hex)] pairs for passing to workers. *)
-
-val of_repositories_lwt : (string * string option) list ->
- (t * (string * string) list) Lwt.t
-(** Lwt-native version of {!of_repositories}. Use this when calling
- from inside an already-running Lwt event loop (e.g. an OCurrent
- Op) to avoid nested {!Lwt_main.run} errors. *)
+(** [of_opam_repository repo_path] opens the repo, reads HEAD, and returns the
+ package index along with the store and commit hash. *)
+
+val of_repositories :
+ (string * string option) list -> t * (string * string) list
+(** [of_repositories repos] loads packages from multiple repositories. Each
+ element is [(repo_path, commit_sha_opt)]. Repositories are layered in order
+ — later repos override earlier ones. Returns the merged package index and a
+ list of [(repo_path, commit_sha_hex)] pairs for passing to workers. *)
+
+val of_repositories_lwt :
+ (string * string option) list -> (t * (string * string) list) Lwt.t
+(** Lwt-native version of {!of_repositories}. Use this when calling from inside
+ an already-running Lwt event loop (e.g. an OCurrent Op) to avoid nested
+ {!Lwt_main.run} errors. *)
val force_all : t -> unit
-(** [force_all t] forces all lazy version maps. Call before using
- [t] from multiple domains. *)
+(** [force_all t] forces all lazy version maps. Call before using [t] from
+ multiple domains. *)
val get_versions :
- t -> OpamPackage.Name.t ->
- OpamFile.OPAM.t OpamPackage.Version.Map.t
+ t -> OpamPackage.Name.t -> OpamFile.OPAM.t OpamPackage.Version.Map.t
val get_package : t -> OpamPackage.t -> OpamFile.OPAM.t
val find_package : t -> OpamPackage.t -> OpamFile.OPAM.t option
-(** [find_package t pkg] returns [Some opam] if the package exists,
- [None] otherwise. *)
+(** [find_package t pkg] returns [Some opam] if the package exists, [None]
+ otherwise. *)
val all_names : t -> OpamPackage.Name.t list
(** [all_names t] returns all package names in the index. *)
val diff_packages :
- store:Store.t -> Store.Hash.t -> Store.Hash.t ->
- OpamPackage.Name.t list
-(** [diff_packages ~store commit1 commit2] returns package names
- whose tree objects differ between the two commits. *)
+ store:Store.t -> Store.Hash.t -> Store.Hash.t -> OpamPackage.Name.t list
+(** [diff_packages ~store commit1 commit2] returns package names whose tree
+ objects differ between the two commits. *)
File "day11/opam/git_utils.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam/git_utils.ml b/_build/default/day11/opam/.formatted/git_utils.ml
index 79738ba..3e24901 100644
--- a/_build/default/day11/opam/git_utils.ml
+++ b/_build/default/day11/opam/.formatted/git_utils.ml
@@ -4,29 +4,28 @@ module Store = Git_unix.Store
let get_git_repo_store_and_hash_commit_lwt repo_path commit_opt =
Store.v (Fpath.v repo_path) >>= function
| Error e ->
- Fmt.failwith "Failed to open git store at %s: %a"
- repo_path Store.pp_error e
+ Fmt.failwith "Failed to open git store at %s: %a" repo_path Store.pp_error
+ e
| Ok store ->
(match commit_opt with
- | Some commit_str ->
- let ref_name = Git.Reference.v commit_str in
- Store.Ref.resolve store ref_name >>= (function
- | Ok hash -> Lwt.return hash
- | Error _ ->
- (try
- let hash = Store.Hash.of_hex commit_str in
- Lwt.return hash
- with _ ->
- Fmt.failwith "Cannot resolve commit %s in %s"
- commit_str repo_path))
- | None ->
- Store.Ref.resolve store Git.Reference.head >>= function
- | Error e ->
- Fmt.failwith "Failed to resolve HEAD in %s: %a"
- repo_path Store.pp_error e
- | Ok hash -> Lwt.return hash)
- >>= fun hash ->
- Lwt.return (store, hash)
+ | Some commit_str -> (
+ let ref_name = Git.Reference.v commit_str in
+ Store.Ref.resolve store ref_name >>= function
+ | Ok hash -> Lwt.return hash
+ | Error _ -> (
+ try
+ let hash = Store.Hash.of_hex commit_str in
+ Lwt.return hash
+ with _ ->
+ Fmt.failwith "Cannot resolve commit %s in %s" commit_str
+ repo_path))
+ | None -> (
+ Store.Ref.resolve store Git.Reference.head >>= function
+ | Error e ->
+ Fmt.failwith "Failed to resolve HEAD in %s: %a" repo_path
+ Store.pp_error e
+ | Ok hash -> Lwt.return hash))
+ >>= fun hash -> Lwt.return (store, hash)
let get_git_repo_store_and_hash_commit repo_path commit_opt =
Lwt_main.run (get_git_repo_store_and_hash_commit_lwt repo_path commit_opt)
@@ -39,21 +38,19 @@ let get_git_repo_store_and_hash repo_path =
let resolve_commit_in_store_lwt store commit_opt =
match commit_opt with
- | Some commit_str ->
- let ref_name = Git.Reference.v commit_str in
- Store.Ref.resolve store ref_name >>= (function
- | Ok hash -> Lwt.return hash
- | Error _ ->
- (try
- let hash = Store.Hash.of_hex commit_str in
- Lwt.return hash
- with _ ->
- Fmt.failwith "Cannot resolve commit %s" commit_str))
- | None ->
- Store.Ref.resolve store Git.Reference.head >>= function
- | Error e ->
- Fmt.failwith "Failed to resolve HEAD: %a" Store.pp_error e
- | Ok hash -> Lwt.return hash
+ | Some commit_str -> (
+ let ref_name = Git.Reference.v commit_str in
+ Store.Ref.resolve store ref_name >>= function
+ | Ok hash -> Lwt.return hash
+ | Error _ -> (
+ try
+ let hash = Store.Hash.of_hex commit_str in
+ Lwt.return hash
+ with _ -> Fmt.failwith "Cannot resolve commit %s" commit_str))
+ | None -> (
+ Store.Ref.resolve store Git.Reference.head >>= function
+ | Error e -> Fmt.failwith "Failed to resolve HEAD: %a" Store.pp_error e
+ | Ok hash -> Lwt.return hash)
let resolve_commit_in_store store commit_opt =
Lwt_main.run (resolve_commit_in_store_lwt store commit_opt)
File "day11/opam/git_utils.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam/git_utils.mli b/_build/default/day11/opam/.formatted/git_utils.mli
index ae03fab..4db856b 100644
--- a/_build/default/day11/opam/git_utils.mli
+++ b/_build/default/day11/opam/.formatted/git_utils.mli
@@ -1,34 +1,30 @@
(** Git repository access.
- Opens git stores and resolves commits/refs. Uses Lwt internally
- but exposes a synchronous API. *)
+ Opens git stores and resolves commits/refs. Uses Lwt internally but exposes
+ a synchronous API. *)
module Store = Git_unix.Store
-val get_git_repo_store_and_hash :
- string -> Store.t * Store.Hash.t
-(** [get_git_repo_store_and_hash repo_path] opens the git store at
- [repo_path] and resolves HEAD to a commit hash. *)
+val get_git_repo_store_and_hash : string -> Store.t * Store.Hash.t
+(** [get_git_repo_store_and_hash repo_path] opens the git store at [repo_path]
+ and resolves HEAD to a commit hash. *)
val get_git_repo_store_and_hash_commit :
string -> string option -> Store.t * Store.Hash.t
-(** [get_git_repo_store_and_hash_commit repo_path commit_opt] opens the
- store and resolves [commit_opt] (a ref name or hex SHA). If [None],
- resolves HEAD. *)
+(** [get_git_repo_store_and_hash_commit repo_path commit_opt] opens the store
+ and resolves [commit_opt] (a ref name or hex SHA). If [None], resolves HEAD.
+*)
-val resolve_commit_in_store :
- Store.t -> string option -> Store.Hash.t
-(** [resolve_commit_in_store store commit_opt] resolves a commit ref
- or SHA in an already-opened store. *)
+val resolve_commit_in_store : Store.t -> string option -> Store.Hash.t
+(** [resolve_commit_in_store store commit_opt] resolves a commit ref or SHA in
+ an already-opened store. *)
-val get_git_repo_store_and_hash_lwt :
- string -> (Store.t * Store.Hash.t) Lwt.t
+val get_git_repo_store_and_hash_lwt : string -> (Store.t * Store.Hash.t) Lwt.t
(** Lwt-native version of {!get_git_repo_store_and_hash}. *)
val get_git_repo_store_and_hash_commit_lwt :
string -> string option -> (Store.t * Store.Hash.t) Lwt.t
(** Lwt-native version of {!get_git_repo_store_and_hash_commit}. *)
-val resolve_commit_in_store_lwt :
- Store.t -> string option -> Store.Hash.t Lwt.t
+val resolve_commit_in_store_lwt : Store.t -> string option -> Store.Hash.t Lwt.t
(** Lwt-native version of {!resolve_commit_in_store}. *)
File "day11/opam/opam_env.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam/opam_env.ml b/_build/default/day11/opam/.formatted/opam_env.ml
index 08cbe6e..270621b 100644
--- a/_build/default/day11/opam/opam_env.ml
+++ b/_build/default/day11/opam/.formatted/opam_env.ml
@@ -1,13 +1,14 @@
-let std_env ?(ocaml_native = true) ?sys_ocaml_version ?opam_version
- ~arch ~os ~os_distribution ~os_family ~os_version () = function
+let std_env ?(ocaml_native = true) ?sys_ocaml_version ?opam_version ~arch ~os
+ ~os_distribution ~os_family ~os_version () = function
| "arch" -> Some (OpamTypes.S arch)
| "os" -> Some (OpamTypes.S os)
| "os-distribution" -> Some (OpamTypes.S os_distribution)
| "os-version" -> Some (OpamTypes.S os_version)
| "os-family" -> Some (OpamTypes.S os_family)
| "opam-version" ->
- Some (OpamVariable.S
- (Option.value ~default:OpamVersion.(to_string current) opam_version))
+ Some
+ (OpamVariable.S
+ (Option.value ~default:OpamVersion.(to_string current) opam_version))
| "sys-ocaml-version" ->
sys_ocaml_version |> Option.map (fun v -> OpamTypes.S v)
| "ocaml:native" -> Some (OpamTypes.B ocaml_native)
File "day11/opam/opam_env.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam/opam_env.mli b/_build/default/day11/opam/.formatted/opam_env.mli
index 3ebfb37..f60c80c 100644
--- a/_build/default/day11/opam/opam_env.mli
+++ b/_build/default/day11/opam/.formatted/opam_env.mli
@@ -1,7 +1,7 @@
(** Opam variable environment for dependency filtering.
- Provides the environment function that the solver context uses
- to evaluate opam filter expressions. Pure — no I/O. *)
+ Provides the environment function that the solver context uses to evaluate
+ opam filter expressions. Pure — no I/O. *)
val std_env :
?ocaml_native:bool ->
@@ -15,8 +15,8 @@ val std_env :
unit ->
string ->
OpamVariable.variable_contents option
-(** [std_env ~arch ~os ~os_distribution ~os_family ~os_version ()]
- returns an environment function for system-level opam variables.
+(** [std_env ~arch ~os ~os_distribution ~os_family ~os_version ()] returns an
+ environment function for system-level opam variables.
Handles: [arch], [os], [os-distribution], [os-version], [os-family],
[opam-version], [sys-ocaml-version], [ocaml:native]. *)
File "day11/sys/atomic_swap.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/atomic_swap.ml b/_build/default/day11/sys/.formatted/atomic_swap.ml
index d7496bc..080d075 100644
--- a/_build/default/day11/sys/atomic_swap.ml
+++ b/_build/default/day11/sys/.formatted/atomic_swap.ml
@@ -1,4 +1,6 @@
-let src = Logs.Src.create "day11.sys.atomic_swap" ~doc:"Atomic directory replacement"
+let src =
+ Logs.Src.create "day11.sys.atomic_swap" ~doc:"Atomic directory replacement"
+
module Log = (val Logs.src_log src)
let staging_of target = Fpath.(target + ".new")
@@ -6,7 +8,7 @@ let old_of target = Fpath.(target + ".old")
let cleanup_stale ~sw env dir =
let rec walk d =
- if Bos.OS.Dir.exists d |> Result.get_ok then begin
+ if Bos.OS.Dir.exists d |> Result.get_ok then
let entries = Bos.OS.Dir.contents d |> Result.get_ok in
List.iter
(fun entry ->
@@ -15,13 +17,11 @@ let cleanup_stale ~sw env dir =
Astring.String.is_suffix ~affix:".new" name
|| Astring.String.is_suffix ~affix:".old" name
in
- if is_stale then begin
+ if is_stale then (
Log.info (fun m -> m "Removing stale dir: %a" Fpath.pp entry);
- Sudo.rm_rf ~sw env entry |> ignore
- end else if Bos.OS.Dir.exists entry |> Result.get_ok then
- walk entry)
+ Sudo.rm_rf ~sw env entry |> ignore)
+ else if Bos.OS.Dir.exists entry |> Result.get_ok then walk entry)
entries
- end
in
walk dir;
Ok ()
@@ -38,38 +38,35 @@ let prepare target =
let commit ~sw env target =
let staging = staging_of target in
let old = old_of target in
- if not (Bos.OS.Dir.exists staging |> Result.get_ok) then
- Ok false
- else begin
+ if not (Bos.OS.Dir.exists staging |> Result.get_ok) then Ok false
+ else
let has_existing = Bos.OS.Dir.exists target |> Result.get_ok in
- (try
- if has_existing then begin
- (* Remove any leftover .old *)
- if Bos.OS.Dir.exists old |> Result.get_ok then
- Sudo.rm_rf ~sw env old |> ignore;
- (* Move existing to .old *)
- Unix.rename (Fpath.to_string target) (Fpath.to_string old)
- end;
- (* Move staging to final *)
- Unix.rename (Fpath.to_string staging) (Fpath.to_string target);
- (* Remove .old backup *)
- if has_existing && (Bos.OS.Dir.exists old |> Result.get_ok) then
- Sudo.rm_rf ~sw env old |> ignore;
- Ok true
- with Unix.Unix_error (e, fn, arg) ->
- (* Try to restore *)
- (if has_existing && (Bos.OS.Dir.exists old |> Result.get_ok)
- && not (Bos.OS.Dir.exists target |> Result.get_ok) then
- try
- Unix.rename (Fpath.to_string old) (Fpath.to_string target)
- with _ -> ());
- Rresult.R.error_msgf "atomic_swap commit: %s(%s): %s"
- fn arg (Unix.error_message e))
- end
+ try
+ if has_existing then (
+ (* Remove any leftover .old *)
+ if Bos.OS.Dir.exists old |> Result.get_ok then
+ Sudo.rm_rf ~sw env old |> ignore;
+ (* Move existing to .old *)
+ Unix.rename (Fpath.to_string target) (Fpath.to_string old));
+ (* Move staging to final *)
+ Unix.rename (Fpath.to_string staging) (Fpath.to_string target);
+ (* Remove .old backup *)
+ if has_existing && Bos.OS.Dir.exists old |> Result.get_ok then
+ Sudo.rm_rf ~sw env old |> ignore;
+ Ok true
+ with Unix.Unix_error (e, fn, arg) ->
+ (* Try to restore *)
+ (if
+ has_existing
+ && Bos.OS.Dir.exists old |> Result.get_ok
+ && not (Bos.OS.Dir.exists target |> Result.get_ok)
+ then
+ try Unix.rename (Fpath.to_string old) (Fpath.to_string target)
+ with _ -> ());
+ Rresult.R.error_msgf "atomic_swap commit: %s(%s): %s" fn arg
+ (Unix.error_message e)
let rollback ~sw env target =
let staging = staging_of target in
- if Bos.OS.Dir.exists staging |> Result.get_ok then
- Sudo.rm_rf ~sw env staging
- else
- Ok ()
+ if Bos.OS.Dir.exists staging |> Result.get_ok then Sudo.rm_rf ~sw env staging
+ else Ok ()
File "day11/sys/atomic_swap.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/atomic_swap.mli b/_build/default/day11/sys/.formatted/atomic_swap.mli
index 61f0bb6..481304b 100644
--- a/_build/default/day11/sys/atomic_swap.mli
+++ b/_build/default/day11/sys/.formatted/atomic_swap.mli
@@ -1,20 +1,20 @@
(** Atomic directory replacement.
- Implements a staging/commit/rollback pattern for updating a
- directory without partial visibility. On commit, the sequence is:
+ Implements a staging/commit/rollback pattern for updating a directory
+ without partial visibility. On commit, the sequence is:
+ Rename existing final dir to [.old] backup
+ Rename staging dir to final location
+ Remove [.old] backup
- If the process crashes between steps, {!cleanup_stale} recovers on
- the next startup by removing orphaned [.new] and [.old] directories.
+ If the process crashes between steps, {!cleanup_stale} recovers on the next
+ startup by removing orphaned [.new] and [.old] directories.
- This module has no domain knowledge — the caller provides the
- target directory path directly.
+ This module has no domain knowledge — the caller provides the target
+ directory path directly.
- Several functions require [env] because they may need to remove
- root-owned directories via sudo. *)
+ Several functions require [env] because they may need to remove root-owned
+ directories via sudo. *)
val cleanup_stale :
sw:Eio.Switch.t ->
@@ -22,15 +22,14 @@ val cleanup_stale :
Fpath.t ->
(unit, [> Rresult.R.msg ]) result
(** [cleanup_stale ~sw env dir] recursively scans [dir] and removes any
- directories whose names end in [.new] or [.old] (leftovers from
- crashed swaps). Uses sudo for root-owned directories. *)
+ directories whose names end in [.new] or [.old] (leftovers from crashed
+ swaps). Uses sudo for root-owned directories. *)
-val prepare :
- Fpath.t -> (Fpath.t, [> Rresult.R.msg ]) result
-(** [prepare target] creates a staging directory at [target ^ ".new"]
- and returns its path. Removes any existing staging dir from a
- previous failed attempt. The caller writes content into the
- returned path, then calls {!commit} or {!rollback}. *)
+val prepare : Fpath.t -> (Fpath.t, [> Rresult.R.msg ]) result
+(** [prepare target] creates a staging directory at [target ^ ".new"] and
+ returns its path. Removes any existing staging dir from a previous failed
+ attempt. The caller writes content into the returned path, then calls
+ {!commit} or {!rollback}. *)
val commit :
sw:Eio.Switch.t ->
@@ -38,15 +37,14 @@ val commit :
Fpath.t ->
(bool, [> Rresult.R.msg ]) result
(** [commit ~sw env target] atomically swaps the staging directory
- ([target ^ ".new"]) into [target]. Returns [Ok true] if the swap
- succeeded, [Ok false] if there was no staging directory. On
- failure, attempts to restore the previous state. Uses sudo to
- remove the old directory. *)
+ ([target ^ ".new"]) into [target]. Returns [Ok true] if the swap succeeded,
+ [Ok false] if there was no staging directory. On failure, attempts to
+ restore the previous state. Uses sudo to remove the old directory. *)
val rollback :
sw:Eio.Switch.t ->
Eio_unix.Stdenv.base ->
Fpath.t ->
(unit, [> Rresult.R.msg ]) result
-(** [rollback ~sw env target] removes the staging directory
- ([target ^ ".new"]) without committing. Uses sudo if needed. *)
+(** [rollback ~sw env target] removes the staging directory ([target ^ ".new"])
+ without committing. Uses sudo if needed. *)
File "day11/sys/dir_lock.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/dir_lock.ml b/_build/default/day11/sys/.formatted/dir_lock.ml
index 208183d..dfe40f3 100644
--- a/_build/default/day11/sys/dir_lock.ml
+++ b/_build/default/day11/sys/.formatted/dir_lock.ml
@@ -1,4 +1,5 @@
let src = Logs.Src.create "day11.sys.dir_lock" ~doc:"Directory-level locking"
+
module Log = (val Logs.src_log src)
(* Intra-process mutex table. Since Eio is cooperative, hashtable access
@@ -13,94 +14,91 @@ let get_mutex key =
Hashtbl.replace mutex_table key m;
m
-let default_lock_file dir_path =
- Fpath.(dir_path + ".lock")
+let default_lock_file dir_path = Fpath.(dir_path + ".lock")
let with_lock ?marker_file ?lock_file dir_path body =
(* Check marker file first — if it exists, skip entirely *)
(match marker_file with
| Some marker ->
let marker_path = Fpath.(dir_path // marker) in
- if Bos.OS.File.exists marker_path |> Result.get_ok then begin
- Log.debug (fun m ->
- m "Marker %a exists, skipping" Fpath.pp marker_path);
- Ok () |> fun r -> r
- end else
- Error `Continue
+ if Bos.OS.File.exists marker_path |> Result.get_ok then (
+ Log.debug (fun m -> m "Marker %a exists, skipping" Fpath.pp marker_path);
+ Ok () |> fun r -> r)
+ else Error `Continue
| None -> Error `Continue)
|> function
| Ok () -> Ok ()
| Error `Continue ->
- let lock_file =
- match lock_file with
- | Some f -> f
- | None -> default_lock_file dir_path
- in
- let lock_file_s = Fpath.to_string lock_file in
- (* Acquire intra-process Eio mutex *)
- let eio_mutex = get_mutex lock_file_s in
- Eio.Mutex.lock eio_mutex;
- Fun.protect ~finally:(fun () -> Eio.Mutex.unlock eio_mutex) (fun () ->
- (* Re-check marker after acquiring mutex — another fiber may have
- completed while we waited *)
- (match marker_file with
- | Some marker ->
- let marker_path = Fpath.(dir_path // marker) in
- if Bos.OS.File.exists marker_path |> Result.get_ok then begin
- Log.debug (fun m ->
- m "Marker %a appeared while waiting for lock"
- Fpath.pp marker_path);
- Ok () |> fun r -> r
- end else
- Error `Continue
- | None -> Error `Continue)
- |> function
- | Ok () -> Ok ()
- | Error `Continue ->
- (* Ensure parent directory of lock file exists *)
- Bos.OS.Dir.create ~path:true (Fpath.parent lock_file) |> ignore;
- (* Acquire cross-process file lock *)
- let lock_fd =
- Unix.openfile lock_file_s [ Unix.O_CREAT; Unix.O_RDWR ] 0o644
- in
- Fun.protect ~finally:(fun () -> Unix.close lock_fd) (fun () ->
- let got_immediately =
- try Unix.lockf lock_fd Unix.F_TLOCK 0; true
- with Unix.Unix_error ((Unix.EAGAIN | Unix.EACCES), _, _) -> false
+ let lock_file =
+ match lock_file with Some f -> f | None -> default_lock_file dir_path
in
- if not got_immediately then begin
- Log.info (fun m ->
- m "Waiting for lock: %a" Fpath.pp dir_path);
- let rec lock_retry () =
- try Unix.lockf lock_fd Unix.F_LOCK 0
- with Unix.Unix_error (Unix.EINTR, _, _) -> lock_retry ()
- in
- lock_retry ();
- Log.info (fun m ->
- m "Acquired lock: %a" Fpath.pp dir_path)
- end;
- (* Write metadata: PID and timestamp *)
- let set_temp_log_path log_path =
- let metadata =
- Printf.sprintf "%d\n%.0f\n%s\n"
- (Unix.getpid ()) (Unix.time ())
- (Fpath.to_string log_path)
- in
- ignore (Unix.lseek lock_fd 0 Unix.SEEK_SET);
- ignore (Unix.ftruncate lock_fd 0);
- let bytes = Bytes.of_string metadata in
- ignore (Unix.write lock_fd bytes 0 (Bytes.length bytes))
- in
- (* Re-check marker after file lock *)
- (match marker_file with
- | Some marker ->
- let marker_path = Fpath.(dir_path // marker) in
- if Bos.OS.File.exists marker_path |> Result.get_ok then begin
- Log.debug (fun m ->
- m "Marker %a appeared while waiting for file lock"
- Fpath.pp marker_path);
- Ok ()
- end else
- body ~set_temp_log_path dir_path
- | None ->
- body ~set_temp_log_path dir_path)))
+ let lock_file_s = Fpath.to_string lock_file in
+ (* Acquire intra-process Eio mutex *)
+ let eio_mutex = get_mutex lock_file_s in
+ Eio.Mutex.lock eio_mutex;
+ Fun.protect
+ ~finally:(fun () -> Eio.Mutex.unlock eio_mutex)
+ (fun () ->
+ (* Re-check marker after acquiring mutex — another fiber may have
+ completed while we waited *)
+ (match marker_file with
+ | Some marker ->
+ let marker_path = Fpath.(dir_path // marker) in
+ if Bos.OS.File.exists marker_path |> Result.get_ok then (
+ Log.debug (fun m ->
+ m "Marker %a appeared while waiting for lock" Fpath.pp
+ marker_path);
+ Ok () |> fun r -> r)
+ else Error `Continue
+ | None -> Error `Continue)
+ |> function
+ | Ok () -> Ok ()
+ | Error `Continue ->
+ (* Ensure parent directory of lock file exists *)
+ Bos.OS.Dir.create ~path:true (Fpath.parent lock_file) |> ignore;
+ (* Acquire cross-process file lock *)
+ let lock_fd =
+ Unix.openfile lock_file_s [ Unix.O_CREAT; Unix.O_RDWR ] 0o644
+ in
+ Fun.protect
+ ~finally:(fun () -> Unix.close lock_fd)
+ (fun () ->
+ let got_immediately =
+ try
+ Unix.lockf lock_fd Unix.F_TLOCK 0;
+ true
+ with
+ | Unix.Unix_error ((Unix.EAGAIN | Unix.EACCES), _, _) ->
+ false
+ in
+ if not got_immediately then (
+ Log.info (fun m ->
+ m "Waiting for lock: %a" Fpath.pp dir_path);
+ let rec lock_retry () =
+ try Unix.lockf lock_fd Unix.F_LOCK 0
+ with Unix.Unix_error (Unix.EINTR, _, _) -> lock_retry ()
+ in
+ lock_retry ();
+ Log.info (fun m -> m "Acquired lock: %a" Fpath.pp dir_path));
+ (* Write metadata: PID and timestamp *)
+ let set_temp_log_path log_path =
+ let metadata =
+ Printf.sprintf "%d\n%.0f\n%s\n" (Unix.getpid ())
+ (Unix.time ()) (Fpath.to_string log_path)
+ in
+ ignore (Unix.lseek lock_fd 0 Unix.SEEK_SET);
+ ignore (Unix.ftruncate lock_fd 0);
+ let bytes = Bytes.of_string metadata in
+ ignore (Unix.write lock_fd bytes 0 (Bytes.length bytes))
+ in
+ (* Re-check marker after file lock *)
+ match marker_file with
+ | Some marker ->
+ let marker_path = Fpath.(dir_path // marker) in
+ if Bos.OS.File.exists marker_path |> Result.get_ok then (
+ Log.debug (fun m ->
+ m "Marker %a appeared while waiting for file lock"
+ Fpath.pp marker_path);
+ Ok ())
+ else body ~set_temp_log_path dir_path
+ | None -> body ~set_temp_log_path dir_path))
File "day11/sys/dir_lock.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/dir_lock.mli b/_build/default/day11/sys/.formatted/dir_lock.mli
index f751e5d..4f7dab3 100644
--- a/_build/default/day11/sys/dir_lock.mli
+++ b/_build/default/day11/sys/.formatted/dir_lock.mli
@@ -1,41 +1,44 @@
(** Directory-level locking.
- Provides mutual exclusion for directory construction. Uses a
- dual-layer locking strategy:
+ Provides mutual exclusion for directory construction. Uses a dual-layer
+ locking strategy:
- {b Intra-process (Eio fibers):} an in-memory mutex table keyed by lock
path, so fibers within the same process serialize correctly.
- - {b Cross-process:} POSIX [lockf] on a lock file, for the case where
- two separate processes share the same directory.
+ - {b Cross-process:} POSIX [lockf] on a lock file, for the case where two
+ separate processes share the same directory.
- This dual-layer approach is necessary because POSIX [lockf] is keyed
- by [(inode, pid)] — two fibers in the same process share a PID and
- would not block each other.
+ This dual-layer approach is necessary because POSIX [lockf] is keyed by
+ [(inode, pid)] — two fibers in the same process share a PID and would not
+ block each other.
- This module has no domain knowledge — the caller determines where
- the lock file lives and what the marker file is called. *)
+ This module has no domain knowledge — the caller determines where the lock
+ file lives and what the marker file is called. *)
val with_lock :
?marker_file:Fpath.t ->
?lock_file:Fpath.t ->
Fpath.t ->
- (set_temp_log_path:(Fpath.t -> unit) -> Fpath.t -> (unit, [ `Msg of string ]) result) ->
+ (set_temp_log_path:(Fpath.t -> unit) ->
+ Fpath.t ->
+ (unit, [ `Msg of string ]) result) ->
(unit, [ `Msg of string ]) result
-(** [with_lock ?marker_file ?lock_file dir_path body] acquires the lock
- for [dir_path], then calls [body ~set_temp_log_path dir_path].
+(** [with_lock ?marker_file ?lock_file dir_path body] acquires the lock for
+ [dir_path], then calls [body ~set_temp_log_path dir_path].
- @param marker_file If provided and already exists at
- [Fpath.(dir_path // marker_file)], the body is skipped — another
- worker already completed this directory.
+ @param marker_file
+ If provided and already exists at [Fpath.(dir_path // marker_file)], the
+ body is skipped — another worker already completed this directory.
- @param lock_file The path to the lock file. If not provided,
- defaults to [Fpath.(dir_path + ".lock")]. The caller is responsible
- for choosing a meaningful path (e.g. under a central [locks/]
- directory with a descriptive name).
+ @param lock_file
+ The path to the lock file. If not provided, defaults to
+ [Fpath.(dir_path + ".lock")]. The caller is responsible for choosing a
+ meaningful path (e.g. under a central [locks/] directory with a
+ descriptive name).
- The [set_temp_log_path] callback updates the lock file metadata with
- the current temp log path, for monitoring by external tools. The
- lock file also records the PID and timestamp.
+ The [set_temp_log_path] callback updates the lock file metadata with the
+ current temp log path, for monitoring by external tools. The lock file also
+ records the PID and timestamp.
- The lock is released when [body] returns or raises — even on
- exceptions, the lock file is cleaned up. *)
+ The lock is released when [body] returns or raises — even on exceptions, the
+ lock file is cleaned up. *)
File "day11/sys/fork_client.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/fork_client.ml b/_build/default/day11/sys/.formatted/fork_client.ml
index 4df537a..1b2f2c8 100644
--- a/_build/default/day11/sys/fork_client.ml
+++ b/_build/default/day11/sys/.formatted/fork_client.ml
@@ -5,27 +5,21 @@
copying). The helper is a few MB, so its forks are sub-millisecond. *)
let src = Logs.Src.create "day11.sys.fork_client" ~doc:"Fork helper client"
+
module Log = (val Logs.src_log src)
-type t = {
- sock_path : string;
- pid : int;
-}
+type t = { sock_path : string; pid : int }
(* ── Protocol I/O on Eio buffered flows ─────────────────────────── *)
-let write_u32 w n =
- Eio.Buf_write.BE.uint32 w (Int32.of_int n)
-
+let write_u32 w n = Eio.Buf_write.BE.uint32 w (Int32.of_int n)
let write_u8 w n = Eio.Buf_write.uint8 w n
let write_str w s =
write_u32 w (String.length s);
Eio.Buf_write.string w s
-let read_u32 r =
- Eio.Buf_read.BE.uint32 r |> Int32.to_int
-
+let read_u32 r = Eio.Buf_read.BE.uint32 r |> Int32.to_int
let read_u8 r = Eio.Buf_read.uint8 r
let read_str r =
@@ -35,15 +29,16 @@ let read_str r =
(* ── Helper daemon lifecycle ────────────────────────────────────── *)
let start () =
- let sock_path = Filename.concat
- (Filename.get_temp_dir_name ())
- (Printf.sprintf "day11-fork-%d.sock" (Unix.getpid ())) in
+ let sock_path =
+ Filename.concat
+ (Filename.get_temp_dir_name ())
+ (Printf.sprintf "day11-fork-%d.sock" (Unix.getpid ()))
+ in
let helper_bin =
(* Look for the helper binary next to the main binary, or in PATH *)
let dir = Filename.dirname Sys.executable_name in
let candidate = Filename.concat dir "day11-fork-helper" in
- if Sys.file_exists candidate then candidate
- else "day11-fork-helper"
+ if Sys.file_exists candidate then candidate else "day11-fork-helper"
in
(* [sock_path] is derived from our pid, which the OS reuses across
runs. With a persistent TMPDIR (a real fs, as the daemon now
@@ -55,19 +50,19 @@ let start () =
here belongs to a dead one. *)
(try Unix.unlink sock_path with _ -> ());
Log.info (fun m -> m "Starting fork helper: %s %s" helper_bin sock_path);
- let pid = Unix.create_process helper_bin
- [| helper_bin; sock_path |]
- Unix.stdin Unix.stdout Unix.stderr in
+ let pid =
+ Unix.create_process helper_bin
+ [| helper_bin; sock_path |]
+ Unix.stdin Unix.stdout Unix.stderr
+ in
(* Wait for socket to appear. One-shot startup, before the Eio loop
does anything interesting — Unix.sleepf is fine here. *)
let rec wait_sock n =
- if n <= 0 then
- failwith "fork helper: socket did not appear"
+ if n <= 0 then failwith "fork helper: socket did not appear"
else if Sys.file_exists sock_path then ()
- else begin
+ else (
Unix.sleepf 0.01;
- wait_sock (n - 1)
- end
+ wait_sock (n - 1))
in
wait_sock 100;
Log.info (fun m -> m "Fork helper running (pid %d)" pid);
@@ -76,7 +71,7 @@ let start () =
let stop t =
(try Unix.kill t.pid Sys.sigterm with _ -> ());
(try ignore (Unix.waitpid [] t.pid) with _ -> ());
- (try Unix.unlink t.sock_path with _ -> ())
+ try Unix.unlink t.sock_path with _ -> ()
(* ── Spawn over the Unix socket ─────────────────────────────────── *)
@@ -95,53 +90,52 @@ let spawn ~sw env t ~env_arr ~argv ~output_file =
try
let flow = Eio.Net.connect ~sw net (`Unix t.sock_path) in
Eio.Buf_write.with_flow flow (fun w ->
- write_u32 w (Array.length env_arr);
- Array.iter (write_str w) env_arr;
- write_u32 w (Array.length argv);
- Array.iter (write_str w) argv;
- (match output_file with
- | None -> write_u8 w 0
- | Some path ->
- write_u8 w 1;
- write_str w path));
- let r = Eio.Buf_read.of_flow flow
- ~max_size:max_response_field_bytes in
+ write_u32 w (Array.length env_arr);
+ Array.iter (write_str w) env_arr;
+ write_u32 w (Array.length argv);
+ Array.iter (write_str w) argv;
+ match output_file with
+ | None -> write_u8 w 0
+ | Some path ->
+ write_u8 w 1;
+ write_str w path);
+ let r = Eio.Buf_read.of_flow flow ~max_size:max_response_field_bytes in
let status_type = read_u8 r in
let status_code = read_u32 r in
let stdout = read_str r in
let stderr = read_str r in
- let status = match status_type with
+ let status =
+ match status_type with
| 0 -> `Exited status_code
| _ -> `Signaled status_code
in
(stdout, stderr, status)
- with
- | (Eio.Io _ | End_of_file) as exn ->
+ with (Eio.Io _ | End_of_file) as exn ->
(* Connection refused, EOF mid-read, EPIPE — all symptoms of a
dead helper. Invalidate the cached instance so the next caller
starts a fresh one. *)
- Log.warn (fun m -> m "Helper looks dead (%s); invalidating instance"
- (Printexc.to_string exn));
+ Log.warn (fun m ->
+ m "Helper looks dead (%s); invalidating instance"
+ (Printexc.to_string exn));
(match Atomic.get instance with
- | Some cached when cached == t ->
- (* Only clear if we are still the current instance — another
+ | Some cached when cached == t ->
+ (* Only clear if we are still the current instance — another
fiber may have already replaced us. *)
- ignore (Atomic.compare_and_set instance (Some cached) None)
- | _ -> ());
+ ignore (Atomic.compare_and_set instance (Some cached) None)
+ | _ -> ());
raise exn
let get_instance () =
match Atomic.get instance with
| Some t -> t
| None ->
- let t = start () in
- if Atomic.compare_and_set instance None (Some t) then begin
- at_exit (fun () -> stop t);
- t
- end else begin
- (* Another fiber raced us — discard ours, use theirs *)
- stop t;
- match Atomic.get instance with
- | Some t -> t
- | None -> failwith "fork helper: startup race"
- end
+ let t = start () in
+ if Atomic.compare_and_set instance None (Some t) then (
+ at_exit (fun () -> stop t);
+ t)
+ else (
+ (* Another fiber raced us — discard ours, use theirs *)
+ stop t;
+ match Atomic.get instance with
+ | Some t -> t
+ | None -> failwith "fork helper: startup race")
File "day11/sys/fork_client.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/fork_client.mli b/_build/default/day11/sys/.formatted/fork_client.mli
index df0cf8d..0ca2bb9 100644
--- a/_build/default/day11/sys/fork_client.mli
+++ b/_build/default/day11/sys/.formatted/fork_client.mli
@@ -1,7 +1,7 @@
(** Client for the fork helper daemon.
- Spawns subprocesses via a small helper process to avoid the ~100ms
- page table copy cost of forking the main 1.7GB process. *)
+ Spawns subprocesses via a small helper process to avoid the ~100ms page
+ table copy cost of forking the main 1.7GB process. *)
type t
@@ -13,10 +13,10 @@ val spawn :
argv:string array ->
output_file:string option ->
string * string * [ `Exited of int | `Signaled of int ]
-(** [spawn ~sw env t ~env_arr ~argv ~output_file] executes the command
- and returns [(stdout, stderr, status)]. The Unix-socket connection
- to the helper is bound to [sw]. The socket I/O is cooperative on
- the calling fiber's domain. *)
+(** [spawn ~sw env t ~env_arr ~argv ~output_file] executes the command and
+ returns [(stdout, stderr, status)]. The Unix-socket connection to the helper
+ is bound to [sw]. The socket I/O is cooperative on the calling fiber's
+ domain. *)
val get_instance : unit -> t
(** Return the global fork helper instance, starting it if needed. *)
File "day11/sys/run.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/run.ml b/_build/default/day11/sys/.formatted/run.ml
index ce2d4cd..e9fe46f 100644
--- a/_build/default/day11/sys/run.ml
+++ b/_build/default/day11/sys/.formatted/run.ml
@@ -10,6 +10,7 @@ type t = {
}
let src = Logs.Src.create "day11.sys.run" ~doc:"Subprocess execution"
+
module Log = (val Logs.src_log src)
(Delegate fork+exec to the fork helper daemon via a Unix socket.
@@ -28,22 +29,20 @@ let run ~sw env cmd output_file =
let t_start = Unix.gettimeofday () in
let env_arr =
let cur = OS.Env.current () |> Result.get_ok in
- Astring.String.Map.fold
- (fun k v acc -> (k ^ "=" ^ v) :: acc)
- cur []
+ Astring.String.Map.fold (fun k v acc -> (k ^ "=" ^ v) :: acc) cur []
|> Array.of_list
in
let clock = Eio.Stdenv.clock env in
let rec run_with_retry retries =
try run_via_helper ~sw env cmd env_arr output_file
with exn ->
- if retries > 0 then begin
- Log.warn (fun m -> m "Fork helper failed (%s), retrying (%d left)"
- (Printexc.to_string exn) retries);
+ if retries > 0 then (
+ Log.warn (fun m ->
+ m "Fork helper failed (%s), retrying (%d left)"
+ (Printexc.to_string exn) retries);
Eio.Time.sleep clock 0.1;
- run_with_retry (retries - 1)
- end else
- raise exn
+ run_with_retry (retries - 1))
+ else raise exn
in
let output, errors, status = run_with_retry 3 in
let t_end = Unix.gettimeofday () in
@@ -58,8 +57,7 @@ let run ~sw env cmd output_file =
| `Signaled n -> ("signaled", n)
in
Log.err (fun m ->
- m "Process %s with %d: '%s'\nStdout:\n%s\nStderr:\n%s"
- verb n (String.concat " " result.cmd)
+ m "Process %s with %d: '%s'\nStdout:\n%s\nStderr:\n%s" verb n
+ (String.concat " " result.cmd)
result.output result.errors));
result
-
File "day11/sys/run.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/run.mli b/_build/default/day11/sys/.formatted/run.mli
index 49f399a..2936d46 100644
--- a/_build/default/day11/sys/run.mli
+++ b/_build/default/day11/sys/.formatted/run.mli
@@ -15,16 +15,10 @@ type t = {
(** Result of a subprocess execution. *)
val run :
- sw:Eio.Switch.t ->
- Eio_unix.Stdenv.base ->
- Bos.Cmd.t ->
- Fpath.t option ->
- t
-(** [run ~sw env cmd output_file] spawns [cmd] as a subprocess via the
- fork helper, captures stdout/stderr, and awaits completion. The
- socket connection to the helper is bound to [sw], so cancelling
- [sw] cancels the spawn.
-
- [output_file] is stored in the result for the caller's bookkeeping
- — it does not affect where output goes. *)
+ sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> Bos.Cmd.t -> Fpath.t option -> t
+(** [run ~sw env cmd output_file] spawns [cmd] as a subprocess via the fork
+ helper, captures stdout/stderr, and awaits completion. The socket connection
+ to the helper is bound to [sw], so cancelling [sw] cancels the spawn.
+ [output_file] is stored in the result for the caller's bookkeeping — it does
+ not affect where output goes. *)
File "day11/sys/sudo.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/sudo.ml b/_build/default/day11/sys/.formatted/sudo.ml
index 037eded..5876635 100644
--- a/_build/default/day11/sys/sudo.ml
+++ b/_build/default/day11/sys/.formatted/sudo.ml
@@ -1,4 +1,5 @@
let src = Logs.Src.create "day11.sys.sudo" ~doc:"Privileged execution"
+
module Log = (val Logs.src_log src)
let run ?output_file ~sw env cmd =
File "day11/sys/sudo.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/sudo.mli b/_build/default/day11/sys/.formatted/sudo.mli
index 0bb279f..39dfa2d 100644
--- a/_build/default/day11/sys/sudo.mli
+++ b/_build/default/day11/sys/.formatted/sudo.mli
@@ -1,17 +1,21 @@
(** Privileged execution.
- Container builds produce root-owned files. We need sudo for cleanup
- and overlay mounting. *)
+ Container builds produce root-owned files. We need sudo for cleanup and
+ overlay mounting. *)
val run :
?output_file:Fpath.t ->
sw:Eio.Switch.t ->
- Eio_unix.Stdenv.base -> Bos.Cmd.t -> (Run.t, [> Rresult.R.msg ]) result
+ Eio_unix.Stdenv.base ->
+ Bos.Cmd.t ->
+ (Run.t, [> Rresult.R.msg ]) result
(** [run ?output_file ~sw env cmd] executes [cmd] with sudo prepended.
[output_file] is stored on the resulting {!Run.t} for the caller's
bookkeeping — it does not redirect output. *)
val rm_rf :
sw:Eio.Switch.t ->
- Eio_unix.Stdenv.base -> Fpath.t -> (unit, [> Rresult.R.msg ]) result
+ Eio_unix.Stdenv.base ->
+ Fpath.t ->
+ (unit, [> Rresult.R.msg ]) result
(** [rm_rf ~sw env path] removes [path] recursively via [sudo rm -rf]. *)
File "day11/sys/tree.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/tree.ml b/_build/default/day11/sys/.formatted/tree.ml
index bb23c7a..aa5c15f 100644
--- a/_build/default/day11/sys/tree.ml
+++ b/_build/default/day11/sys/.formatted/tree.ml
@@ -1,4 +1,5 @@
let src = Logs.Src.create "day11.sys.tree" ~doc:"Directory tree operations"
+
module Log = (val Logs.src_log src)
let cp_file ~source ~target =
@@ -7,17 +8,20 @@ let cp_file ~source ~target =
let src_s = Fpath.to_string source in
let tgt_s = Fpath.to_string target in
let ic = open_in_bin src_s in
- Fun.protect ~finally:(fun () -> close_in_noerr ic) (fun () ->
- let oc = open_out_bin tgt_s in
- Fun.protect ~finally:(fun () -> close_out_noerr oc) (fun () ->
- let rec loop () =
- let n = input ic buf 0 buf_size in
- if n > 0 then begin
- output oc buf 0 n;
- loop ()
- end
- in
- loop ()));
+ Fun.protect
+ ~finally:(fun () -> close_in_noerr ic)
+ (fun () ->
+ let oc = open_out_bin tgt_s in
+ Fun.protect
+ ~finally:(fun () -> close_out_noerr oc)
+ (fun () ->
+ let rec loop () =
+ let n = input ic buf 0 buf_size in
+ if n > 0 then (
+ output oc buf 0 n;
+ loop ())
+ in
+ loop ()));
(* Preserve permissions and times; a failure here shouldn't abort the
copy that already succeeded. *)
let stat = Unix.lstat src_s in
@@ -29,8 +33,7 @@ let cp_file ~source ~target =
try Unix.utimes tgt_s stat.Unix.st_atime stat.Unix.st_mtime
with Unix.Unix_error (e, _, _) ->
Log.warn (fun m ->
- m "could not preserve timestamps on %s: %s" tgt_s
- (Unix.error_message e))
+ m "could not preserve timestamps on %s: %s" tgt_s (Unix.error_message e))
let rec walk_copy ~link source target =
let src_s = Fpath.to_string source in
@@ -48,14 +51,13 @@ let rec walk_copy ~link source target =
let link_target = Unix.readlink src_s in
Unix.symlink link_target (Fpath.to_string target)
| Unix.S_REG ->
- if link then
+ if link then (
try Unix.link src_s (Fpath.to_string target)
with Unix.Unix_error (Unix.EMLINK, _, _) ->
Log.debug (fun m ->
m "EMLINK on %a, falling back to copy" Fpath.pp source);
- cp_file ~source ~target
- else
- cp_file ~source ~target
+ cp_file ~source ~target)
+ else cp_file ~source ~target
| _ -> ()
let hardlink ~source ~target =
@@ -64,10 +66,9 @@ let hardlink ~source ~target =
Ok ()
with
| Unix.Unix_error (e, fn, arg) ->
- Rresult.R.error_msgf "hardlink %a -> %a: %s(%s): %s"
- Fpath.pp source Fpath.pp target fn arg (Unix.error_message e)
- | exn ->
- Rresult.R.error_msgf "hardlink: %s" (Printexc.to_string exn)
+ Rresult.R.error_msgf "hardlink %a -> %a: %s(%s): %s" Fpath.pp source
+ Fpath.pp target fn arg (Unix.error_message e)
+ | exn -> Rresult.R.error_msgf "hardlink: %s" (Printexc.to_string exn)
let copy ~source ~target =
try
@@ -75,10 +76,9 @@ let copy ~source ~target =
Ok ()
with
| Unix.Unix_error (e, fn, arg) ->
- Rresult.R.error_msgf "copy %a -> %a: %s(%s): %s"
- Fpath.pp source Fpath.pp target fn arg (Unix.error_message e)
- | exn ->
- Rresult.R.error_msgf "copy: %s" (Printexc.to_string exn)
+ Rresult.R.error_msgf "copy %a -> %a: %s(%s): %s" Fpath.pp source Fpath.pp
+ target fn arg (Unix.error_message e)
+ | exn -> Rresult.R.error_msgf "copy: %s" (Printexc.to_string exn)
let clense ~source ~target =
let rec walk src tgt =
@@ -96,21 +96,20 @@ let clense ~source ~target =
entries;
(* Remove dir if now empty *)
let remaining = Bos.OS.Dir.contents tgt |> Result.get_ok in
- if remaining = [] then
- Bos.OS.Dir.delete ~recurse:false tgt |> ignore
- | Unix.S_REG ->
+ if remaining = [] then Bos.OS.Dir.delete ~recurse:false tgt |> ignore
+ | Unix.S_REG -> (
let src_s = Fpath.to_string src in
- (try
- let src_stat = Unix.lstat src_s in
- if src_stat.Unix.st_mtime = stat.Unix.st_mtime then
- try Unix.unlink tgt_s
- with Unix.Unix_error (Unix.EACCES, _, _) ->
- (* Read-only file: add write bits and retry. *)
- Unix.chmod tgt_s (stat.Unix.st_perm lor 0o222);
- Unix.unlink tgt_s
- with Unix.Unix_error (e, _, _) ->
- Log.debug (fun m ->
- m "clense: skipping %s: %s" tgt_s (Unix.error_message e)))
+ try
+ let src_stat = Unix.lstat src_s in
+ if src_stat.Unix.st_mtime = stat.Unix.st_mtime then (
+ try Unix.unlink tgt_s
+ with Unix.Unix_error (Unix.EACCES, _, _) ->
+ (* Read-only file: add write bits and retry. *)
+ Unix.chmod tgt_s (stat.Unix.st_perm lor 0o222);
+ Unix.unlink tgt_s)
+ with Unix.Unix_error (e, _, _) ->
+ Log.debug (fun m ->
+ m "clense: skipping %s: %s" tgt_s (Unix.error_message e)))
| _ -> ()
in
try
@@ -118,7 +117,6 @@ let clense ~source ~target =
Ok ()
with
| Unix.Unix_error (e, fn, arg) ->
- Rresult.R.error_msgf "clense %a -> %a: %s(%s): %s"
- Fpath.pp source Fpath.pp target fn arg (Unix.error_message e)
- | exn ->
- Rresult.R.error_msgf "clense: %s" (Printexc.to_string exn)
+ Rresult.R.error_msgf "clense %a -> %a: %s(%s): %s" Fpath.pp source
+ Fpath.pp target fn arg (Unix.error_message e)
+ | exn -> Rresult.R.error_msgf "clense: %s" (Printexc.to_string exn)
File "day11/sys/tree.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/tree.mli b/_build/default/day11/sys/.formatted/tree.mli
index fd7779f..5302c73 100644
--- a/_build/default/day11/sys/tree.mli
+++ b/_build/default/day11/sys/.formatted/tree.mli
@@ -2,20 +2,17 @@
val hardlink :
source:Fpath.t -> target:Fpath.t -> (unit, [> Rresult.R.msg ]) result
-(** [hardlink ~source ~target] recursively hardlinks the tree rooted at
- [source] into [target]. Falls back to {!copy} on EMLINK (too many
- links). Symlink targets in the source tree are preserved as symlinks. *)
+(** [hardlink ~source ~target] recursively hardlinks the tree rooted at [source]
+ into [target]. Falls back to {!copy} on EMLINK (too many links). Symlink
+ targets in the source tree are preserved as symlinks. *)
-val copy :
- source:Fpath.t -> target:Fpath.t -> (unit, [> Rresult.R.msg ]) result
-(** [copy ~source ~target] recursively copies the tree rooted at
- [source] into [target], preserving permissions and modification
- times. *)
+val copy : source:Fpath.t -> target:Fpath.t -> (unit, [> Rresult.R.msg ]) result
+(** [copy ~source ~target] recursively copies the tree rooted at [source] into
+ [target], preserving permissions and modification times. *)
val clense :
source:Fpath.t -> target:Fpath.t -> (unit, [> Rresult.R.msg ]) result
-(** [clense ~source ~target] removes files from [target] that are
- identical to their counterparts in [source] (compared by mtime).
- Also removes directories in [target] that become empty after
- removal. Used after overlay builds to extract only new/changed
- files. *)
+(** [clense ~source ~target] removes files from [target] that are identical to
+ their counterparts in [source] (compared by mtime). Also removes directories
+ in [target] that become empty after removal. Used after overlay builds to
+ extract only new/changed files. *)
File "day11/sys/util.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/util.ml b/_build/default/day11/sys/.formatted/util.ml
index 78163a8..73888a3 100644
--- a/_build/default/day11/sys/util.ml
+++ b/_build/default/day11/sys/.formatted/util.ml
@@ -1,6 +1,8 @@
let nproc () =
let ic = Unix.open_process_in "nproc" in
- let n = In_channel.input_line ic |> Option.get |> String.trim |> int_of_string in
+ let n =
+ In_channel.input_line ic |> Option.get |> String.trim |> int_of_string
+ in
ignore (Unix.close_process_in ic);
n
@@ -16,9 +18,7 @@ let dir_size path =
| _ -> acc)
acc entries
in
- try Ok (walk 0 path)
- with
+ try Ok (walk 0 path) with
| Unix.Unix_error (e, fn, arg) ->
Rresult.R.error_msgf "%s(%s): %s" fn arg (Unix.error_message e)
- | exn ->
- Rresult.R.error_msgf "dir_size: %s" (Printexc.to_string exn)
+ | exn -> Rresult.R.error_msgf "dir_size: %s" (Printexc.to_string exn)
File "day11/sys/util.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/util.mli b/_build/default/day11/sys/.formatted/util.mli
index 003a43d..129b400 100644
--- a/_build/default/day11/sys/util.mli
+++ b/_build/default/day11/sys/.formatted/util.mli
@@ -4,8 +4,7 @@ val nproc : unit -> int
(** [nproc ()] returns the number of available processors. *)
val dir_size : Fpath.t -> (int, [> Rresult.R.msg ]) result
-(** [dir_size path] returns the total size of all files under [path] in
- bytes, computed recursively via [Unix.lstat]. Symlinks contribute
- their own size (the length of the link path), not the size of the
- target they point to. Returns [Error] if the directory cannot be
- read. *)
+(** [dir_size path] returns the total size of all files under [path] in bytes,
+ computed recursively via [Unix.lstat]. Symlinks contribute their own size
+ (the length of the link path), not the size of the target they point to.
+ Returns [Error] if the directory cannot be read. *)
File "day11/solution/deps.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/deps.ml b/_build/default/day11/solution/.formatted/deps.ml
index d173278..b1909bd 100644
--- a/_build/default/day11/solution/deps.ml
+++ b/_build/default/day11/solution/.formatted/deps.ml
@@ -16,21 +16,22 @@ let transitive_deps deps =
match Hashtbl.find_opt cache pkg with
| Some d -> d
| None ->
- if Hashtbl.mem visiting pkg then
- OpamPackage.Set.empty
- else begin
- Hashtbl.add visiting pkg ();
- let direct = match OpamPackage.Map.find_opt pkg deps with
- | Some s -> s | None -> OpamPackage.Set.empty in
- let transitive =
- OpamPackage.Set.fold (fun dep acc ->
- OpamPackage.Set.union acc (go dep)
- ) direct direct
- in
- Hashtbl.remove visiting pkg;
- Hashtbl.replace cache pkg transitive;
- transitive
- end
+ if Hashtbl.mem visiting pkg then OpamPackage.Set.empty
+ else (
+ Hashtbl.add visiting pkg ();
+ let direct =
+ match OpamPackage.Map.find_opt pkg deps with
+ | Some s -> s
+ | None -> OpamPackage.Set.empty
+ in
+ let transitive =
+ OpamPackage.Set.fold
+ (fun dep acc -> OpamPackage.Set.union acc (go dep))
+ direct direct
+ in
+ Hashtbl.remove visiting pkg;
+ Hashtbl.replace cache pkg transitive;
+ transitive)
in
OpamPackage.Map.mapi (fun pkg _ -> go pkg) deps
@@ -39,18 +40,19 @@ let transitive_deps deps =
cycle. Stops at the first cycle. *)
let has_cycle deps =
let colour : (OpamPackage.t, [ `Grey | `Black ]) Hashtbl.t =
- Hashtbl.create 64 in
+ Hashtbl.create 64
+ in
let exception Cycle in
let rec visit pkg =
match Hashtbl.find_opt colour pkg with
| Some `Black -> ()
| Some `Grey -> raise Cycle
| None ->
- Hashtbl.add colour pkg `Grey;
- (match OpamPackage.Map.find_opt pkg deps with
- | Some direct -> OpamPackage.Set.iter visit direct
- | None -> ());
- Hashtbl.replace colour pkg `Black
+ Hashtbl.add colour pkg `Grey;
+ (match OpamPackage.Map.find_opt pkg deps with
+ | Some direct -> OpamPackage.Set.iter visit direct
+ | None -> ());
+ Hashtbl.replace colour pkg `Black
in
try
OpamPackage.Map.iter (fun pkg _ -> visit pkg) deps;
@@ -60,11 +62,12 @@ let has_cycle deps =
let compiler_names = [ "ocaml-base-compiler"; "ocaml-variants"; "ocaml" ]
let extract_ocaml_version deps =
- List.find_map (fun name ->
- let name = OpamPackage.Name.of_string name in
- OpamPackage.Map.filter (fun pkg _ ->
- OpamPackage.Name.equal (OpamPackage.name pkg) name
- ) deps
- |> OpamPackage.Map.min_binding_opt
- |> Option.map fst
- ) compiler_names
+ List.find_map
+ (fun name ->
+ let name = OpamPackage.Name.of_string name in
+ OpamPackage.Map.filter
+ (fun pkg _ -> OpamPackage.Name.equal (OpamPackage.name pkg) name)
+ deps
+ |> OpamPackage.Map.min_binding_opt
+ |> Option.map fst)
+ compiler_names
File "day11/solution/deps.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/deps.mli b/_build/default/day11/solution/.formatted/deps.mli
index b5360b6..68434ee 100644
--- a/_build/default/day11/solution/deps.mli
+++ b/_build/default/day11/solution/.formatted/deps.mli
@@ -1,23 +1,21 @@
(** Dependency graph operations.
- Pure functions on dependency maps where each package maps to its
- direct dependencies. No solver or I/O dependencies. *)
+ Pure functions on dependency maps where each package maps to its direct
+ dependencies. No solver or I/O dependencies. *)
type t = OpamPackage.Set.t OpamPackage.Map.t
(** A dependency graph: maps each package to its direct dependencies. *)
val transitive_deps : t -> t
-(** [transitive_deps deps] enriches the map so each package maps
- to its full transitive dependency closure. *)
+(** [transitive_deps deps] enriches the map so each package maps to its full
+ transitive dependency closure. *)
val has_cycle : t -> bool
-(** [has_cycle deps] is [true] iff [deps] contains a dependency cycle
- (e.g. [ppxlib → ppxlib_jane → ppxlib] in the oxcaml overlay's
- patched [ppxlib.0.33.0+ox]). Useful for filtering solver output
- before passing to [build_dag], which can't build cyclic targets
- sensibly. *)
+(** [has_cycle deps] is [true] iff [deps] contains a dependency cycle (e.g.
+ [ppxlib → ppxlib_jane → ppxlib] in the oxcaml overlay's patched
+ [ppxlib.0.33.0+ox]). Useful for filtering solver output before passing to
+ [build_dag], which can't build cyclic targets sensibly. *)
val extract_ocaml_version : t -> OpamPackage.t option
-(** [extract_ocaml_version deps] finds [ocaml-base-compiler],
- [ocaml-variants], or [ocaml] in the graph. Returns the first
- match found. *)
+(** [extract_ocaml_version deps] finds [ocaml-base-compiler], [ocaml-variants],
+ or [ocaml] in the graph. Returns the first match found. *)
File "day11/solution/json.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/json.ml b/_build/default/day11/solution/.formatted/json.ml
index 360e0be..20ced99 100644
--- a/_build/default/day11/solution/json.ml
+++ b/_build/default/day11/solution/.formatted/json.ml
@@ -15,17 +15,20 @@ let to_json pkgs =
let of_json json =
try
let open Yojson.Safe.Util in
- Ok (json |> to_assoc
- |> List.fold_left
- (fun acc (s, l) ->
- let pkg = OpamPackage.of_string s in
- let deps =
- l |> to_list
- |> List.map (fun s -> s |> to_string |> OpamPackage.of_string)
- |> OpamPackage.Set.of_list
- in
- OpamPackage.Map.add pkg deps acc)
- OpamPackage.Map.empty)
+ Ok
+ (json
+ |> to_assoc
+ |> List.fold_left
+ (fun acc (s, l) ->
+ let pkg = OpamPackage.of_string s in
+ let deps =
+ l
+ |> to_list
+ |> List.map (fun s -> s |> to_string |> OpamPackage.of_string)
+ |> OpamPackage.Set.of_list
+ in
+ OpamPackage.Map.add pkg deps acc)
+ OpamPackage.Map.empty)
with exn ->
Rresult.R.error_msgf "Solution_json.of_json: %s" (Printexc.to_string exn)
@@ -34,19 +37,18 @@ let save path solution =
Yojson.Safe.to_file (Fpath.to_string path) (to_json solution);
Ok ()
with exn ->
- Rresult.R.error_msgf "Solution_json.save %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ Rresult.R.error_msgf "Solution_json.save %a: %s" Fpath.pp path
+ (Printexc.to_string exn)
let load path =
try
let json = Yojson.Safe.from_file (Fpath.to_string path) in
of_json json
with exn ->
- Rresult.R.error_msgf "Solution_json.load %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ Rresult.R.error_msgf "Solution_json.load %a: %s" Fpath.pp path
+ (Printexc.to_string exn)
-let to_string solution =
- Yojson.Safe.to_string (to_json solution)
+let to_string solution = Yojson.Safe.to_string (to_json solution)
let of_string str =
try
File "day11/solution/json.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/json.mli b/_build/default/day11/solution/.formatted/json.mli
index 2d07890..4dadc16 100644
--- a/_build/default/day11/solution/json.mli
+++ b/_build/default/day11/solution/.formatted/json.mli
@@ -1,8 +1,8 @@
(** Solution persistence.
- Serializes dependency solutions (package → dependency set maps)
- to and from JSON. Used for caching solved results on disk and
- for inter-process communication. *)
+ Serializes dependency solutions (package → dependency set maps) to and from
+ JSON. Used for caching solved results on disk and for inter-process
+ communication. *)
type t = Deps.t
(** Alias for {!Deps.t}. *)
File "day11/solution/rdeps.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/rdeps.ml b/_build/default/day11/solution/.formatted/rdeps.ml
index a1d91ea..6a879e8 100644
--- a/_build/default/day11/solution/rdeps.ml
+++ b/_build/default/day11/solution/.formatted/rdeps.ml
@@ -1,9 +1,10 @@
let find solutions pkg =
- List.fold_left (fun acc solution ->
- let trans = Deps.transitive_deps solution in
- OpamPackage.Map.fold (fun p deps acc ->
- if OpamPackage.Set.mem pkg deps then
- OpamPackage.Set.add p acc
- else acc
- ) trans acc
- ) OpamPackage.Set.empty solutions
+ List.fold_left
+ (fun acc solution ->
+ let trans = Deps.transitive_deps solution in
+ OpamPackage.Map.fold
+ (fun p deps acc ->
+ if OpamPackage.Set.mem pkg deps then OpamPackage.Set.add p acc
+ else acc)
+ trans acc)
+ OpamPackage.Set.empty solutions
File "day11/solution/rdeps.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/rdeps.mli b/_build/default/day11/solution/.formatted/rdeps.mli
index b86a2f6..4ef64bb 100644
--- a/_build/default/day11/solution/rdeps.mli
+++ b/_build/default/day11/solution/.formatted/rdeps.mli
@@ -1,10 +1,8 @@
(** Reverse dependency lookup.
- Given a set of solutions, finds which packages transitively
- depend on a given package. *)
+ Given a set of solutions, finds which packages transitively depend on a
+ given package. *)
-val find :
- Deps.t list -> OpamPackage.t ->
- OpamPackage.Set.t
+val find : Deps.t list -> OpamPackage.t -> OpamPackage.Set.t
(** [find solutions pkg] returns all packages across [solutions] that
transitively depend on [pkg]. *)
File "day11/solution/solve_result.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/solve_result.ml b/_build/default/day11/solution/.formatted/solve_result.ml
index ee83a07..2d735d6 100644
--- a/_build/default/day11/solution/solve_result.ml
+++ b/_build/default/day11/solution/.formatted/solve_result.ml
@@ -6,47 +6,52 @@ type t = {
}
let packages_to_json pkgs =
- `List (OpamPackage.Set.fold (fun p acc ->
- `String (OpamPackage.to_string p) :: acc
- ) pkgs [])
+ `List
+ (OpamPackage.Set.fold
+ (fun p acc -> `String (OpamPackage.to_string p) :: acc)
+ pkgs [])
let packages_of_json json =
let open Yojson.Safe.Util in
- json |> to_list |> List.map to_string
+ json
+ |> to_list
+ |> List.map to_string
|> List.map OpamPackage.of_string
|> OpamPackage.Set.of_list
let examined_to_json examined =
- `List (OpamPackage.Name.Set.fold (fun n acc ->
- `String (OpamPackage.Name.to_string n) :: acc
- ) examined [])
+ `List
+ (OpamPackage.Name.Set.fold
+ (fun n acc -> `String (OpamPackage.Name.to_string n) :: acc)
+ examined [])
let examined_of_json json =
let open Yojson.Safe.Util in
- json |> to_list |> List.map to_string
+ json
+ |> to_list
+ |> List.map to_string
|> List.map OpamPackage.Name.of_string
|> OpamPackage.Name.Set.of_list
let to_json t =
- `Assoc [
- ("packages", packages_to_json t.packages);
- ("build_deps", Json.to_json t.build_deps);
- ("doc_deps", Json.to_json t.doc_deps);
- ("examined", examined_to_json t.examined);
- ]
+ `Assoc
+ [
+ ("packages", packages_to_json t.packages);
+ ("build_deps", Json.to_json t.build_deps);
+ ("doc_deps", Json.to_json t.doc_deps);
+ ("examined", examined_to_json t.examined);
+ ]
let of_json json =
try
let open Yojson.Safe.Util in
let packages = json |> member "packages" |> packages_of_json in
- let build_deps = json |> member "build_deps"
- |> Json.of_json in
- let doc_deps = json |> member "doc_deps"
- |> Json.of_json in
+ let build_deps = json |> member "build_deps" |> Json.of_json in
+ let doc_deps = json |> member "doc_deps" |> Json.of_json in
let examined = json |> member "examined" |> examined_of_json in
- match build_deps, doc_deps with
+ match (build_deps, doc_deps) with
| Ok build_deps, Ok doc_deps ->
- Ok { packages; build_deps; doc_deps; examined }
+ Ok { packages; build_deps; doc_deps; examined }
| Error e, _ | _, Error e -> Error e
with exn ->
Rresult.R.error_msgf "Solve_result.of_json: %s" (Printexc.to_string exn)
File "day11/solution/solve_result.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/solve_result.mli b/_build/default/day11/solution/.formatted/solve_result.mli
index 08fbdeb..df06864 100644
--- a/_build/default/day11/solution/solve_result.mli
+++ b/_build/default/day11/solution/.formatted/solve_result.mli
@@ -1,29 +1,25 @@
(** Result of dependency solving.
- Carries both the build dependency graph (acyclic, used for
- topological build ordering) and the doc dependency graph (may
- contain cycles via [x-extra-doc-deps], used for odoc
- cross-referencing). Both graphs span the same package set. *)
+ Carries both the build dependency graph (acyclic, used for topological build
+ ordering) and the doc dependency graph (may contain cycles via
+ [x-extra-doc-deps], used for odoc cross-referencing). Both graphs span the
+ same package set. *)
type t = {
packages : OpamPackage.Set.t;
- (** The version assignment chosen by the solver. *)
-
+ (** The version assignment chosen by the solver. *)
build_deps : Deps.t;
- (** Acyclic. Each package mapped to the packages it needs to build
- and install. Safe to topologically sort. *)
-
+ (** Acyclic. Each package mapped to the packages it needs to build and
+ install. Safe to topologically sort. *)
doc_deps : Deps.t;
- (** May contain cycles. Each package mapped to the packages whose
- odoc output it needs for cross-referencing. Equals {!build_deps}
- plus [{post}] deps and [x-extra-doc-deps] edges. Do NOT
- topologically sort this graph. *)
-
+ (** May contain cycles. Each package mapped to the packages whose odoc
+ output it needs for cross-referencing. Equals {!build_deps} plus
+ [{post}] deps and [x-extra-doc-deps] edges. Do NOT topologically sort
+ this graph. *)
examined : OpamPackage.Name.Set.t;
- (** Package names the solver touched during solving. Used for
- incremental cache invalidation: if none of the examined names
- changed between opam-repo commits, the cached result is still
- valid. *)
+ (** Package names the solver touched during solving. Used for incremental
+ cache invalidation: if none of the examined names changed between
+ opam-repo commits, the cached result is still valid. *)
}
val to_json : t -> Yojson.Safe.t
File "day11/solution/tool_names.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/tool_names.ml b/_build/default/day11/solution/.formatted/tool_names.ml
index e01c904..1bc454a 100644
--- a/_build/default/day11/solution/tool_names.ml
+++ b/_build/default/day11/solution/.formatted/tool_names.ml
@@ -1,28 +1,22 @@
-(** Packages that are doc-pipeline tools, never runtime deps. They
- are built once per [driver_compiler] in the tool layer
- ({!Day11_opam_build.Tools.plan_tool}) and mounted into doc
- containers by {!Day11_doc.Doc_build.make_tool_mounts}. They must
- not be solver roots in per-target solves: each target solve would
- pull a slightly different transitive closure (different
- [cmdliner] / [yojson] / [eio] / [progress] versions), inflating
- the doc-deps universe and forcing a fresh per-target build of an
- otherwise-shared tool.
+(** Packages that are doc-pipeline tools, never runtime deps. They are built
+ once per [driver_compiler] in the tool layer
+ ({!Day11_opam_build.Tools.plan_tool}) and mounted into doc containers by
+ {!Day11_doc.Doc_build.make_tool_mounts}. They must not be solver roots in
+ per-target solves: each target solve would pull a slightly different
+ transitive closure (different [cmdliner] / [yojson] / [eio] / [progress]
+ versions), inflating the doc-deps universe and forcing a fresh per-target
+ build of an otherwise-shared tool.
- [odoc] and [odoc-parser] are deliberately {b not} on this list:
- [odoc] parses [.cmt]/[.cmti] files and must match the target's
- OCaml ABI, so it's already a per-compiler tool via
- [odoc_tool]. The names here are the compiler-agnostic ones — they
- exec [odoc] rather than linking against the compiler libraries. *)
-let names = [
- "odoc-driver";
- "odoc-md";
- "sherlodoc";
- "odig";
-]
+ [odoc] and [odoc-parser] are deliberately {b not} on this list: [odoc]
+ parses [.cmt]/[.cmti] files and must match the target's OCaml ABI, so it's
+ already a per-compiler tool via [odoc_tool]. The names here are the
+ compiler-agnostic ones — they exec [odoc] rather than linking against the
+ compiler libraries. *)
+let names = [ "odoc-driver"; "odoc-md"; "sherlodoc"; "odig" ]
let name_set =
- List.fold_left (fun acc n ->
- OpamPackage.Name.Set.add (OpamPackage.Name.of_string n) acc)
+ List.fold_left
+ (fun acc n -> OpamPackage.Name.Set.add (OpamPackage.Name.of_string n) acc)
OpamPackage.Name.Set.empty names
let is_tool_only name = OpamPackage.Name.Set.mem name name_set
File "day11/solution/universe.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/universe.ml b/_build/default/day11/solution/.formatted/universe.ml
index 7611032..46ea552 100644
--- a/_build/default/day11/solution/universe.ml
+++ b/_build/default/day11/solution/.formatted/universe.ml
@@ -9,7 +9,6 @@ let of_deps deps =
|> Digest.to_hex
let dummy = ""
-
let equal = String.equal
let to_string t = t
let pp fmt t = Format.pp_print_string fmt t
File "day11/solution/universe.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/universe.mli b/_build/default/day11/solution/.formatted/universe.mli
index b77b2c3..5e32095 100644
--- a/_build/default/day11/solution/universe.mli
+++ b/_build/default/day11/solution/.formatted/universe.mli
@@ -1,17 +1,17 @@
(** Universe identifier — a hash of the transitive dependency set.
- Used to distinguish different build contexts for the same package
- version, and to determine blessed documentation paths. *)
+ Used to distinguish different build contexts for the same package version,
+ and to determine blessed documentation paths. *)
type t
val of_deps : OpamPackage.Set.t -> t
-(** [of_deps deps] computes a universe identifier from a set of
- transitive dependencies. *)
+(** [of_deps deps] computes a universe identifier from a set of transitive
+ dependencies. *)
val dummy : t
-(** A placeholder for contexts where the universe is not meaningful
- (e.g. tool nodes, test fixtures). *)
+(** A placeholder for contexts where the universe is not meaningful (e.g. tool
+ nodes, test fixtures). *)
val equal : t -> t -> bool
val to_string : t -> string
File "day11/container/mount.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/container/mount.ml b/_build/default/day11/container/.formatted/mount.ml
index 6100d8e..9b907f5 100644
--- a/_build/default/day11/container/mount.ml
+++ b/_build/default/day11/container/.formatted/mount.ml
@@ -1,17 +1,13 @@
-type t = {
- ty : string;
- src : string;
- dst : string;
- options : string list;
-}
+type t = { ty : string; src : string; dst : string; options : string list }
let to_json { ty; src; dst; options } =
- `Assoc [
- ("destination", `String dst);
- ("type", `String ty);
- ("source", `String src);
- ("options", `List (List.map (fun x -> `String x) options));
- ]
+ `Assoc
+ [
+ ("destination", `String dst);
+ ("type", `String ty);
+ ("source", `String src);
+ ("options", `List (List.map (fun x -> `String x) options));
+ ]
let bind_ro ~src dst =
{ ty = "bind"; src; dst; options = [ "ro"; "rbind"; "rprivate" ] }
File "day11/container/oci_spec.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/container/oci_spec.ml b/_build/default/day11/container/.formatted/oci_spec.ml
index d490560..913546d 100644
--- a/_build/default/day11/container/oci_spec.ml
+++ b/_build/default/day11/container/.formatted/oci_spec.ml
@@ -12,124 +12,245 @@ type t = {
numa_mems : string option;
}
-let make ?(terminal = false) ?(cwd = "/") ?(hostname = "container")
- ?(env = []) ?(mounts = []) ?(network = false)
- ?cpuset ?numa_mems
- ~argv ~uid ~gid () : t =
- { terminal; cwd; hostname; env; mounts; network; argv; uid; gid;
- cpuset; numa_mems }
+let make ?(terminal = false) ?(cwd = "/") ?(hostname = "container") ?(env = [])
+ ?(mounts = []) ?(network = false) ?cpuset ?numa_mems ~argv ~uid ~gid () : t
+ =
+ {
+ terminal;
+ cwd;
+ hostname;
+ env;
+ mounts;
+ network;
+ argv;
+ uid;
+ gid;
+ cpuset;
+ numa_mems;
+ }
-let default_linux_caps = [
- "CAP_CHOWN";
- "CAP_DAC_OVERRIDE";
- "CAP_FSETID";
- "CAP_FOWNER";
- "CAP_MKNOD";
- "CAP_SETGID";
- "CAP_SETUID";
- "CAP_SETFCAP";
- "CAP_SETPCAP";
- "CAP_SYS_CHROOT";
- "CAP_KILL";
- "CAP_AUDIT_WRITE";
-]
+let default_linux_caps =
+ [
+ "CAP_CHOWN";
+ "CAP_DAC_OVERRIDE";
+ "CAP_FSETID";
+ "CAP_FOWNER";
+ "CAP_MKNOD";
+ "CAP_SETGID";
+ "CAP_SETUID";
+ "CAP_SETFCAP";
+ "CAP_SETPCAP";
+ "CAP_SYS_CHROOT";
+ "CAP_KILL";
+ "CAP_AUDIT_WRITE";
+ ]
let strings xs = `List (List.map (fun x -> `String x) xs)
let to_yojson ~root (t : t) : Yojson.Safe.t =
- `Assoc [
- ("ociVersion", `String "1.0.1-dev");
- ("process", `Assoc [
- ("terminal", `Bool t.terminal);
- ("user", `Assoc [ ("uid", `Int t.uid); ("gid", `Int t.gid) ]);
- ("args", strings t.argv);
- ("env", strings (List.map (fun (k, v) ->
- Printf.sprintf "%s=%s" k v) t.env));
- ("cwd", `String t.cwd);
- ("capabilities", `Assoc [
- ("bounding", strings default_linux_caps);
- ("effective", strings default_linux_caps);
- ("inheritable", strings default_linux_caps);
- ("permitted", strings default_linux_caps);
- ]);
- ("rlimits", `List [
- `Assoc [ ("type", `String "RLIMIT_NOFILE");
- ("hard", `Int 1024); ("soft", `Int 1024) ] ]);
- ("noNewPrivileges", `Bool false);
- ]);
- ("root", `Assoc [
- ("path", `String root);
- ("readonly", `Bool false) ]);
- ("hostname", `String t.hostname);
- ("mounts", `List (
- List.map Mount.to_json t.mounts
- @ [
- Mount.(to_json { ty = "proc"; src = "proc"; dst = "/proc";
- options = [ "nosuid"; "noexec"; "nodev" ] });
- Mount.(to_json { ty = "tmpfs"; src = "tmpfs"; dst = "/tmp";
- options = [ "nosuid"; "noatime"; "nodev";
- "noexec"; "mode=1777" ] });
- Mount.(to_json { ty = "tmpfs"; src = "tmpfs"; dst = "/dev";
- options = [ "nosuid"; "strictatime"; "mode=755";
- "size=65536k" ] });
- Mount.(to_json { ty = "devpts"; src = "devpts"; dst = "/dev/pts";
- options = [ "nosuid"; "noexec"; "newinstance";
- "ptmxmode=0666"; "mode=0620";
- "gid=5" ] });
- Mount.(to_json { ty = "sysfs"; src = "sysfs"; dst = "/sys";
- options = [ "nosuid"; "noexec"; "nodev"; "ro" ] });
- Mount.(to_json { ty = "cgroup"; src = "cgroup";
- dst = "/sys/fs/cgroup";
- options = [ "ro"; "nosuid"; "noexec"; "nodev" ] });
- Mount.(to_json { ty = "tmpfs"; src = "shm"; dst = "/dev/shm";
- options = [ "nosuid"; "noexec"; "nodev";
- "mode=1777"; "size=65536k" ] });
- Mount.(to_json { ty = "mqueue"; src = "mqueue";
- dst = "/dev/mqueue";
- options = [ "nosuid"; "noexec"; "nodev" ] });
- ]
- @ (if t.network then
- [ Mount.(to_json { ty = "bind"; src = "/etc/resolv.conf";
- dst = "/etc/resolv.conf";
- options = [ "ro"; "rbind"; "rprivate" ] }) ]
- else [])));
- ("linux", `Assoc (
- (* cgroup cpuset/mems — emitted only when set, so unconfigured
+ `Assoc
+ [
+ ("ociVersion", `String "1.0.1-dev");
+ ( "process",
+ `Assoc
+ [
+ ("terminal", `Bool t.terminal);
+ ("user", `Assoc [ ("uid", `Int t.uid); ("gid", `Int t.gid) ]);
+ ("args", strings t.argv);
+ ( "env",
+ strings
+ (List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) t.env) );
+ ("cwd", `String t.cwd);
+ ( "capabilities",
+ `Assoc
+ [
+ ("bounding", strings default_linux_caps);
+ ("effective", strings default_linux_caps);
+ ("inheritable", strings default_linux_caps);
+ ("permitted", strings default_linux_caps);
+ ] );
+ ( "rlimits",
+ `List
+ [
+ `Assoc
+ [
+ ("type", `String "RLIMIT_NOFILE");
+ ("hard", `Int 1024);
+ ("soft", `Int 1024);
+ ];
+ ] );
+ ("noNewPrivileges", `Bool false);
+ ] );
+ ("root", `Assoc [ ("path", `String root); ("readonly", `Bool false) ]);
+ ("hostname", `String t.hostname);
+ ( "mounts",
+ `List
+ (List.map Mount.to_json t.mounts
+ @ [
+ Mount.(
+ to_json
+ {
+ ty = "proc";
+ src = "proc";
+ dst = "/proc";
+ options = [ "nosuid"; "noexec"; "nodev" ];
+ });
+ Mount.(
+ to_json
+ {
+ ty = "tmpfs";
+ src = "tmpfs";
+ dst = "/tmp";
+ options =
+ [ "nosuid"; "noatime"; "nodev"; "noexec"; "mode=1777" ];
+ });
+ Mount.(
+ to_json
+ {
+ ty = "tmpfs";
+ src = "tmpfs";
+ dst = "/dev";
+ options =
+ [ "nosuid"; "strictatime"; "mode=755"; "size=65536k" ];
+ });
+ Mount.(
+ to_json
+ {
+ ty = "devpts";
+ src = "devpts";
+ dst = "/dev/pts";
+ options =
+ [
+ "nosuid";
+ "noexec";
+ "newinstance";
+ "ptmxmode=0666";
+ "mode=0620";
+ "gid=5";
+ ];
+ });
+ Mount.(
+ to_json
+ {
+ ty = "sysfs";
+ src = "sysfs";
+ dst = "/sys";
+ options = [ "nosuid"; "noexec"; "nodev"; "ro" ];
+ });
+ Mount.(
+ to_json
+ {
+ ty = "cgroup";
+ src = "cgroup";
+ dst = "/sys/fs/cgroup";
+ options = [ "ro"; "nosuid"; "noexec"; "nodev" ];
+ });
+ Mount.(
+ to_json
+ {
+ ty = "tmpfs";
+ src = "shm";
+ dst = "/dev/shm";
+ options =
+ [
+ "nosuid"; "noexec"; "nodev"; "mode=1777"; "size=65536k";
+ ];
+ });
+ Mount.(
+ to_json
+ {
+ ty = "mqueue";
+ src = "mqueue";
+ dst = "/dev/mqueue";
+ options = [ "nosuid"; "noexec"; "nodev" ];
+ });
+ ]
+ @
+ if t.network then
+ [
+ Mount.(
+ to_json
+ {
+ ty = "bind";
+ src = "/etc/resolv.conf";
+ dst = "/etc/resolv.conf";
+ options = [ "ro"; "rbind"; "rprivate" ];
+ });
+ ]
+ else []) );
+ ( "linux",
+ `Assoc
+ ((* cgroup cpuset/mems — emitted only when set, so unconfigured
containers stay identical to the pre-NUMA spec. *)
- (match t.cpuset, t.numa_mems with
- | None, None -> []
- | _ ->
- let cpu_kv = List.filter_map
- (fun (k, v) -> Option.map (fun s -> (k, `String s)) v)
- [ ("cpus", t.cpuset); ("mems", t.numa_mems) ] in
- [ ("resources", `Assoc [ ("cpu", `Assoc cpu_kv) ]) ])
- @ [
- ("namespaces", `List (
- List.map (fun ns -> `Assoc [ ("type", `String ns) ])
- ((if t.network then [] else [ "network" ])
- @ [ "pid"; "ipc"; "uts"; "mount" ])));
- ("maskedPaths", strings [
- "/proc/acpi"; "/proc/asound"; "/proc/kcore"; "/proc/keys";
- "/proc/latency_stats"; "/proc/timer_list"; "/proc/timer_stats";
- "/proc/sched_debug"; "/sys/firmware"; "/proc/scsi" ]);
- ("readonlyPaths", strings [
- "/proc/bus"; "/proc/fs"; "/proc/irq"; "/proc/sys";
- "/proc/sysrq-trigger" ]);
- ("seccomp", `Assoc [
- ("defaultAction", `String "SCMP_ACT_ALLOW");
- ("syscalls", `List [
- `Assoc [
- ("names", strings [
- "fsync"; "fdatasync"; "msync"; "sync"; "syncfs";
- "sync_file_range" ]);
- ("action", `String "SCMP_ACT_ERRNO");
- ("errnoRet", `Int 0);
- ]]);
- ("architectures", strings [
- "SCMP_ARCH_X86_64"; "SCMP_ARCH_X86"; "SCMP_ARCH_X32" ]);
- ]);
- ]));
- ]
+ (match (t.cpuset, t.numa_mems) with
+ | None, None -> []
+ | _ ->
+ let cpu_kv =
+ List.filter_map
+ (fun (k, v) -> Option.map (fun s -> (k, `String s)) v)
+ [ ("cpus", t.cpuset); ("mems", t.numa_mems) ]
+ in
+ [ ("resources", `Assoc [ ("cpu", `Assoc cpu_kv) ]) ])
+ @ [
+ ( "namespaces",
+ `List
+ (List.map
+ (fun ns -> `Assoc [ ("type", `String ns) ])
+ ((if t.network then [] else [ "network" ])
+ @ [ "pid"; "ipc"; "uts"; "mount" ])) );
+ ( "maskedPaths",
+ strings
+ [
+ "/proc/acpi";
+ "/proc/asound";
+ "/proc/kcore";
+ "/proc/keys";
+ "/proc/latency_stats";
+ "/proc/timer_list";
+ "/proc/timer_stats";
+ "/proc/sched_debug";
+ "/sys/firmware";
+ "/proc/scsi";
+ ] );
+ ( "readonlyPaths",
+ strings
+ [
+ "/proc/bus";
+ "/proc/fs";
+ "/proc/irq";
+ "/proc/sys";
+ "/proc/sysrq-trigger";
+ ] );
+ ( "seccomp",
+ `Assoc
+ [
+ ("defaultAction", `String "SCMP_ACT_ALLOW");
+ ( "syscalls",
+ `List
+ [
+ `Assoc
+ [
+ ( "names",
+ strings
+ [
+ "fsync";
+ "fdatasync";
+ "msync";
+ "sync";
+ "syncfs";
+ "sync_file_range";
+ ] );
+ ("action", `String "SCMP_ACT_ERRNO");
+ ("errnoRet", `Int 0);
+ ];
+ ] );
+ ( "architectures",
+ strings
+ [ "SCMP_ARCH_X86_64"; "SCMP_ARCH_X86"; "SCMP_ARCH_X32" ]
+ );
+ ] );
+ ]) );
+ ]
let write ~root bundle_dir t =
let path = Fpath.(bundle_dir / "config.json") in
@@ -137,8 +258,8 @@ let write ~root bundle_dir t =
Yojson.Safe.to_file (Fpath.to_string path) (to_yojson ~root t);
Ok ()
with exn ->
- Rresult.R.error_msgf "Oci_spec.write %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ Rresult.R.error_msgf "Oci_spec.write %a: %s" Fpath.pp path
+ (Printexc.to_string exn)
let placeholder_root = "<rootfs>"
@@ -148,8 +269,8 @@ let write_template path t =
(to_yojson ~root:placeholder_root t);
Ok ()
with exn ->
- Rresult.R.error_msgf "Oci_spec.write_template %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ Rresult.R.error_msgf "Oci_spec.write_template %a: %s" Fpath.pp path
+ (Printexc.to_string exn)
(* A template config.json is concrete JSON in which only [root.path]
is parameterized (= [placeholder_root]). Instantiating it is just a
@@ -158,29 +279,38 @@ let write_template path t =
accept a non-template (or already-instantiated) config.json. *)
let instantiate_template ~root (json : Yojson.Safe.t) =
match json with
- | `Assoc fields ->
- (match List.assoc_opt "root" fields with
- | Some (`Assoc root_fields) ->
- (match List.assoc_opt "path" root_fields with
- | Some (`String p) when p = placeholder_root ->
- let root_fields' = List.map (fun (k, v) ->
- if k = "path" then (k, `String root) else (k, v)) root_fields in
- let fields' = List.map (fun (k, v) ->
- if k = "root" then (k, `Assoc root_fields') else (k, v)) fields in
- Ok (`Assoc fields')
- | Some (`String p) ->
- Rresult.R.error_msgf
- "Oci_spec.instantiate_template: root.path is %S, not the \
- template placeholder %S" p placeholder_root
- | _ ->
- Rresult.R.error_msg
- "Oci_spec.instantiate_template: root.path missing or not a string")
- | _ ->
- Rresult.R.error_msg
- "Oci_spec.instantiate_template: no root object")
+ | `Assoc fields -> (
+ match List.assoc_opt "root" fields with
+ | Some (`Assoc root_fields) -> (
+ match List.assoc_opt "path" root_fields with
+ | Some (`String p) when p = placeholder_root ->
+ let root_fields' =
+ List.map
+ (fun (k, v) ->
+ if k = "path" then (k, `String root) else (k, v))
+ root_fields
+ in
+ let fields' =
+ List.map
+ (fun (k, v) ->
+ if k = "root" then (k, `Assoc root_fields') else (k, v))
+ fields
+ in
+ Ok (`Assoc fields')
+ | Some (`String p) ->
+ Rresult.R.error_msgf
+ "Oci_spec.instantiate_template: root.path is %S, not the \
+ template placeholder %S"
+ p placeholder_root
+ | _ ->
+ Rresult.R.error_msg
+ "Oci_spec.instantiate_template: root.path missing or not a \
+ string")
+ | _ -> Rresult.R.error_msg "Oci_spec.instantiate_template: no root object"
+ )
| _ ->
- Rresult.R.error_msg
- "Oci_spec.instantiate_template: config.json is not a JSON object"
+ Rresult.R.error_msg
+ "Oci_spec.instantiate_template: config.json is not a JSON object"
let instantiate_template_file ~template ~root ~bundle_dir =
match
@@ -190,12 +320,15 @@ let instantiate_template_file ~template ~root ~bundle_dir =
Fpath.pp template (Printexc.to_string exn)
with
| Error _ as e -> e
- | Ok json ->
- match instantiate_template ~root json with
- | Error _ as e -> e
- | Ok json ->
- let path = Fpath.(bundle_dir / "config.json") in
- try Yojson.Safe.to_file (Fpath.to_string path) json; Ok ()
- with exn ->
- Rresult.R.error_msgf "Oci_spec.instantiate_template_file: write %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ | Ok json -> (
+ match instantiate_template ~root json with
+ | Error _ as e -> e
+ | Ok json -> (
+ let path = Fpath.(bundle_dir / "config.json") in
+ try
+ Yojson.Safe.to_file (Fpath.to_string path) json;
+ Ok ()
+ with exn ->
+ Rresult.R.error_msgf
+ "Oci_spec.instantiate_template_file: write %a: %s" Fpath.pp path
+ (Printexc.to_string exn)))
File "day11/container/mount.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/container/mount.mli b/_build/default/day11/container/.formatted/mount.mli
index 59ba720..4b02071 100644
--- a/_build/default/day11/container/mount.mli
+++ b/_build/default/day11/container/.formatted/mount.mli
@@ -1,37 +1,35 @@
(** Mount point specifications for OCI containers.
- A {!t} value describes a single entry in the container's
- [mounts] array, exactly as it appears in the OCI runtime spec.
- Values are constructed directly or via the {!bind_ro}/{!bind_rw}
- helpers and collected into a list that is passed to
- {!Oci_spec.make}.
+ A {!t} value describes a single entry in the container's [mounts] array,
+ exactly as it appears in the OCI runtime spec. Values are constructed
+ directly or via the {!bind_ro}/{!bind_rw} helpers and collected into a list
+ that is passed to {!Oci_spec.make}.
- The system mounts that every container needs ([/proc], [/sys],
- [/dev/pts], etc.) are injected automatically by {!Oci_spec.make}
- and should NOT appear in the caller's mount list — the caller is
- only responsible for application-specific mounts, which in
- practice means bind mounts. *)
+ The system mounts that every container needs ([/proc], [/sys], [/dev/pts],
+ etc.) are injected automatically by {!Oci_spec.make} and should NOT appear
+ in the caller's mount list — the caller is only responsible for
+ application-specific mounts, which in practice means bind mounts. *)
type t = {
ty : string;
- (** Mount type as understood by the kernel: ["bind"], ["tmpfs"],
- ["proc"], ["sysfs"], ["cgroup"], ["devpts"], ["mqueue"], etc. *)
+ (** Mount type as understood by the kernel: ["bind"], ["tmpfs"], ["proc"],
+ ["sysfs"], ["cgroup"], ["devpts"], ["mqueue"], etc. *)
src : string;
- (** Source of the mount. For bind mounts this is the absolute path
- on the host filesystem; for virtual filesystems it is the
- filesystem name (e.g. ["proc"], ["sysfs"]). *)
+ (** Source of the mount. For bind mounts this is the absolute path on the
+ host filesystem; for virtual filesystems it is the filesystem name
+ (e.g. ["proc"], ["sysfs"]). *)
dst : string;
- (** Absolute path inside the container where the mount appears. *)
+ (** Absolute path inside the container where the mount appears. *)
options : string list;
- (** Mount options as space-less strings: ["ro"], ["rw"], ["nosuid"],
- ["rbind"], ["rprivate"], ["size=65536k"], etc. *)
+ (** Mount options as space-less strings: ["ro"], ["rw"], ["nosuid"],
+ ["rbind"], ["rprivate"], ["size=65536k"], etc. *)
}
-(** One mount point. The field order mirrors the OCI runtime-spec
- layout for convenience but does not affect behaviour. *)
+(** One mount point. The field order mirrors the OCI runtime-spec layout for
+ convenience but does not affect behaviour. *)
val to_json : t -> Yojson.Safe.t
-(** [to_json m] serializes [m] to the JSON object expected by the
- OCI runtime spec:
+(** [to_json m] serializes [m] to the JSON object expected by the OCI runtime
+ spec:
{[
{ "destination": dst;
@@ -40,27 +38,27 @@ val to_json : t -> Yojson.Safe.t
"options": [...] }
]}
- Normally called only by {!Oci_spec.make}; callers don't need to
- touch the JSON form themselves. *)
+ Normally called only by {!Oci_spec.make}; callers don't need to touch the
+ JSON form themselves. *)
(** {2 Bind-mount helpers}
- Bind mounts make a host-side path visible inside the container at
- a different (or the same) location. They are the main way the
- build pipeline ships build inputs (opam-repository overlays,
- patches, pre-built dependency trees) into a container.
+ Bind mounts make a host-side path visible inside the container at a
+ different (or the same) location. They are the main way the build pipeline
+ ships build inputs (opam-repository overlays, patches, pre-built dependency
+ trees) into a container.
- Both helpers set [rbind] and [rprivate] so the mount is recursive
- and does not propagate back to the host mount namespace. *)
+ Both helpers set [rbind] and [rprivate] so the mount is recursive and does
+ not propagate back to the host mount namespace. *)
val bind_ro : src:string -> string -> t
-(** [bind_ro ~src dst] is a read-only bind mount of host path [src]
- at container path [dst]. Use this for inputs the container should
- not be able to modify: source archives, patch files, the
- opam-repository, shared read-only dep trees, etc. *)
+(** [bind_ro ~src dst] is a read-only bind mount of host path [src] at container
+ path [dst]. Use this for inputs the container should not be able to modify:
+ source archives, patch files, the opam-repository, shared read-only dep
+ trees, etc. *)
val bind_rw : src:string -> string -> t
-(** [bind_rw ~src dst] is a read-write bind mount of host path [src]
- at container path [dst]. Use this sparingly — the container will
- be able to write to the host path directly. Typical uses are the
- shared odoc-output directories during doc generation. *)
+(** [bind_rw ~src dst] is a read-write bind mount of host path [src] at
+ container path [dst]. Use this sparingly — the container will be able to
+ write to the host path directly. Typical uses are the shared odoc-output
+ directories during doc generation. *)
File "day11/container/oci_spec.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/container/oci_spec.mli b/_build/default/day11/container/.formatted/oci_spec.mli
index 853ef00..517124a 100644
--- a/_build/default/day11/container/oci_spec.mli
+++ b/_build/default/day11/container/.formatted/oci_spec.mli
@@ -1,57 +1,50 @@
(** OCI runtime specification (config.json) generation.
- {{:https://github.com/opencontainers/runtime-spec}runc} and other
- OCI runtimes read a bundle's [config.json] to decide everything
- about how the container is launched: what to run, in what
- rootfs, with what namespaces, capabilities, mounts, seccomp
- filters, and so on.
+ {{:https://github.com/opencontainers/runtime-spec}runc} and other OCI
+ runtimes read a bundle's [config.json] to decide everything about how the
+ container is launched: what to run, in what rootfs, with what namespaces,
+ capabilities, mounts, seccomp filters, and so on.
{1 Spec templates}
A {!t} value is a {b spec template} — a fully-described container
- parameterized only by the rootfs path. Every other field
- (cwd, env, argv, mounts, namespaces, capabilities, …) is baked
- in when the template is constructed via {!make}.
+ parameterized only by the rootfs path. Every other field (cwd, env, argv,
+ mounts, namespaces, capabilities, …) is baked in when the template is
+ constructed via {!make}.
- Templates exist because the rootfs path is typically only known
- {e after} a host-side mount step (overlayfs, bind mount, chroot
- setup, …). The caller knows what container they want well in
- advance; the rootfs path is filled in last by the code that
- physically performs the mount and then calls {!to_yojson} or
- {!write}.
+ Templates exist because the rootfs path is typically only known {e after} a
+ host-side mount step (overlayfs, bind mount, chroot setup, …). The caller
+ knows what container they want well in advance; the rootfs path is filled in
+ last by the code that physically performs the mount and then calls
+ {!to_yojson} or {!write}.
{1 Defaults}
- Most of the OCI spec is boilerplate that never varies between
- builds. {!make} hardcodes sensible values for all of it:
-
- {ul
- {- Linux namespaces: [pid], [ipc], [uts], [mount], and [network]
- (unless [~network:true] is passed).}
- {- Capabilities: a Docker-equivalent baseline (CAP_CHOWN,
- CAP_DAC_OVERRIDE, CAP_FSETID, CAP_FOWNER, CAP_MKNOD,
- CAP_SETGID, CAP_SETUID, CAP_SETFCAP, CAP_SETPCAP,
- CAP_SYS_CHROOT, CAP_KILL, CAP_AUDIT_WRITE).}
- {- Seccomp: [fsync], [fdatasync], [msync], [sync], [syncfs], and
- [sync_file_range] are all masked to return [ERRNO 0]. This is
- deliberate — it makes opam package installs significantly
- faster because the build doesn't need durability guarantees
- inside an ephemeral container.}
- {- [rlimits]: [RLIMIT_NOFILE] = 1024.}
- {- Standard system mounts: [/proc], [/sys], [/dev], [/dev/pts],
- [/dev/shm], [/dev/mqueue], [/sys/fs/cgroup], and [/tmp].}
- {- Masked and read-only [/proc] subpaths matching the Docker
- defaults.}
- {- If [~network:true]: a bind-mount of [/etc/resolv.conf] so
- DNS works inside the container.}}
-
- What varies per call is: what command to run, where, as whom,
- and with which extra mounts. *)
+ Most of the OCI spec is boilerplate that never varies between builds.
+ {!make} hardcodes sensible values for all of it:
+
+ - Linux namespaces: [pid], [ipc], [uts], [mount], and [network] (unless
+ [~network:true] is passed).
+ - Capabilities: a Docker-equivalent baseline (CAP_CHOWN, CAP_DAC_OVERRIDE,
+ CAP_FSETID, CAP_FOWNER, CAP_MKNOD, CAP_SETGID, CAP_SETUID, CAP_SETFCAP,
+ CAP_SETPCAP, CAP_SYS_CHROOT, CAP_KILL, CAP_AUDIT_WRITE).
+ - Seccomp: [fsync], [fdatasync], [msync], [sync], [syncfs], and
+ [sync_file_range] are all masked to return [ERRNO 0]. This is deliberate —
+ it makes opam package installs significantly faster because the build
+ doesn't need durability guarantees inside an ephemeral container.
+ - [rlimits]: [RLIMIT_NOFILE] = 1024.
+ - Standard system mounts: [/proc], [/sys], [/dev], [/dev/pts], [/dev/shm],
+ [/dev/mqueue], [/sys/fs/cgroup], and [/tmp].
+ - Masked and read-only [/proc] subpaths matching the Docker defaults.
+ - If [~network:true]: a bind-mount of [/etc/resolv.conf] so DNS works inside
+ the container.
+
+ What varies per call is: what command to run, where, as whom, and with which
+ extra mounts. *)
type t
-(** A spec template — a fully-described container missing only the
- rootfs path. Construct with {!make}, instantiate with
- {!to_yojson} or {!write}. *)
+(** A spec template — a fully-described container missing only the rootfs path.
+ Construct with {!make}, instantiate with {!to_yojson} or {!write}. *)
val make :
?terminal:bool ->
@@ -67,88 +60,77 @@ val make :
gid:int ->
unit ->
t
-(** [make ~argv ~uid ~gid ()] builds a spec template. The rootfs
- path is supplied later via {!to_yojson} or {!write}.
+(** [make ~argv ~uid ~gid ()] builds a spec template. The rootfs path is
+ supplied later via {!to_yojson} or {!write}.
- @param argv Command and arguments. First element is the
- executable, the rest are passed to it unchanged.
+ @param argv
+ Command and arguments. First element is the executable, the rest are
+ passed to it unchanged.
@param uid User ID inside the container.
@param gid Group ID inside the container.
- @param terminal Whether to allocate a controlling TTY.
- Default [false].
+ @param terminal Whether to allocate a controlling TTY. Default [false].
@param cwd Working directory inside the container. Default ["/"].
- @param hostname Hostname visible inside the container. Default
- ["container"].
- @param env Environment variables as [(key, value)] pairs.
- Serialized as [KEY=value] strings. Default [[]].
- @param mounts Extra bind mounts on top of the standard system
- mounts (which are added automatically). Default [[]].
- @param network If [true], the container joins the host network
- namespace and gets [/etc/resolv.conf] bind-mounted. If [false]
- (the default), the container is in its own network namespace
- and has no connectivity.
- @param cpuset Restrict the container to a set of host CPUs.
- Emitted as [linux.resources.cpu.cpus] (cgroup [cpuset.cpus]).
- Format is the Linux cpuset list: e.g. ["0-3"] or ["0-3,20-23"].
- When set, [nproc] inside the container reports the cpuset count.
- @param numa_mems Restrict the container to memory from these NUMA
- nodes. Emitted as [linux.resources.cpu.mems] (cgroup
- [cpuset.mems]). Format is the Linux nodeset: e.g. ["0"] or
- ["0-1"]. Pairs naturally with [?cpuset] to keep memory local
- to the cpus running the build. *)
+ @param hostname
+ Hostname visible inside the container. Default ["container"].
+ @param env
+ Environment variables as [(key, value)] pairs. Serialized as [KEY=value]
+ strings. Default [[]].
+ @param mounts
+ Extra bind mounts on top of the standard system mounts (which are added
+ automatically). Default [[]].
+ @param network
+ If [true], the container joins the host network namespace and gets
+ [/etc/resolv.conf] bind-mounted. If [false] (the default), the container
+ is in its own network namespace and has no connectivity.
+ @param cpuset
+ Restrict the container to a set of host CPUs. Emitted as
+ [linux.resources.cpu.cpus] (cgroup [cpuset.cpus]). Format is the Linux
+ cpuset list: e.g. ["0-3"] or ["0-3,20-23"]. When set, [nproc] inside the
+ container reports the cpuset count.
+ @param numa_mems
+ Restrict the container to memory from these NUMA nodes. Emitted as
+ [linux.resources.cpu.mems] (cgroup [cpuset.mems]). Format is the Linux
+ nodeset: e.g. ["0"] or ["0-1"]. Pairs naturally with [?cpuset] to keep
+ memory local to the cpus running the build. *)
val to_yojson : root:string -> t -> Yojson.Safe.t
-(** [to_yojson ~root t] instantiates the template with [root] as the
- container's rootfs path and returns the JSON object that runc
- expects in [config.json]. *)
+(** [to_yojson ~root t] instantiates the template with [root] as the container's
+ rootfs path and returns the JSON object that runc expects in [config.json].
+*)
-val write :
- root:string ->
- Fpath.t ->
- t ->
- (unit, [> Rresult.R.msg ]) result
-(** [write ~root bundle_dir t] instantiates [t] with [root] and
- writes it as [bundle_dir/config.json], where {{!Runc.run}runc}
- expects to find it. *)
+val write : root:string -> Fpath.t -> t -> (unit, [> Rresult.R.msg ]) result
+(** [write ~root bundle_dir t] instantiates [t] with [root] and writes it as
+ [bundle_dir/config.json], where {{!Runc.run}runc} expects to find it. *)
val placeholder_root : string
-(** A sentinel string ([<rootfs>]) used by {!write_template} as the
- rootfs path. Callers reading back a template-mode [config.json]
- are expected to substitute it for a real overlay-merged rootfs
- before invoking runc. *)
-
-val write_template :
- Fpath.t ->
- t ->
- (unit, [> Rresult.R.msg ]) result
+(** A sentinel string ([<rootfs>]) used by {!write_template} as the rootfs path.
+ Callers reading back a template-mode [config.json] are expected to
+ substitute it for a real overlay-merged rootfs before invoking runc. *)
+
+val write_template : Fpath.t -> t -> (unit, [> Rresult.R.msg ]) result
(** [write_template path t] writes [t] to [path] (typically
- [<layer_dir>/config.json]) with {!placeholder_root} as the
- rootfs path. The result is a valid OCI bundle descriptor —
- once a host substitutes the placeholder for a real rootfs path
- (e.g. an overlay merging the base image with the layer's
- transitive deps) the bundle is directly runc-runnable. *)
+ [<layer_dir>/config.json]) with {!placeholder_root} as the rootfs path. The
+ result is a valid OCI bundle descriptor — once a host substitutes the
+ placeholder for a real rootfs path (e.g. an overlay merging the base image
+ with the layer's transitive deps) the bundle is directly runc-runnable. *)
val instantiate_template :
- root:string ->
- Yojson.Safe.t ->
- (Yojson.Safe.t, [> Rresult.R.msg ]) result
-(** [instantiate_template ~root json] takes a template-mode
- [config.json] (as produced by {!write_template}) and returns it
- with {!placeholder_root} replaced by the real rootfs path [root].
- This is the inverse half of {!write_template}: it lets a tool
- replay a recorded bundle without re-deriving the spec. Since a
- template is concrete JSON parameterized only by [root.path], this
- substitutes that one field rather than parsing back into a {!t}.
- Errors if [json] isn't a recognisable template (no [root.path], or
- [root.path] isn't {!placeholder_root} - e.g. already instantiated). *)
+ root:string -> Yojson.Safe.t -> (Yojson.Safe.t, [> Rresult.R.msg ]) result
+(** [instantiate_template ~root json] takes a template-mode [config.json] (as
+ produced by {!write_template}) and returns it with {!placeholder_root}
+ replaced by the real rootfs path [root]. This is the inverse half of
+ {!write_template}: it lets a tool replay a recorded bundle without
+ re-deriving the spec. Since a template is concrete JSON parameterized only
+ by [root.path], this substitutes that one field rather than parsing back
+ into a {!t}. Errors if [json] isn't a recognisable template (no [root.path],
+ or [root.path] isn't {!placeholder_root} - e.g. already instantiated). *)
val instantiate_template_file :
template:Fpath.t ->
root:string ->
bundle_dir:Fpath.t ->
(unit, [> Rresult.R.msg ]) result
-(** [instantiate_template_file ~template ~root ~bundle_dir] reads the
- template [config.json] at [template], substitutes [root] for
- {!placeholder_root} (via {!instantiate_template}), and writes the
- result as [bundle_dir/config.json] - a bundle directly runnable by
- {{!Runc.run}runc}. *)
+(** [instantiate_template_file ~template ~root ~bundle_dir] reads the template
+ [config.json] at [template], substitutes [root] for {!placeholder_root} (via
+ {!instantiate_template}), and writes the result as [bundle_dir/config.json]
+ \- a bundle directly runnable by {{!Runc.run}runc}. *)
File "day11/container/overlay.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/container/overlay.ml b/_build/default/day11/container/.formatted/overlay.ml
index ee365d3..7244e0b 100644
--- a/_build/default/day11/container/overlay.ml
+++ b/_build/default/day11/container/.formatted/overlay.ml
@@ -12,25 +12,32 @@
call site, so we dedupe here. *)
let dedup_preserving_order paths =
let seen = Hashtbl.create (List.length paths) in
- List.fold_left (fun acc p ->
- let key = Fpath.to_string p in
- if Hashtbl.mem seen key then acc
- else begin Hashtbl.add seen key (); p :: acc end
- ) [] paths
+ List.fold_left
+ (fun acc p ->
+ let key = Fpath.to_string p in
+ if Hashtbl.mem seen key then acc
+ else (
+ Hashtbl.add seen key ();
+ p :: acc))
+ [] paths
|> List.rev
let mount ~sw env ~lower ~upper ~work ~target =
let lower = dedup_preserving_order lower in
- let lower_str =
- List.map Fpath.to_string lower |> String.concat ":"
- in
+ let lower_str = List.map Fpath.to_string lower |> String.concat ":" in
let opts =
- Printf.sprintf "lowerdir=%s,upperdir=%s,workdir=%s"
- lower_str (Fpath.to_string upper) (Fpath.to_string work)
+ Printf.sprintf "lowerdir=%s,upperdir=%s,workdir=%s" lower_str
+ (Fpath.to_string upper) (Fpath.to_string work)
in
let cmd =
- Bos.Cmd.(v "mount" % "-t" % "overlay" % "overlay"
- % "-o" % opts % Fpath.to_string target)
+ Bos.Cmd.(
+ v "mount"
+ % "-t"
+ % "overlay"
+ % "overlay"
+ % "-o"
+ % opts
+ % Fpath.to_string target)
in
Day11_sys.Sudo.run ~sw env cmd |> Result.map (fun _run -> ())
File "day11/container/overlay.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/container/overlay.mli b/_build/default/day11/container/.formatted/overlay.mli
index 368acea..a4302e6 100644
--- a/_build/default/day11/container/overlay.mli
+++ b/_build/default/day11/container/.formatted/overlay.mli
@@ -1,19 +1,16 @@
(** Linux overlayfs mount and umount.
- Thin wrapper over the [mount(8)] and [umount(8)] commands that
- requires [sudo]. The library supplies exactly the primitives
- needed to stack build layers into a single rootfs for a
- container run:
+ Thin wrapper over the [mount(8)] and [umount(8)] commands that requires
+ [sudo]. The library supplies exactly the primitives needed to stack build
+ layers into a single rootfs for a container run:
- {ul
- {- {!mount} assembles an overlayfs from any number of
- read-only lowers, one writable upper, and one workdir.}
- {- {!umount} tears it down.}}
+ - {!mount} assembles an overlayfs from any number of read-only lowers, one
+ writable upper, and one workdir.
+ - {!umount} tears it down.
- The mount is the final filesystem the container sees as [/]. The
- upper dir captures everything the container writes; after the
- run, the caller typically renames the upper into its cache as a
- new layer. *)
+ The mount is the final filesystem the container sees as [/]. The upper dir
+ captures everything the container writes; after the run, the caller
+ typically renames the upper into its cache as a new layer. *)
val mount :
sw:Eio.Switch.t ->
@@ -23,54 +20,49 @@ val mount :
work:Fpath.t ->
target:Fpath.t ->
(unit, [> Rresult.R.msg ]) result
-(** [mount ~sw env ~lower ~upper ~work ~target] mounts an overlayfs at
- [target] using the given lowers and upper.
+(** [mount ~sw env ~lower ~upper ~work ~target] mounts an overlayfs at [target]
+ using the given lowers and upper.
- {b Lower ordering follows kernel convention: the {e first} entry
- in [lower] becomes the {e topmost} layer}, shadowing files from
- later entries with the same path. The list is joined as
- [lowerdir=A:B:C:...] and passed to [mount -t overlay], so the
- same precedence rules as the [lowerdir] option apply:
+ {b Lower ordering follows kernel convention: the {e first} entry in [lower]
+ becomes the {e topmost} layer}, shadowing files from later entries with
+ the same path. The list is joined as [lowerdir=A:B:C:...] and passed to
+ [mount -t overlay], so the same precedence rules as the [lowerdir] option
+ apply:
- {ul
- {- Directories from all lowers are merged, union-style.}
- {- For non-directory entries with the same name, the leftmost
- layer wins.}
- {- A [trusted.overlay.opaque=y] xattr on a directory in the
- upper causes the corresponding directory in the lower to be
- hidden (does not apply to directories in lowers themselves).}
- {- A whiteout (char device 0/0) in a higher layer hides a
- same-named entry in a lower layer.}}
+ - Directories from all lowers are merged, union-style.
+ - For non-directory entries with the same name, the leftmost layer wins.
+ - A [trusted.overlay.opaque=y] xattr on a directory in the upper causes the
+ corresponding directory in the lower to be hidden (does not apply to
+ directories in lowers themselves).
+ - A whiteout (char device 0/0) in a higher layer hides a same-named entry in
+ a lower layer.
- The [upper] and [work] directories must exist and must be on the
- same filesystem. The upper directory receives any writes the
- container makes to its rootfs. The work directory is internal
- overlayfs scratch space and should be treated as opaque — do not
- read or write it directly.
+ The [upper] and [work] directories must exist and must be on the same
+ filesystem. The upper directory receives any writes the container makes to
+ its rootfs. The work directory is internal overlayfs scratch space and
+ should be treated as opaque — do not read or write it directly.
- Mount-option length limit: the classic [mount(2)] syscall caps
- the options string at [PAGE_SIZE] (typically 4096 bytes). With
- many lowers or long paths, this limit can be hit;
- {!Day11_layer.Stack.plan_lowerdir} is the recommended way to
- split a large dep list into a "kept separate" bucket and a
- "cp-merged into one lower" bucket that fits the budget.
+ Mount-option length limit: the classic [mount(2)] syscall caps the options
+ string at [PAGE_SIZE] (typically 4096 bytes). With many lowers or long
+ paths, this limit can be hit; {!Day11_layer.Stack.plan_lowerdir} is the
+ recommended way to split a large dep list into a "kept separate" bucket and
+ a "cp-merged into one lower" bucket that fits the budget.
@param lower Read-only lowers, leftmost = topmost. Must be non-empty.
- @param upper Writable upper directory (must be on the same
- filesystem as [work]).
+ @param upper
+ Writable upper directory (must be on the same filesystem as [work]).
@param work Overlayfs workdir — scratch, do not touch.
- @param target Mount point. Must already exist as an empty
- directory.
- @return [Ok ()] on success, or [Error (`Msg _)] if [mount] fails.
- Common failure modes include a too-long options string, a
- missing directory, or a permission error. *)
+ @param target Mount point. Must already exist as an empty directory.
+ @return
+ [Ok ()] on success, or [Error (`Msg _)] if [mount] fails. Common failure
+ modes include a too-long options string, a missing directory, or a
+ permission error. *)
val umount :
sw:Eio.Switch.t ->
Eio_unix.Stdenv.base ->
Fpath.t ->
(unit, [> Rresult.R.msg ]) result
-(** [umount ~sw env target] unmounts the overlay previously mounted at
- [target]. Safe to call on a directory that is not currently a
- mount point — the error is returned but callers typically
- [ignore] it inside cleanup handlers. *)
+(** [umount ~sw env target] unmounts the overlay previously mounted at [target].
+ Safe to call on a directory that is not currently a mount point — the error
+ is returned but callers typically [ignore] it inside cleanup handlers. *)
File "day11/container/runc.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/container/runc.ml b/_build/default/day11/container/.formatted/runc.ml
index 7afffbf..331259f 100644
--- a/_build/default/day11/container/runc.ml
+++ b/_build/default/day11/container/.formatted/runc.ml
@@ -1,13 +1,10 @@
let run ~sw env ~bundle ~container_id =
let cmd =
- Bos.Cmd.(v "runc" % "run" % "-b" % Fpath.to_string bundle
- % container_id)
+ Bos.Cmd.(v "runc" % "run" % "-b" % Fpath.to_string bundle % container_id)
in
let log_file = Fpath.(bundle / "runc.log") in
Day11_sys.Sudo.run ~output_file:log_file ~sw env cmd
let delete ~sw env container_id =
- let cmd =
- Bos.Cmd.(v "runc" % "delete" % "-f" % container_id)
- in
+ let cmd = Bos.Cmd.(v "runc" % "delete" % "-f" % container_id) in
Day11_sys.Sudo.run ~sw env cmd |> Result.map (fun _run -> ())
File "day11/container/runc.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/container/runc.mli b/_build/default/day11/container/.formatted/runc.mli
index 887da81..e84364b 100644
--- a/_build/default/day11/container/runc.mli
+++ b/_build/default/day11/container/.formatted/runc.mli
@@ -1,17 +1,14 @@
(** OCI container runtime: running and deleting containers via [runc].
- Thin wrapper over the [runc] command-line runtime. Both
- functions require [sudo] (runc uses Linux clone/namespace
- syscalls that need [CAP_SYS_ADMIN]).
-
- A container is identified by the pair of a {e bundle directory}
- on disk and a {e container id} string. The bundle directory
- must contain a [config.json] (OCI spec) and typically a
- rootfs path referenced from that spec. Use
- {!Oci_spec.make} + {!Oci_spec.write} to produce the config.
- Container ids are caller-chosen but must be unique on the host
- at the time of the [run] call — {!delete} cleans up any stale
- container with the same id first. *)
+ Thin wrapper over the [runc] command-line runtime. Both functions require
+ [sudo] (runc uses Linux clone/namespace syscalls that need [CAP_SYS_ADMIN]).
+
+ A container is identified by the pair of a {e bundle directory} on disk and
+ a {e container id} string. The bundle directory must contain a [config.json]
+ (OCI spec) and typically a rootfs path referenced from that spec. Use
+ {!Oci_spec.make} + {!Oci_spec.write} to produce the config. Container ids
+ are caller-chosen but must be unique on the host at the time of the [run]
+ call — {!delete} cleans up any stale container with the same id first. *)
val run :
sw:Eio.Switch.t ->
@@ -20,38 +17,34 @@ val run :
container_id:string ->
(Day11_sys.Run.t, [> Rresult.R.msg ]) result
(** [run ~sw env ~bundle ~container_id] executes
- [sudo runc run -b bundle container_id] and blocks until the
- container exits.
-
- {b Side effect:} runc's stdout and stderr are captured to
- [bundle/runc.log]. Callers that need to inspect the output can
- either read that file after the call returns, or use the
- {!Day11_sys.Run.t} value, whose [output]/[errors] fields
- contain the same data.
-
- The returned {!Day11_sys.Run.t} carries the container's final
- exit status in its [status] field: [`Exited n] for a normal
- exit and [`Signaled n] if the container was killed by a signal.
- A failed {e invocation} of runc itself (e.g. runc missing from
- [$PATH]) returns [Error _]; a non-zero exit from a container
- that ran to completion returns [Ok run] with a non-zero
+ [sudo runc run -b bundle container_id] and blocks until the container exits.
+
+ {b Side effect:} runc's stdout and stderr are captured to [bundle/runc.log].
+ Callers that need to inspect the output can either read that file after the
+ call returns, or use the {!Day11_sys.Run.t} value, whose [output]/[errors]
+ fields contain the same data.
+
+ The returned {!Day11_sys.Run.t} carries the container's final exit status in
+ its [status] field: [`Exited n] for a normal exit and [`Signaled n] if the
+ container was killed by a signal. A failed {e invocation} of runc itself
+ (e.g. runc missing from [$PATH]) returns [Error _]; a non-zero exit from a
+ container that ran to completion returns [Ok run] with a non-zero
[run.status]. Callers must distinguish the two.
- This function does not clean up the container after it exits.
- Always pair it with {!delete} inside a [Fun.protect] so that
- exceptions don't leak container state into runc's on-disk
- registry at [/run/runc/]. *)
+ This function does not clean up the container after it exits. Always pair it
+ with {!delete} inside a [Fun.protect] so that exceptions don't leak
+ container state into runc's on-disk registry at [/run/runc/]. *)
val delete :
sw:Eio.Switch.t ->
Eio_unix.Stdenv.base ->
string ->
(unit, [> Rresult.R.msg ]) result
-(** [delete ~sw env container_id] runs [sudo runc delete -f container_id]
- to forcefully remove a container from runc's registry,
- terminating it if it's still running. Safe to call on a
- non-existent id — the error is returned and can be ignored.
-
- Callers typically [ignore] the result, both before a run
- (to clear any stale state from a previous run that didn't
- clean up) and after, inside a [Fun.protect] finally handler. *)
+(** [delete ~sw env container_id] runs [sudo runc delete -f container_id] to
+ forcefully remove a container from runc's registry, terminating it if it's
+ still running. Safe to call on a non-existent id — the error is returned and
+ can be ignored.
+
+ Callers typically [ignore] the result, both before a run (to clear any stale
+ state from a previous run that didn't clean up) and after, inside a
+ [Fun.protect] finally handler. *)
File "day11/layer/base.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/base.ml b/_build/default/day11/layer/.formatted/base.ml
index 6435ed8..605b091 100644
--- a/_build/default/day11/layer/base.ml
+++ b/_build/default/day11/layer/.formatted/base.ml
@@ -1,5 +1 @@
-type t = {
- hash : string;
- dir : Fpath.t;
- image : string;
-}
+type t = { hash : string; dir : Fpath.t; image : string }
File "day11/layer/base.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/base.mli b/_build/default/day11/layer/.formatted/base.mli
index 2e86231..ea9150c 100644
--- a/_build/default/day11/layer/base.mli
+++ b/_build/default/day11/layer/.formatted/base.mli
@@ -1,13 +1,8 @@
(** The base image layer.
- A {!t} represents the foundational layer at the bottom of every
- overlay stack — typically a Debian rootfs imported from a Docker
- image, with opam preinstalled. Higher-level layer types (opam
- package builds, odoc doc layers) live in domain-specific
- libraries, e.g. [day11_opam_layer]. *)
+ A {!t} represents the foundational layer at the bottom of every overlay
+ stack — typically a Debian rootfs imported from a Docker image, with opam
+ preinstalled. Higher-level layer types (opam package builds, odoc doc
+ layers) live in domain-specific libraries, e.g. [day11_opam_layer]. *)
-type t = {
- hash : string;
- dir : Fpath.t;
- image : string;
-}
+type t = { hash : string; dir : Fpath.t; image : string }
File "day11/layer/day11_layer.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/day11_layer.ml b/_build/default/day11/layer/.formatted/day11_layer.ml
index 2a2d645..782a3b6 100644
--- a/_build/default/day11/layer/day11_layer.ml
+++ b/_build/default/day11/layer/.formatted/day11_layer.ml
@@ -1,7 +1,6 @@
(** Content-addressed layer storage.
- A layer is a directory on disk identified by its content hash.
- It contains:
+ A layer is a directory on disk identified by its content hash. It contains:
- [fs/] — the filesystem tree (overlayfs upper)
- [layer.json] — metadata ({!Meta.t})
- [layer.log] — build stdout/stderr
@@ -9,10 +8,7 @@
(** {1 Core type} *)
-type t = Layer.t = {
- hash : string;
- dir : Fpath.t;
-}
+type t = Layer.t = { hash : string; dir : Fpath.t }
include (Layer : module type of Layer with type t := t)
File "day11/layer/dir.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/dir.mli b/_build/default/day11/layer/.formatted/dir.mli
index c2d2d47..c145d72 100644
--- a/_build/default/day11/layer/dir.mli
+++ b/_build/default/day11/layer/.formatted/dir.mli
@@ -1,13 +1,13 @@
(** On-disk layer directory naming convention.
- All layers live in a directory whose name is derived from the
- layer's content hash. This module owns that convention so
- individual layer kinds don't have to know it. *)
+ All layers live in a directory whose name is derived from the layer's
+ content hash. This module owns that convention so individual layer kinds
+ don't have to know it. *)
val name : string -> string
-(** [name hash] returns the directory basename for a layer with full
- content hash [hash]. Uses the first 12 hex characters, producing
- e.g. ["c9f7404f9f87"]. *)
+(** [name hash] returns the directory basename for a layer with full content
+ hash [hash]. Uses the first 12 hex characters, producing e.g.
+ ["c9f7404f9f87"]. *)
val path : os_dir:Fpath.t -> string -> Fpath.t
(** [path ~os_dir hash] is [os_dir / name hash]. *)
File "day11/layer/hash.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/hash.ml b/_build/default/day11/layer/.formatted/hash.ml
index 2aa5314..407b27e 100644
--- a/_build/default/day11/layer/hash.ml
+++ b/_build/default/day11/layer/.formatted/hash.ml
@@ -2,8 +2,7 @@ let of_strings parts =
let s = String.concat "\000" parts in
Digest.string s |> Digest.to_hex
-let base_hash ~image =
- of_strings [ "base"; image ]
+let base_hash ~image = of_strings [ "base"; image ]
let layer_hash ~base_hash ~dep_hashes ~pkg =
of_strings ([ "layer"; base_hash; pkg ] @ dep_hashes)
File "day11/layer/hash.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/hash.mli b/_build/default/day11/layer/.formatted/hash.mli
index 9cfe9b6..d50eb5c 100644
--- a/_build/default/day11/layer/hash.mli
+++ b/_build/default/day11/layer/.formatted/hash.mli
@@ -1,18 +1,18 @@
(** Layer hash computation for cache identity.
- A layer hash uniquely identifies a layer's content based on its
- inputs. Two layers with the same hash are assumed identical and
- can be reused from cache. *)
+ A layer hash uniquely identifies a layer's content based on its inputs. Two
+ layers with the same hash are assumed identical and can be reused from
+ cache. *)
val of_strings : string list -> string
-(** [of_strings parts] computes a hex digest from the concatenation
- of [parts]. Used as the building block for all hash functions. *)
+(** [of_strings parts] computes a hex digest from the concatenation of [parts].
+ Used as the building block for all hash functions. *)
val base_hash : image:string -> string
(** [base_hash ~image] returns a hash identifying the base image. *)
val layer_hash :
base_hash:string -> dep_hashes:string list -> pkg:string -> string
-(** [layer_hash ~base_hash ~dep_hashes ~pkg] computes the cache key
- for a build layer. Depends on the base image, all transitive
- dependency layer hashes, and the package being built. *)
+(** [layer_hash ~base_hash ~dep_hashes ~pkg] computes the cache key for a build
+ layer. Depends on the base image, all transitive dependency layer hashes,
+ and the package being built. *)
File "day11/layer/import.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/import.ml b/_build/default/day11/layer/.formatted/import.ml
index 886f179..22011d4 100644
--- a/_build/default/day11/layer/import.ml
+++ b/_build/default/day11/layer/.formatted/import.ml
@@ -1,4 +1,5 @@
let src_log = Logs.Src.create "day11.layer.import" ~doc:"Layer import"
+
module Log = (val Logs.src_log src_log)
let from_docker ~sw env ~image ~layer_dir =
@@ -11,37 +12,37 @@ let from_docker ~sw env ~image ~layer_dir =
(* Create a stopped container from the image *)
Log.info (fun m -> m "Creating container from %s" image);
let create_run =
- Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "docker" % "create" % image) None
+ Day11_sys.Run.run ~sw env Bos.Cmd.(v "docker" % "create" % image) None
in
match create_run.status with
- | `Signaled n ->
- Rresult.R.error_msgf "docker create signaled %d" n
+ | `Signaled n -> Rresult.R.error_msgf "docker create signaled %d" n
| `Exited n when n <> 0 ->
- Rresult.R.error_msgf "docker create failed (exit %d): %s"
- n create_run.errors
- | _ ->
- let container_id = String.trim create_run.output in
- Log.info (fun m -> m "Exporting container %s" container_id);
- (* Export and extract with sudo to preserve ownership *)
- let export_run =
- Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "sh" % "-c"
- % Printf.sprintf "docker export %s | sudo tar x -C %s"
- container_id fs_s)
- None
- in
- (* Always clean up the temporary container *)
- let _rm =
- Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "docker" % "rm" % "-f" % container_id) None
- in
- match export_run.status with
- | `Exited 0 ->
- Log.info (fun m -> m "Imported %s to %a" image Fpath.pp layer_dir);
- Ok ()
- | `Exited n ->
- Rresult.R.error_msgf "docker export failed (exit %d): %s"
- n export_run.errors
- | `Signaled n ->
- Rresult.R.error_msgf "docker export signaled %d" n
+ Rresult.R.error_msgf "docker create failed (exit %d): %s" n
+ create_run.errors
+ | _ -> (
+ let container_id = String.trim create_run.output in
+ Log.info (fun m -> m "Exporting container %s" container_id);
+ (* Export and extract with sudo to preserve ownership *)
+ let export_run =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(
+ v "sh"
+ % "-c"
+ % Printf.sprintf "docker export %s | sudo tar x -C %s" container_id
+ fs_s)
+ None
+ in
+ (* Always clean up the temporary container *)
+ let _rm =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(v "docker" % "rm" % "-f" % container_id)
+ None
+ in
+ match export_run.status with
+ | `Exited 0 ->
+ Log.info (fun m -> m "Imported %s to %a" image Fpath.pp layer_dir);
+ Ok ()
+ | `Exited n ->
+ Rresult.R.error_msgf "docker export failed (exit %d): %s" n
+ export_run.errors
+ | `Signaled n -> Rresult.R.error_msgf "docker export signaled %d" n)
File "day11/layer/import.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/import.mli b/_build/default/day11/layer/.formatted/import.mli
index d5841a7..0b2ecde 100644
--- a/_build/default/day11/layer/import.mli
+++ b/_build/default/day11/layer/.formatted/import.mli
@@ -6,9 +6,9 @@ val from_docker :
image:string ->
layer_dir:Fpath.t ->
(unit, [> Rresult.R.msg ]) result
-(** [from_docker ~sw env ~image ~layer_dir] extracts the filesystem of a
- Docker image into [layer_dir/fs/]. Creates a temporary container
- via [docker create], exports it with [docker export], and extracts
- the tarball. The temporary container is removed afterward.
+(** [from_docker ~sw env ~image ~layer_dir] extracts the filesystem of a Docker
+ image into [layer_dir/fs/]. Creates a temporary container via
+ [docker create], exports it with [docker export], and extracts the tarball.
+ The temporary container is removed afterward.
The image is pulled if not already present locally. *)
File "day11/layer/last_used.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/last_used.ml b/_build/default/day11/layer/.formatted/last_used.ml
index 2c5478a..f42ec0f 100644
--- a/_build/default/day11/layer/last_used.ml
+++ b/_build/default/day11/layer/.formatted/last_used.ml
@@ -1,5 +1,4 @@
let sentinel = "last_used"
-
let eio_path env p = Eio.Path.(env#fs / Fpath.to_string p)
let touch env layer_dir =
@@ -7,8 +6,7 @@ let touch env layer_dir =
let ep = eio_path env path in
try
(* Create the file if it doesn't exist. *)
- Eio.Path.with_open_out ~create:(`If_missing 0o644) ep
- (fun _ -> ());
+ Eio.Path.with_open_out ~create:(`If_missing 0o644) ep (fun _ -> ());
(* Update mtime to now via a systhread; Eio.Path has no utimes. *)
let path_s = Fpath.to_string path in
Eio_unix.run_in_systhread (fun () -> Unix.utimes path_s 0.0 0.0)
@@ -16,5 +14,4 @@ let touch env layer_dir =
let get env layer_dir =
let ep = eio_path env Fpath.(layer_dir / sentinel) in
- try Some (Eio.Path.stat ~follow:true ep).mtime
- with _ -> None
+ try Some (Eio.Path.stat ~follow:true ep).mtime with _ -> None
File "day11/layer/last_used.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/last_used.mli b/_build/default/day11/layer/.formatted/last_used.mli
index 38c88c1..b560efe 100644
--- a/_build/default/day11/layer/last_used.mli
+++ b/_build/default/day11/layer/.formatted/last_used.mli
@@ -1,20 +1,18 @@
(** Per-layer "last used" timestamp for LRU cache eviction.
- Each layer has a [last_used] sentinel file in its directory whose
- mtime records the most recent access. The file's content is
- irrelevant — only its mtime matters.
+ Each layer has a [last_used] sentinel file in its directory whose mtime
+ records the most recent access. The file's content is irrelevant — only its
+ mtime matters.
- This is deliberately split off from {!Meta} so that marking
- a layer as used is cheap — just [utimensat] on a small sentinel
- file, no JSON read/write. *)
+ This is deliberately split off from {!Meta} so that marking a layer as used
+ is cheap — just [utimensat] on a small sentinel file, no JSON read/write. *)
val touch : Eio_unix.Stdenv.base -> Fpath.t -> unit
-(** [touch env layer_dir] records that the layer has just been accessed.
- Creates [layer_dir/last_used] if it doesn't exist, or updates its
- mtime if it does. Errors are silently ignored — touch must never
- fail a build. *)
+(** [touch env layer_dir] records that the layer has just been accessed. Creates
+ [layer_dir/last_used] if it doesn't exist, or updates its mtime if it does.
+ Errors are silently ignored — touch must never fail a build. *)
val get : Eio_unix.Stdenv.base -> Fpath.t -> float option
-(** [get env layer_dir] returns the unix timestamp (seconds since epoch)
- of the last touch, or [None] if the sentinel file doesn't exist
- or can't be stat'd. *)
+(** [get env layer_dir] returns the unix timestamp (seconds since epoch) of the
+ last touch, or [None] if the sentinel file doesn't exist or can't be stat'd.
+*)
File "day11/layer/layer.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/layer.ml b/_build/default/day11/layer/.formatted/layer.ml
index 1be775a..44b4c06 100644
--- a/_build/default/day11/layer/layer.ml
+++ b/_build/default/day11/layer/.formatted/layer.ml
@@ -1,7 +1,4 @@
-type t = {
- hash : string;
- dir : Fpath.t;
-}
+type t = { hash : string; dir : Fpath.t }
let of_hash ~os_dir hash =
let len = min 12 (String.length hash) in
@@ -13,9 +10,7 @@ let dir t = t.dir
let fs t = Fpath.(t.dir / "fs")
let meta_path t = Fpath.(t.dir / "layer.json")
let log_path t = Fpath.(t.dir / "layer.log")
-
-let pp f t =
- Fmt.pf f "%s" (String.sub t.hash 0 (min 12 (String.length t.hash)))
+let pp f t = Fmt.pf f "%s" (String.sub t.hash 0 (min 12 (String.length t.hash)))
let exists env t =
Eio.Path.is_file Eio.Path.(env#fs / Fpath.to_string (meta_path t))
File "day11/layer/layer.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/layer.mli b/_build/default/day11/layer/.formatted/layer.mli
index 11558a6..e057ec6 100644
--- a/_build/default/day11/layer/layer.mli
+++ b/_build/default/day11/layer/.formatted/layer.mli
@@ -1,23 +1,21 @@
(** A layer on disk.
- A layer is identified by its content hash and lives at a directory
- derived from that hash under the os_dir. The directory contains:
+ A layer is identified by its content hash and lives at a directory derived
+ from that hash under the os_dir. The directory contains:
- [fs/] — the filesystem tree (overlayfs upper)
- [layer.json] — metadata ({!Meta.t})
- [layer.log] — build stdout/stderr
- optional sidecar files ([build.json], [doc.json], etc.) *)
-type t = {
- hash : string;
- dir : Fpath.t;
-}
+type t = { hash : string; dir : Fpath.t }
val of_hash : os_dir:Fpath.t -> string -> t
-(** [of_hash ~os_dir hash] constructs a layer reference from a hash.
- Does not check whether the layer exists on disk. *)
+(** [of_hash ~os_dir hash] constructs a layer reference from a hash. Does not
+ check whether the layer exists on disk. *)
val hash : t -> string
val dir : t -> Fpath.t
+
val fs : t -> Fpath.t
(** [fs t] is [t.dir / "fs"]. *)
File "day11/layer/layer_status.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/layer_status.ml b/_build/default/day11/layer/.formatted/layer_status.ml
index c086cfa..56339e8 100644
--- a/_build/default/day11/layer/layer_status.ml
+++ b/_build/default/day11/layer/.formatted/layer_status.ml
@@ -1,45 +1,43 @@
-type entry = {
- hash : string;
- exit_status : int;
- ts : string;
-}
+type entry = { hash : string; exit_status : int; ts : string }
let path os_dir = Fpath.(os_dir / "layer_status.jsonl")
let now_iso8601 () =
let t = Unix.gettimeofday () in
let tm = Unix.gmtime t in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min tm.tm_sec
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (tm.tm_year + 1900)
+ (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
let entry_to_line e =
- Yojson.Safe.to_string (`Assoc [
- "hash", `String e.hash;
- "exit_status", `Int e.exit_status;
- "ts", `String e.ts;
- ]) ^ "\n"
+ Yojson.Safe.to_string
+ (`Assoc
+ [
+ ("hash", `String e.hash);
+ ("exit_status", `Int e.exit_status);
+ ("ts", `String e.ts);
+ ])
+ ^ "\n"
let entry_of_line line =
try
let json = Yojson.Safe.from_string line in
let open Yojson.Safe.Util in
- Some {
- hash = json |> member "hash" |> to_string;
- exit_status = json |> member "exit_status" |> to_int;
- ts = json |> member "ts" |> to_string;
- }
+ Some
+ {
+ hash = json |> member "hash" |> to_string;
+ exit_status = json |> member "exit_status" |> to_int;
+ ts = json |> member "ts" |> to_string;
+ }
with _ -> None
-(** Process-wide mutex serialising appends. The kernel's O_APPEND
- serialises across processes; the mutex serialises across our own
- workers so we issue one syscall per line cleanly. *)
+(** Process-wide mutex serialising appends. The kernel's O_APPEND serialises
+ across processes; the mutex serialises across our own workers so we issue
+ one syscall per line cleanly. *)
let append_mutex = Mutex.create ()
-(** Normalise to the 12-char prefix used as the layer dir name —
- that's the form already on disk and what callers query with. *)
-let normalise_hash h =
- String.sub h 0 (min 12 (String.length h))
+(** Normalise to the 12-char prefix used as the layer dir name — that's the form
+ already on disk and what callers query with. *)
+let normalise_hash h = String.sub h 0 (min 12 (String.length h))
let append ~os_dir ~hash ~exit_status =
let hash = normalise_hash hash in
@@ -48,46 +46,48 @@ let append ~os_dir ~hash ~exit_status =
Mutex.lock append_mutex;
let finally () = Mutex.unlock append_mutex in
Fun.protect ~finally (fun () ->
- let fd = Unix.openfile p
- [ Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT ] 0o644 in
- let bytes = Bytes.unsafe_of_string line in
- let len = Bytes.length bytes in
- let n = Unix.write fd bytes 0 len in
- Unix.close fd;
- if n <> len then
- Printf.eprintf "Layer_status.append: short write %d/%d for %s\n%!"
- n len hash)
+ let fd =
+ Unix.openile p [ Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT ] 0o644
+ in
+ let bytes = Bytes.unsafe_of_string line in
+ let len = Bytes.length bytes in
+ let n = Unix.write fd bytes 0 len in
+ Unix.close fd;
+ if n <> len then
+ Printf.eprintf "Layer_status.append: short write %d/%d for %s\n%!" n len
+ hash)
-(** Bootstrap: scan every [<os_dir>/<short>/layer.json], compose
- entries, write atomically via temp+rename so racing processes
- can't see a partial file. Returns the freshly-built table without
- re-reading the just-written file. *)
+(** Bootstrap: scan every [<os_dir>/<short>/layer.json], compose entries, write
+ atomically via temp+rename so racing processes can't see a partial file.
+ Returns the freshly-built table without re-reading the just-written file. *)
let bootstrap_from_disk os_dir =
let table : (string, entry) Hashtbl.t = Hashtbl.create 32768 in
let os_dir_s = Fpath.to_string os_dir in
if not (Sys.file_exists os_dir_s) then table
- else begin
+ else
let entries = Sys.readdir os_dir_s in
- Array.iter (fun name ->
- (* layer dirs are 12-char hex; skip everything else (locks,
+ Array.iter
+ (fun name ->
+ (* layer dirs are 12-char hex; skip everything else (locks,
markers, the layer_status.jsonl file itself, etc.) *)
- if String.length name = 12 then begin
- let layer_json = Filename.concat (Filename.concat os_dir_s name)
- "layer.json" in
- match In_channel.with_open_text layer_json In_channel.input_all with
- | exception _ -> ()
- | s ->
- try
- let json = Yojson.Safe.from_string s in
- let exit_status =
- json |> Yojson.Safe.Util.member "exit_status"
- |> Yojson.Safe.Util.to_int
- in
- let e = { hash = name; exit_status; ts = now_iso8601 () } in
- Hashtbl.replace table name e
- with _ -> ()
- end
- ) entries;
+ if String.length name = 12 then
+ let layer_json =
+ Filename.concat (Filename.concat os_dir_s name) "layer.json"
+ in
+ match In_channel.with_open_text layer_json In_channel.input_all with
+ | exception _ -> ()
+ | s -> (
+ try
+ let json = Yojson.Safe.from_string s in
+ let exit_status =
+ json
+ |> Yojson.Safe.Util.member "exit_status"
+ |> Yojson.Safe.Util.to_int
+ in
+ let e = { hash = name; exit_status; ts = now_iso8601 () } in
+ Hashtbl.replace table name e
+ with _ -> ()))
+ entries;
(* Atomically materialise the file. *)
let final_path = Fpath.to_string (path os_dir) in
let tmp_path = Printf.sprintf "%s.tmp.%d" final_path (Unix.getpid ()) in
@@ -95,28 +95,28 @@ let bootstrap_from_disk os_dir =
Hashtbl.iter (fun _ e -> output_string oc (entry_to_line e)) table;
close_out oc;
(try Unix.rename tmp_path final_path
- with _ -> (try Sys.remove tmp_path with _ -> ()));
+ with _ -> ( try Sys.remove tmp_path with _ -> ()));
table
- end
let load ~os_dir =
let p = path os_dir in
let p_s = Fpath.to_string p in
if not (Sys.file_exists p_s) then bootstrap_from_disk os_dir
- else begin
+ else
let table : (string, entry) Hashtbl.t = Hashtbl.create 32768 in
let ic = open_in p_s in
- Fun.protect ~finally:(fun () -> close_in_noerr ic) (fun () ->
- try
- while true do
- let line = input_line ic in
- if line <> "" then
- match entry_of_line line with
- | Some e ->
- let key = normalise_hash e.hash in
- Hashtbl.replace table key { e with hash = key }
- | None -> ()
- done
- with End_of_file -> ());
+ Fun.protect
+ ~finally:(fun () -> close_in_noerr ic)
+ (fun () ->
+ try
+ while true do
+ let line = input_line ic in
+ if line <> "" then
+ match entry_of_line line with
+ | Some e ->
+ let key = normalise_hash e.hash in
+ Hashtbl.replace table key { e with hash = key }
+ | None -> ()
+ done
+ with End_of_file -> ());
table
- end
File "day11/layer/layer_status.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/layer_status.mli b/_build/default/day11/layer/.formatted/layer_status.mli
index c7a3dda..0492e3b 100644
--- a/_build/default/day11/layer/layer_status.mli
+++ b/_build/default/day11/layer/.formatted/layer_status.mli
@@ -1,36 +1,30 @@
(** Durable per-os-dir log of layer finalisation outcomes.
- Stored at [<os_dir>/layer_status.jsonl] as one JSON object per
- line: [{"hash":"…32hex","exit_status":0,"ts":"…"}]. Append-only;
- last entry per hash wins on read.
+ Stored at [<os_dir>/layer_status.jsonl] as one JSON object per line:
+ [{"hash":"…32hex","exit_status":0,"ts":"…"}]. Append-only; last entry per
+ hash wins on read.
- This file exists so callers can answer "what's the durable state
- of every layer?" without doing 25k+ small file reads against
- [layer.json] sidecars. {!load} reads and parses one file; {!append}
- writes one line per layer-finalisation event.
+ This file exists so callers can answer "what's the durable state of every
+ layer?" without doing 25k+ small file reads against [layer.json] sidecars.
+ {!load} reads and parses one file; {!append} writes one line per
+ layer-finalisation event.
Bootstrap: on first {!load} the file is created by walking
- [<os_dir>/*/layer.json] and reading each meta. That's slow
- (~7s on a 25k-layer cache), but it only happens once. Every
- subsequent finalisation appends, so {!load} stays cheap. *)
+ [<os_dir>/*/layer.json] and reading each meta. That's slow (~7s on a
+ 25k-layer cache), but it only happens once. Every subsequent finalisation
+ appends, so {!load} stays cheap. *)
-type entry = {
- hash : string;
- exit_status : int;
- ts : string;
-}
+type entry = { hash : string; exit_status : int; ts : string }
val path : Fpath.t -> Fpath.t
-val append :
- os_dir:Fpath.t -> hash:string -> exit_status:int -> unit
-(** Atomic single-syscall append, serialised within the process by an
- internal mutex so multiple build workers finishing simultaneously
- don't tear lines. Uses [O_APPEND] for protection against external
- writers (other day11 processes against the same os_dir). *)
+val append : os_dir:Fpath.t -> hash:string -> exit_status:int -> unit
+(** Atomic single-syscall append, serialised within the process by an internal
+ mutex so multiple build workers finishing simultaneously don't tear lines.
+ Uses [O_APPEND] for protection against external writers (other day11
+ processes against the same os_dir). *)
val load : os_dir:Fpath.t -> (string, entry) Hashtbl.t
-(** [load ~os_dir] returns [hash → latest entry] for every layer ever
- recorded. Bootstraps the file by walking on-disk layers if it
- doesn't exist yet — that first call takes seconds, every later
- call milliseconds. *)
+(** [load ~os_dir] returns [hash → latest entry] for every layer ever recorded.
+ Bootstraps the file by walking on-disk layers if it doesn't exist yet — that
+ first call takes seconds, every later call milliseconds. *)
File "day11/layer/meta.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/meta.ml b/_build/default/day11/layer/.formatted/meta.ml
index df026d5..c489ec8 100644
--- a/_build/default/day11/layer/meta.ml
+++ b/_build/default/day11/layer/.formatted/meta.ml
@@ -3,23 +3,24 @@
type timing = (string * float) list
let empty_timing : timing = []
-
-let timing_field name t =
- try List.assoc name t with Not_found -> 0.0
+let timing_field name t = try List.assoc name t with Not_found -> 0.0
let timing_to_yojson (t : timing) : Yojson.Safe.t =
`Assoc (List.map (fun (k, v) -> (k, `Float v)) t)
let timing_of_yojson (json : Yojson.Safe.t) : (timing, string) result =
match json with
- | `Assoc kvs ->
- (try
- Ok (List.map (fun (k, v) ->
- match v with
- | `Float f -> (k, f)
- | `Int i -> (k, float_of_int i)
- | _ -> failwith "timing value must be a number") kvs)
- with Failure m -> Error m)
+ | `Assoc kvs -> (
+ try
+ Ok
+ (List.map
+ (fun (k, v) ->
+ match v with
+ | `Float f -> (k, f)
+ | `Int i -> (k, float_of_int i)
+ | _ -> failwith "timing value must be a number")
+ kvs)
+ with Failure m -> Error m)
| `Null -> Ok []
| _ -> Error "timing must be a JSON object"
@@ -35,29 +36,28 @@ type t = {
timing : timing; [@default empty_timing]
created_at : string;
failed_dep : string option; [@default None]
-} [@@deriving yojson { strict = false }]
+}
+[@@deriving yojson { strict = false }]
(* ── (de)serialization ────────────────────────────────────────── *)
let now_iso8601 env =
let t = Eio.Time.now env#clock in
let tm = Unix.gmtime t in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min tm.tm_sec
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (tm.tm_year + 1900)
+ (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
let eio_path env p = Eio.Path.(env#fs / Fpath.to_string p)
let save ?created_at env path t =
- let created_at = match created_at with
+ let created_at =
+ match created_at with
| Some s -> s
- | None ->
- if t.created_at = "" then now_iso8601 env else t.created_at
+ | None -> if t.created_at = "" then now_iso8601 env else t.created_at
in
let t = { t with created_at } in
try
- Eio.Path.save ~create:(`Or_truncate 0o644)
- (eio_path env path)
+ Eio.Path.save ~create:(`Or_truncate 0o644) (eio_path env path)
(Yojson.Safe.to_string (to_yojson t));
Ok ()
with exn ->
@@ -70,14 +70,15 @@ let load env path =
Rresult.R.error_msgf "load %a: %s" Fpath.pp path (Printexc.to_string exn)
with
| Error _ as e -> e
- | Ok s ->
- match
- try Ok (Yojson.Safe.from_string s)
- with exn ->
- Rresult.R.error_msgf "parse %a: %s" Fpath.pp path (Printexc.to_string exn)
- with
- | Error _ as e -> e
- | Ok json ->
- match of_yojson json with
- | Ok v -> Ok v
- | Error msg -> Rresult.R.error_msgf "load %a: %s" Fpath.pp path msg
+ | Ok s -> (
+ match
+ try Ok (Yojson.Safe.from_string s)
+ with exn ->
+ Rresult.R.error_msgf "parse %a: %s" Fpath.pp path
+ (Printexc.to_string exn)
+ with
+ | Error _ as e -> e
+ | Ok json -> (
+ match of_yojson json with
+ | Ok v -> Ok v
+ | Error msg -> Rresult.R.error_msgf "load %a: %s" Fpath.pp path msg))
File "day11/layer/meta.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/meta.mli b/_build/default/day11/layer/.formatted/meta.mli
index 7d794cd..7ca7ce4 100644
--- a/_build/default/day11/layer/meta.mli
+++ b/_build/default/day11/layer/.formatted/meta.mli
@@ -1,39 +1,36 @@
(** Generic per-layer metadata, serialized as [layer.json].
- Every layer of every kind has a [layer.json] file holding a
- {!t} record. The record contains only information that is
- meaningful for any layer regardless of what built it: how the
- container exited, which parents it stacked on, who the build
- user was, what time it took, when it was created.
+ Every layer of every kind has a [layer.json] file holding a {!t} record. The
+ record contains only information that is meaningful for any layer regardless
+ of what built it: how the container exited, which parents it stacked on, who
+ the build user was, what time it took, when it was created.
{1 Sidecar convention}
- Domain-specific information (the package being built, installed
- files, applied patches, odoc phase, etc.) lives in {b sidecar}
- files in the same directory and is owned by the relevant domain
- library. The "kind" of a layer is determined by which sidecar
- files are present:
+ Domain-specific information (the package being built, installed files,
+ applied patches, odoc phase, etc.) lives in {b sidecar} files in the same
+ directory and is owned by the relevant domain library. The "kind" of a layer
+ is determined by which sidecar files are present:
- - [build.json] (see [Day11_opam_layer.Build_meta]) marks an
- opam package build layer
- - [doc.json] (see [Day11_opam_layer.Doc_meta]) marks an odoc
- doc layer
+ - [build.json] (see [Day11_opam_layer.Build_meta]) marks an opam package
+ build layer
+ - [doc.json] (see [Day11_opam_layer.Doc_meta]) marks an odoc doc layer
- future kinds add their own sidecars
- {b Sidecar files MUST be valid JSON} (typically a single object
- at the top level). The generic library does not enforce this —
- no part of [day11_layer] reads sidecars — but tools that walk
- the cache rely on the convention to display layer contents
- without needing the relevant domain library linked in.
+ {b Sidecar files MUST be valid JSON} (typically a single object at the top
+ level). The generic library does not enforce this — no part of [day11_layer]
+ reads sidecars — but tools that walk the cache rely on the convention to
+ display layer contents without needing the relevant domain library linked
+ in.
- LRU access bookkeeping is kept separate — see {!Last_used} — so
- touching a layer doesn't rewrite its JSON.
+ LRU access bookkeeping is kept separate — see {!Last_used} — so touching a
+ layer doesn't rewrite its JSON.
{1 Phase timing}
Build pipelines record per-phase timing as a free-form
- [(string * float) list]. Phase names are not validated; readers
- that want a specific well-known phase use {!timing_field}. *)
+ [(string * float) list]. Phase names are not validated; readers that want a
+ specific well-known phase use {!timing_field}. *)
type timing = (string * float) list
@@ -44,26 +41,25 @@ val timing_field : string -> timing -> float
type t = {
exit_status : int;
- (** Exit status of the build process: 0 = success, anything else
- is a failure. *)
+ (** Exit status of the build process: 0 = success, anything else is a
+ failure. *)
parent_hashes : string list;
- (** Full hashes of the layers that were stacked as the lowers of
- the overlay during the build, in the order they were stacked.
- For domain types that also carry their own dep records (e.g.
- opam package strings), the parallel list lives in the sidecar. *)
+ (** Full hashes of the layers that were stacked as the lowers of the
+ overlay during the build, in the order they were stacked. For domain
+ types that also carry their own dep records (e.g. opam package
+ strings), the parallel list lives in the sidecar. *)
uid : int;
gid : int;
base_hash : string;
- (** Hash of the base image layer at the bottom of the overlay. *)
- disk_usage : int;
- (** Approximate size in bytes of the layer's [fs/] tree. *)
+ (** Hash of the base image layer at the bottom of the overlay. *)
+ disk_usage : int; (** Approximate size in bytes of the layer's [fs/] tree. *)
timing : timing;
created_at : string;
- (** ISO-8601 UTC timestamp of when the layer was extracted. *)
+ (** ISO-8601 UTC timestamp of when the layer was extracted. *)
failed_dep : string option;
- (** [Some name] for layers that didn't run because a dependency
- build failed. [None] for layers that ran to completion (whether
- successfully or with a non-zero exit). *)
+ (** [Some name] for layers that didn't run because a dependency build
+ failed. [None] for layers that ran to completion (whether successfully
+ or with a non-zero exit). *)
}
(** {1 Read and write} *)
@@ -71,12 +67,12 @@ type t = {
val save :
?created_at:string ->
Eio_unix.Stdenv.base ->
- Fpath.t -> t -> (unit, [> Rresult.R.msg ]) result
-(** [save env path t] writes [t] to [path] as JSON. If [?created_at]
- is supplied, it overrides [t.created_at]; if omitted and
- [t.created_at] is empty, the current UTC time is used. *)
+ Fpath.t ->
+ t ->
+ (unit, [> Rresult.R.msg ]) result
+(** [save env path t] writes [t] to [path] as JSON. If [?created_at] is
+ supplied, it overrides [t.created_at]; if omitted and [t.created_at] is
+ empty, the current UTC time is used. *)
-val load :
- Eio_unix.Stdenv.base ->
- Fpath.t -> (t, [> Rresult.R.msg ]) result
+val load : Eio_unix.Stdenv.base -> Fpath.t -> (t, [> Rresult.R.msg ]) result
(** [load env path] reads and parses a [layer.json]. *)
File "day11/layer/relocations.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/relocations.ml b/_build/default/day11/layer/.formatted/relocations.ml
index feb83bd..a1bf209 100644
--- a/_build/default/day11/layer/relocations.ml
+++ b/_build/default/day11/layer/.formatted/relocations.ml
@@ -17,14 +17,13 @@ let eio_path env p = Eio.Path.(env#fs / Fpath.to_string p)
let scan_file env path needles =
match Eio.Path.load (eio_path env path) with
| exception _ -> []
- | content ->
- List.concat_map (fun needle -> find_all ~needle content) needles
+ | content -> List.concat_map (fun needle -> find_all ~needle content) needles
(* -- Tree walk ----------------------------------------------------------- *)
let scan env ~layer_fs ~forbidden =
if forbidden = [] then []
- else begin
+ else
let results = ref [] in
let root = Fpath.to_string layer_fs in
let root_len = String.length root in
@@ -33,72 +32,71 @@ let scan env ~layer_fs ~forbidden =
match Eio.Path.read_dir dir_ep with
| exception _ -> ()
| entries ->
- List.iter (fun name ->
- let abs = Filename.concat dir name in
- let abs_ep = eio_path env (Fpath.v abs) in
- match Eio.Path.stat ~follow:false abs_ep with
- | exception _ -> ()
- | (st : Eio.File.Stat.t) ->
- match st.kind with
- | `Directory -> walk abs
- | `Regular_file ->
- let hits = scan_file env (Fpath.v abs) forbidden in
- if hits <> [] then begin
- let rel =
- if String.length abs > root_len
- && String.sub abs 0 root_len = root
- && abs.[root_len] = '/'
- then String.sub abs (root_len + 1)
- (String.length abs - root_len - 1)
- else abs
- in
- results := (rel, hits) :: !results
- end
- | _ -> ()
- ) entries
+ List.iter
+ (fun name ->
+ let abs = Filename.concat dir name in
+ let abs_ep = eio_path env (Fpath.v abs) in
+ match Eio.Path.stat ~follow:false abs_ep with
+ | exception _ -> ()
+ | (st : Eio.File.Stat.t) -> (
+ match st.kind with
+ | `Directory -> walk abs
+ | `Regular_file ->
+ let hits = scan_file env (Fpath.v abs) forbidden in
+ if hits <> [] then
+ let rel =
+ if
+ String.length abs > root_len
+ && String.sub abs 0 root_len = root
+ && abs.[root_len] = '/'
+ then
+ String.sub abs (root_len + 1)
+ (String.length abs - root_len - 1)
+ else abs
+ in
+ results := (rel, hits) :: !results
+ | _ -> ()))
+ entries
in
if Eio.Path.is_directory (eio_path env layer_fs) then walk root;
List.rev !results
- end
(* -- Persistence --------------------------------------------------------- *)
let to_json t : Yojson.Safe.t =
- `Assoc (List.map (fun (path, hits) ->
- (path, `List (List.map (fun s -> `String s) hits))
- ) t)
+ `Assoc
+ (List.map
+ (fun (path, hits) -> (path, `List (List.map (fun s -> `String s) hits)))
+ t)
let of_json (j : Yojson.Safe.t) : (string * string list) list option =
match j with
- | `Assoc items ->
- (try
- Some (List.map (fun (k, v) ->
- match v with
- | `List strs ->
- let hits = List.map (function
- | `String s -> s
- | _ -> raise Exit
- ) strs in
- (k, hits)
- | _ -> raise Exit
- ) items)
- with Exit -> None)
+ | `Assoc items -> (
+ try
+ Some
+ (List.map
+ (fun (k, v) ->
+ match v with
+ | `List strs ->
+ let hits =
+ List.map (function `String s -> s | _ -> raise Exit) strs
+ in
+ (k, hits)
+ | _ -> raise Exit)
+ items)
+ with Exit -> None)
| _ -> None
let save env path t =
let json = to_json t in
try
- Eio.Path.save ~create:(`Or_truncate 0o644)
- (eio_path env path)
+ Eio.Path.save ~create:(`Or_truncate 0o644) (eio_path env path)
(Yojson.Safe.pretty_to_string json);
Ok ()
with exn ->
- Rresult.R.error_msgf "save %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ Rresult.R.error_msgf "save %a: %s" Fpath.pp path (Printexc.to_string exn)
let load env path =
match Eio.Path.load (eio_path env path) with
| exception _ -> None
- | content ->
- try of_json (Yojson.Safe.from_string content)
- with _ -> None
+ | content -> ( try of_json (Yojson.Safe.from_string content) with _ -> None)
File "day11/layer/relocations.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/relocations.mli b/_build/default/day11/layer/.formatted/relocations.mli
index 5c91513..aea7e8f 100644
--- a/_build/default/day11/layer/relocations.mli
+++ b/_build/default/day11/layer/.formatted/relocations.mli
@@ -1,39 +1,37 @@
(** Scan a layer's [fs/] tree for non-relocatable path references.
- Layers are portable between backends and machines only if the
- files inside them do not embed absolute paths that are specific
- to the build environment (e.g. [/tmp/day11_native_ABC/_opam/...]).
+ Layers are portable between backends and machines only if the files inside
+ them do not embed absolute paths that are specific to the build environment
+ (e.g. [/tmp/day11_native_ABC/_opam/...]).
- {!scan} walks a layer's [fs/] and checks every regular file for
- occurrences of any [forbidden] substring. Binary files
- (detected by NUL in the first few KB) are searched byte-wise;
- text files are searched line by line. Results are stored as a
- [relocations.json] sidecar.
+ {!scan} walks a layer's [fs/] and checks every regular file for occurrences
+ of any [forbidden] substring. Binary files (detected by NUL in the first few
+ KB) are searched byte-wise; text files are searched line by line. Results
+ are stored as a [relocations.json] sidecar.
- Empty relocations = portable. A non-empty list means the layer
- carries build-time paths that a consumer won't be able to
- resolve. *)
+ Empty relocations = portable. A non-empty list means the layer carries
+ build-time paths that a consumer won't be able to resolve. *)
val scan :
Eio_unix.Stdenv.base ->
layer_fs:Fpath.t ->
forbidden:string list ->
(string * string list) list
-(** [scan env ~layer_fs ~forbidden] walks [layer_fs] and returns, for
- each file that contains at least one [forbidden] substring,
- a pair [(rel_path, occurrences)]. [occurrences] is a flat list
- of the forbidden strings found in the file (possibly with
- duplicates if a single forbidden string appears more than once).
+(** [scan env ~layer_fs ~forbidden] walks [layer_fs] and returns, for each file
+ that contains at least one [forbidden] substring, a pair
+ [(rel_path, occurrences)]. [occurrences] is a flat list of the forbidden
+ strings found in the file (possibly with duplicates if a single forbidden
+ string appears more than once).
Skips symlinks, sockets, pipes, devices. *)
val save :
Eio_unix.Stdenv.base ->
- Fpath.t -> (string * string list) list -> (unit, [> Rresult.R.msg ]) result
+ Fpath.t ->
+ (string * string list) list ->
+ (unit, [> Rresult.R.msg ]) result
(** [save env path t] writes [t] as JSON to [path]. *)
-val load :
- Eio_unix.Stdenv.base ->
- Fpath.t -> (string * string list) list option
-(** [load env path] reads and parses a [relocations.json]. Returns
- [None] if the file doesn't exist or can't be parsed. *)
+val load : Eio_unix.Stdenv.base -> Fpath.t -> (string * string list) list option
+(** [load env path] reads and parses a [relocations.json]. Returns [None] if the
+ file doesn't exist or can't be parsed. *)
File "day11/layer/scan.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/scan.ml b/_build/default/day11/layer/.formatted/scan.ml
index 6b32111..c45426c 100644
--- a/_build/default/day11/layer/scan.ml
+++ b/_build/default/day11/layer/.formatted/scan.ml
@@ -6,10 +6,10 @@ let list_layers env dir =
try
Eio.Path.read_dir ep
|> List.filter_map (fun name ->
- let child = Fpath.(dir / name) in
- if Eio.Path.is_directory (eio_path env child) then
- Some (name, child)
- else None)
+ let child = Fpath.(dir / name) in
+ if Eio.Path.is_directory (eio_path env child) then
+ Some (name, child)
+ else None)
with _ -> []
else []
@@ -20,14 +20,13 @@ let list_package_symlinks ?(exclude = []) env packages_dir pkg_str =
try
Eio.Path.read_dir ep
|> List.filter_map (fun name ->
- if List.mem name exclude then None
- else
- let child = eio_path env Fpath.(pkg_dir / name) in
- match Eio.Path.stat ~follow:false child with
- | stat when stat.kind = `Symbolic_link ->
- (try Some (name, Eio.Path.read_link child)
- with _ -> None)
- | _ -> None
- | exception _ -> None)
+ if List.mem name exclude then None
+ else
+ let child = eio_path env Fpath.(pkg_dir / name) in
+ match Eio.Path.stat ~follow:false child with
+ | stat when stat.kind = `Symbolic_link -> (
+ try Some (name, Eio.Path.read_link child) with _ -> None)
+ | _ -> None
+ | exception _ -> None)
with _ -> []
else []
File "day11/layer/scan.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/scan.mli b/_build/default/day11/layer/.formatted/scan.mli
index 49262d8..c515ba8 100644
--- a/_build/default/day11/layer/scan.mli
+++ b/_build/default/day11/layer/.formatted/scan.mli
@@ -1,18 +1,15 @@
(** Filesystem scanning for layer discovery.
- Enumerates layers and packages from the on-disk cache structure.
- All functions are generic — the caller interprets directory names
- and applies any prefix-based filtering. *)
+ Enumerates layers and packages from the on-disk cache structure. All
+ functions are generic — the caller interprets directory names and applies
+ any prefix-based filtering. *)
(** {2 Layer enumeration} *)
-val list_layers :
- Eio_unix.Stdenv.base ->
- Fpath.t ->
- (string * Fpath.t) list
-(** [list_layers env dir] returns [(name, path)] pairs for all
- subdirectories under [dir]. Returns [[]] if the directory
- doesn't exist or can't be read. *)
+val list_layers : Eio_unix.Stdenv.base -> Fpath.t -> (string * Fpath.t) list
+(** [list_layers env dir] returns [(name, path)] pairs for all subdirectories
+ under [dir]. Returns [[]] if the directory doesn't exist or can't be read.
+*)
val list_package_symlinks :
?exclude:string list ->
@@ -21,6 +18,6 @@ val list_package_symlinks :
string ->
(string * string) list
(** [list_package_symlinks ?exclude env packages_dir pkg_str] returns
- [(symlink_name, target)] pairs for all symlinks in
- [packages_dir/pkg_str/]. [exclude] is an optional list of
- symlink names to skip (e.g. [["blessed-build"; "blessed-docs"]]). *)
+ [(symlink_name, target)] pairs for all symlinks in [packages_dir/pkg_str/].
+ [exclude] is an optional list of symlink names to skip (e.g.
+ [["blessed-build"; "blessed-docs"]]). *)
File "day11/layer/snapshot.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/snapshot.ml b/_build/default/day11/layer/.formatted/snapshot.ml
index 43ebba0..85b3730 100644
--- a/_build/default/day11/layer/snapshot.ml
+++ b/_build/default/day11/layer/.formatted/snapshot.ml
@@ -1,18 +1,11 @@
-type entry = {
- size : int64;
- mtime : float;
- inode : int64;
-}
-
+type entry = { size : int64; mtime : float; inode : int64 }
type t = (string, entry) Hashtbl.t
let is_empty t = Hashtbl.length t = 0
let size t = Hashtbl.length t
let entry_of_stat (st : Eio.File.Stat.t) : entry =
- { size = Optint.Int63.to_int64 st.size;
- mtime = st.mtime;
- inode = st.ino }
+ { size = Optint.Int63.to_int64 st.size; mtime = st.mtime; inode = st.ino }
let eio_path env p = Eio.Path.(env#fs / Fpath.to_string p)
@@ -25,50 +18,53 @@ let walk env root =
match Eio.Path.read_dir dir_ep with
| exception _ -> ()
| entries ->
- List.iter (fun name ->
- let abs = Filename.concat dir name in
- let abs_ep = eio_path env (Fpath.v abs) in
- match Eio.Path.stat ~follow:false abs_ep with
- | exception _ -> ()
- | (st : Eio.File.Stat.t) ->
- match st.kind with
- | `Directory -> scan abs
- | `Regular_file | `Symbolic_link ->
- let rel =
- (* strip [root/] prefix; if the abs path doesn't start
+ List.iter
+ (fun name ->
+ let abs = Filename.concat dir name in
+ let abs_ep = eio_path env (Fpath.v abs) in
+ match Eio.Path.stat ~follow:false abs_ep with
+ | exception _ -> ()
+ | (st : Eio.File.Stat.t) -> (
+ match st.kind with
+ | `Directory -> scan abs
+ | `Regular_file | `Symbolic_link -> (
+ let rel =
+ (* strip [root/] prefix; if the abs path doesn't start
with root_s (unlikely), fall back to using abs *)
- if String.length abs > root_len
- && String.sub abs 0 root_len = root_s
- && abs.[root_len] = '/'
- then String.sub abs (root_len + 1)
- (String.length abs - root_len - 1)
- else abs
- in
- (* Use stat (following symlinks) so the recorded entry
+ if
+ String.length abs > root_len
+ && String.sub abs 0 root_len = root_s
+ && abs.[root_len] = '/'
+ then
+ String.sub abs (root_len + 1)
+ (String.length abs - root_len - 1)
+ else abs
+ in
+ (* Use stat (following symlinks) so the recorded entry
reflects what the file resolves to. An in-place
replacement of a file changes inode, even if mtime
is carried over. *)
- (match Eio.Path.stat ~follow:true abs_ep with
- | st -> Hashtbl.replace tbl rel (entry_of_stat st)
- | exception _ ->
- (* Broken symlink: record the lstat entry. *)
- Hashtbl.replace tbl rel (entry_of_stat st))
- | _ -> ()
- ) entries
+ match Eio.Path.stat ~follow:true abs_ep with
+ | st -> Hashtbl.replace tbl rel (entry_of_stat st)
+ | exception _ ->
+ (* Broken symlink: record the lstat entry. *)
+ Hashtbl.replace tbl rel (entry_of_stat st))
+ | _ -> ()))
+ entries
in
- if Eio.Path.is_directory (eio_path env root) then
- scan root_s;
+ if Eio.Path.is_directory (eio_path env root) then scan root_s;
tbl
let take env root = walk env root
let diff env ~before root =
let after = walk env root in
- Hashtbl.fold (fun rel (e : entry) acc ->
- match Hashtbl.find_opt before rel with
- | None -> rel :: acc
- | Some (e0 : entry) ->
- if e.size = e0.size && e.mtime = e0.mtime && e.inode = e0.inode
- then acc
- else rel :: acc
- ) after []
+ Hashtbl.fold
+ (fun rel (e : entry) acc ->
+ match Hashtbl.find_opt before rel with
+ | None -> rel :: acc
+ | Some (e0 : entry) ->
+ if e.size = e0.size && e.mtime = e0.mtime && e.inode = e0.inode then
+ acc
+ else rel :: acc)
+ after []
File "day11/layer/snapshot.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/snapshot.mli b/_build/default/day11/layer/.formatted/snapshot.mli
index 6445e2d..74e677c 100644
--- a/_build/default/day11/layer/snapshot.mli
+++ b/_build/default/day11/layer/.formatted/snapshot.mli
@@ -1,44 +1,36 @@
(** Filesystem snapshots — lightweight before/after comparison.
- Designed for the native build backend: snapshot a prefix before a
- build, run the build, diff the prefix to get the list of files
- produced.
+ Designed for the native build backend: snapshot a prefix before a build, run
+ the build, diff the prefix to get the list of files produced.
The snapshot records [(size, mtime, inode)] per file. This catches:
- new files (absent from [before])
- modified files (different mtime or size)
- - in-place replacements (same mtime, different inode) — e.g. a
- build script that does [mv newfile oldfile] with [cp -p]
+ - in-place replacements (same mtime, different inode) — e.g. a build script
+ that does [mv newfile oldfile] with [cp -p]
- Content hashing is deliberately avoided — it would dominate build
- time. For opam-style builds, where files are typically written
- once and never modified in place, [(size, mtime, inode)] is
- sufficient. *)
-
-type entry = {
- size : int64;
- mtime : float;
- inode : int64;
-}
+ Content hashing is deliberately avoided — it would dominate build time. For
+ opam-style builds, where files are typically written once and never modified
+ in place, [(size, mtime, inode)] is sufficient. *)
+type entry = { size : int64; mtime : float; inode : int64 }
type t
val take : Eio_unix.Stdenv.base -> Fpath.t -> t
-(** [take env root] walks [root] (recursively) and records one {!entry}
- per regular file and symlink, keyed by path relative to [root].
- Directories are not recorded, but are traversed. Missing [root]
- returns an empty snapshot. *)
+(** [take env root] walks [root] (recursively) and records one {!entry} per
+ regular file and symlink, keyed by path relative to [root]. Directories are
+ not recorded, but are traversed. Missing [root] returns an empty snapshot.
+*)
val diff : Eio_unix.Stdenv.base -> before:t -> Fpath.t -> string list
-(** [diff env ~before root] walks [root] again and returns the list of
- relative paths that are either:
+(** [diff env ~before root] walks [root] again and returns the list of relative
+ paths that are either:
- absent from [before] (new files), or
- present in [before] but with a different [(size, mtime, inode)]
- Paths are relative to [root]. Symlinks are compared by their
- target's size/mtime/inode — not by the symlink's own metadata —
- since [Eio.Path.stat ~follow:true] follows symlinks. *)
+ Paths are relative to [root]. Symlinks are compared by their target's
+ size/mtime/inode — not by the symlink's own metadata — since
+ [Eio.Path.stat ~follow:true] follows symlinks. *)
val is_empty : t -> bool
-
val size : t -> int
File "day11/layer/stack.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/stack.ml b/_build/default/day11/layer/.formatted/stack.ml
index b48de92..10b0f9c 100644
--- a/_build/default/day11/layer/stack.ml
+++ b/_build/default/day11/layer/.formatted/stack.ml
@@ -1,4 +1,5 @@
let src_log = Logs.Src.create "day11.layer.stack" ~doc:"Layer stacking"
+
module Log = (val Logs.src_log src_log)
let plan_lowerdir ~available ~merged_overhead ~entry_cost layer_dirs =
@@ -7,7 +8,7 @@ let plan_lowerdir ~available ~merged_overhead ~entry_cost layer_dirs =
in
(* Fast path: every layer fits as its own lowerdir, no merge needed. *)
if total_cost <= available then (layer_dirs, [])
- else begin
+ else
(* Walk the list taking layers for the separate bucket as long
as we stay within (available - merged_overhead). Once we'd
overflow, the rest of the list goes to the merged bucket. *)
@@ -15,71 +16,64 @@ let plan_lowerdir ~available ~merged_overhead ~entry_cost layer_dirs =
let rec aux acc_cost kept = function
| [] -> (List.rev kept, [])
| d :: rest ->
- let c = entry_cost d in
- if acc_cost + c <= target then
- aux (acc_cost + c) (d :: kept) rest
- else
- (List.rev kept, d :: rest)
+ let c = entry_cost d in
+ if acc_cost + c <= target then aux (acc_cost + c) (d :: kept) rest
+ else (List.rev kept, d :: rest)
in
aux 0 [] layer_dirs
- end
let collect_fs_dirs env layer_dirs =
- List.filter_map (fun layer_dir ->
- let fs = Fpath.(layer_dir / "fs") in
- if Eio.Path.is_directory Eio.Path.(env#fs / Fpath.to_string fs) then
- Some (Fpath.to_string fs)
- else begin
- Log.debug (fun m ->
- m "Skipping %a (no fs/ subdir)" Fpath.pp layer_dir);
- None
- end
- ) layer_dirs
+ List.filter_map
+ (fun layer_dir ->
+ let fs = Fpath.(layer_dir / "fs") in
+ if Eio.Path.is_directory Eio.Path.(env#fs / Fpath.to_string fs) then
+ Some (Fpath.to_string fs)
+ else (
+ Log.debug (fun m -> m "Skipping %a (no fs/ subdir)" Fpath.pp layer_dir);
+ None))
+ layer_dirs
let merge_script fs_dirs target =
let target_s = Fpath.to_string target in
- let cmds = List.map (fun fs ->
- Printf.sprintf "cp -n --archive --no-dereference --recursive --link --no-target-directory %s %s"
- (Filename.quote fs) (Filename.quote target_s)
- ) fs_dirs in
- "r=0; " ^
- String.concat " " (List.map (fun c -> c ^ " || r=1;") cmds)
+ let cmds =
+ List.map
+ (fun fs ->
+ Printf.sprintf
+ "cp -n --archive --no-dereference --recursive --link \
+ --no-target-directory %s %s"
+ (Filename.quote fs) (Filename.quote target_s))
+ fs_dirs
+ in
+ "r=0; "
+ ^ String.concat " " (List.map (fun c -> c ^ " || r=1;") cmds)
^ " exit $r"
let merge ~sw env ~layer_dirs ~target =
let fs_dirs = collect_fs_dirs env layer_dirs in
if fs_dirs = [] then Ok ()
- else begin
- Log.info (fun m -> m "Merging %d layer fs dirs into %a (sudo)"
- (List.length fs_dirs) Fpath.pp target);
+ else (
+ Log.info (fun m ->
+ m "Merging %d layer fs dirs into %a (sudo)" (List.length fs_dirs)
+ Fpath.pp target);
let script = merge_script fs_dirs target in
let result =
- Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "bash" % "-c" % script)
+ Day11_sys.Sudo.run ~sw env Bos.Cmd.(v "bash" % "-c" % script)
in
- match result with
- | Ok _ -> Ok ()
- | Error _ as e -> e
- end
+ match result with Ok _ -> Ok () | Error _ as e -> e)
let merge_no_sudo env ~layer_dirs ~target =
let fs_dirs = collect_fs_dirs env layer_dirs in
if fs_dirs = [] then Ok ()
- else begin
- Log.info (fun m -> m "Merging %d layer fs dirs into %a"
- (List.length fs_dirs) Fpath.pp target);
+ else (
+ Log.info (fun m ->
+ m "Merging %d layer fs dirs into %a" (List.length fs_dirs) Fpath.pp
+ target);
let script = merge_script fs_dirs target in
- let result =
- Bos.OS.Cmd.run_status
- Bos.Cmd.(v "bash" % "-c" % script)
- in
+ let result = Bos.OS.Cmd.run_status Bos.Cmd.(v "bash" % "-c" % script) in
match result with
| Ok (`Exited 0) -> Ok ()
| Ok (`Exited n) ->
- Rresult.R.error_msgf "cp --link into %a exited %d"
- Fpath.pp target n
+ Rresult.R.error_msgf "cp --link into %a exited %d" Fpath.pp target n
| Ok (`Signaled n) ->
- Rresult.R.error_msgf "cp --link into %a signaled %d"
- Fpath.pp target n
- | Error _ as e -> e
- end
+ Rresult.R.error_msgf "cp --link into %a signaled %d" Fpath.pp target n
+ | Error _ as e -> e)
File "day11/layer/stack.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/stack.mli b/_build/default/day11/layer/.formatted/stack.mli
index 621418c..38119e7 100644
--- a/_build/default/day11/layer/stack.mli
+++ b/_build/default/day11/layer/.formatted/stack.mli
@@ -1,10 +1,9 @@
(** Layer stacking — merge multiple layer filesystems into one directory.
- Layers are stacked in order: earlier layers are lower (overridden by
- later ones). The merge uses [sudo cp --archive --link] for speed —
- hardlinks avoid copying file data. Sudo is required because layer
- [fs/] directories are typically root-owned (created by container
- builds). *)
+ Layers are stacked in order: earlier layers are lower (overridden by later
+ ones). The merge uses [sudo cp --archive --link] for speed — hardlinks avoid
+ copying file data. Sudo is required because layer [fs/] directories are
+ typically root-owned (created by container builds). *)
val merge :
sw:Eio.Switch.t ->
@@ -12,23 +11,21 @@ val merge :
layer_dirs:Fpath.t list ->
target:Fpath.t ->
(unit, [> Rresult.R.msg ]) result
-(** [merge ~sw env ~layer_dirs ~target] stacks the [fs/] subdirectory of
- each layer in [layer_dirs] into [target], in order. Uses
- [sudo cp -an --link] so files are hardlinked, not copied. Later
- layers override earlier ones ([-n] means no-clobber, so first
- writer wins — pass layers in reverse dep order if needed).
+(** [merge ~sw env ~layer_dirs ~target] stacks the [fs/] subdirectory of each
+ layer in [layer_dirs] into [target], in order. Uses [sudo cp -an --link] so
+ files are hardlinked, not copied. Later layers override earlier ones ([-n]
+ means no-clobber, so first writer wins — pass layers in reverse dep order if
+ needed).
- Returns [Error] if any copy fails (e.g. a layer dir doesn't
- exist). *)
+ Returns [Error] if any copy fails (e.g. a layer dir doesn't exist). *)
val merge_no_sudo :
Eio_unix.Stdenv.base ->
layer_dirs:Fpath.t list ->
target:Fpath.t ->
(unit, [> Rresult.R.msg ]) result
-(** Like {!merge}, but runs [cp] directly without sudo. Intended
- for user-owned layers (e.g. those produced by the native
- backend). *)
+(** Like {!merge}, but runs [cp] directly without sudo. Intended for user-owned
+ layers (e.g. those produced by the native backend). *)
val plan_lowerdir :
available:int ->
@@ -36,25 +33,23 @@ val plan_lowerdir :
entry_cost:(Fpath.t -> int) ->
Fpath.t list ->
Fpath.t list * Fpath.t list
-(** [plan_lowerdir ~available ~merged_overhead ~entry_cost layer_dirs]
- decides which layers to pass as separate overlayfs lowerdirs and
- which to cp-merge into a single shared dir, so that the resulting
- mount options string fits in the caller's byte budget.
+(** [plan_lowerdir ~available ~merged_overhead ~entry_cost layer_dirs] decides
+ which layers to pass as separate overlayfs lowerdirs and which to cp-merge
+ into a single shared dir, so that the resulting mount options string fits in
+ the caller's byte budget.
- Returns [(separate, to_merge)]. The fast path (when all layers
- fit) returns [(layer_dirs, [])] with no merging needed. When
- some must be merged, as many as possible are kept separate
- (taken from the front of the list).
+ Returns [(separate, to_merge)]. The fast path (when all layers fit) returns
+ [(layer_dirs, [])] with no merging needed. When some must be merged, as many
+ as possible are kept separate (taken from the front of the list).
Parameters:
- - [available]: the byte budget for the dep-entry portion of the
- mount options string. The caller is responsible for subtracting
- fixed overhead (keyword, separators, base/fs entry, upperdir,
- workdir) before passing this value.
- - [merged_overhead]: extra bytes added to the cost when at least
- one layer must be merged (typically the length of the
- merged-lower path plus its leading colon separator).
- - [entry_cost]: function returning how many bytes a single
- separate-lowerdir entry contributes (typically
- [String.length (Fpath.to_string (dir / "fs")) + 1] for the
- colon). *)
+ - [available]: the byte budget for the dep-entry portion of the mount
+ options string. The caller is responsible for subtracting fixed overhead
+ (keyword, separators, base/fs entry, upperdir, workdir) before passing
+ this value.
+ - [merged_overhead]: extra bytes added to the cost when at least one layer
+ must be merged (typically the length of the merged-lower path plus its
+ leading colon separator).
+ - [entry_cost]: function returning how many bytes a single separate-lowerdir
+ entry contributes (typically
+ [String.length (Fpath.to_string (dir / "fs")) + 1] for the colon). *)
File "day11/layer/symlinks.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/symlinks.ml b/_build/default/day11/layer/.formatted/symlinks.ml
index a257403..0db456c 100644
--- a/_build/default/day11/layer/symlinks.ml
+++ b/_build/default/day11/layer/.formatted/symlinks.ml
@@ -13,5 +13,5 @@ let ensure env ~packages_dir ~id ~layer_name =
Eio.Path.symlink ~link_to:target ep_link;
Ok ()
with exn ->
- Rresult.R.error_msgf "Symlinks.ensure %s/%s: %s"
- id layer_name (Printexc.to_string exn)
+ Rresult.R.error_msgf "Symlinks.ensure %s/%s: %s" id layer_name
+ (Printexc.to_string exn)
File "day11/layer/symlinks.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/symlinks.mli b/_build/default/day11/layer/.formatted/symlinks.mli
index e8771f1..092008e 100644
--- a/_build/default/day11/layer/symlinks.mli
+++ b/_build/default/day11/layer/.formatted/symlinks.mli
@@ -1,15 +1,13 @@
(** Per-id tracking symlinks under [packages_dir/<id>/].
- A small registry that lets you enumerate every layer ever
- associated with a given identifier (typically a package
- [name.version] string, but the function is generic — any string
- that's a valid path component will do).
+ A small registry that lets you enumerate every layer ever associated with a
+ given identifier (typically a package [name.version] string, but the
+ function is generic — any string that's a valid path component will do).
- For each layer, a symlink is created at
- [packages_dir/<id>/<layer_name>] pointing back to the layer
- directory. The directory name [packages] is historical from when
- every layer was an opam package build; this module just owns the
- symlink mechanics and does not interpret the namespace. *)
+ For each layer, a symlink is created at [packages_dir/<id>/<layer_name>]
+ pointing back to the layer directory. The directory name [packages] is
+ historical from when every layer was an opam package build; this module just
+ owns the symlink mechanics and does not interpret the namespace. *)
val ensure :
Eio_unix.Stdenv.base ->
@@ -18,7 +16,7 @@ val ensure :
layer_name:string ->
(unit, [> Rresult.R.msg ]) result
(** [ensure env ~packages_dir ~id ~layer_name] creates a symlink at
- [packages_dir/id/layer_name] pointing to [../../layer_name].
- Creates the [packages_dir/id] directory if needed. Idempotent —
- if a symlink already exists at the same path it is replaced so
- the registry always reflects the most recent build. *)
+ [packages_dir/id/layer_name] pointing to [../../layer_name]. Creates the
+ [packages_dir/id] directory if needed. Idempotent — if a symlink already
+ exists at the same path it is replaced so the registry always reflects the
+ most recent build. *)
File "day11/solver_pool/solver_pool.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver_pool/solver_pool.ml b/_build/default/day11/solver_pool/.formatted/solver_pool.ml
index 235fa1b..1af94bf 100644
--- a/_build/default/day11/solver_pool/solver_pool.ml
+++ b/_build/default/day11/solver_pool/.formatted/solver_pool.ml
@@ -1,4 +1,6 @@
-let src = Logs.Src.create "day11.solver_pool" ~doc:"Parallel out-of-process solver"
+let src =
+ Logs.Src.create "day11.solver_pool" ~doc:"Parallel out-of-process solver"
+
module Log = (val Logs.src_log src)
(* Bumped by every [solve_many] call so concurrent invocations get
@@ -7,13 +9,15 @@ let solve_many_call_seq = Atomic.make 0
let find_worker_bin () =
let exe_dir = Filename.dirname Sys.argv.(0) in
- let candidates = [
- Filename.concat exe_dir "solver_worker.exe";
- Filename.concat exe_dir "../solver/solver_worker.exe";
- Filename.concat exe_dir "../../day11/solver/solver_worker.exe";
- "_build/default/day11/solver/solver_worker.exe";
- "day11-solver-worker";
- ] in
+ let candidates =
+ [
+ Filename.concat exe_dir "solver_worker.exe";
+ Filename.concat exe_dir "../solver/solver_worker.exe";
+ Filename.concat exe_dir "../../day11/solver/solver_worker.exe";
+ "_build/default/day11/solver/solver_worker.exe";
+ "day11-solver-worker";
+ ]
+ in
let from_path =
(* Check $PATH for day11-solver-worker. This only runs once per
solve_many call, before Eio fibers are spawned, so using plain
@@ -23,37 +27,38 @@ let find_worker_bin () =
ignore (Unix.close_process_in ic);
path
in
- let all_candidates = candidates @
- (match from_path with Some p -> [p] | None -> []) in
+ let all_candidates =
+ candidates @ match from_path with Some p -> [ p ] | None -> []
+ in
match List.find_opt Sys.file_exists all_candidates with
| Some p -> p
| None ->
- let tried = String.concat ", " candidates in
- failwith (Printf.sprintf "solver_worker binary not found (tried: %s, argv0=%s)"
- tried Sys.argv.(0))
+ let tried = String.concat ", " candidates in
+ failwith
+ (Printf.sprintf "solver_worker binary not found (tried: %s, argv0=%s)"
+ tried Sys.argv.(0))
let examined_of_json json =
let open Yojson.Safe.Util in
- json |> to_list |> List.map to_string
+ json
+ |> to_list
+ |> List.map to_string
|> List.map OpamPackage.Name.of_string
|> OpamPackage.Name.Set.of_list
let parse_result_line line =
let json = Yojson.Safe.from_string line in
let open Yojson.Safe.Util in
- let pkg = json |> member "package" |> to_string
- |> OpamPackage.of_string in
+ let pkg = json |> member "package" |> to_string |> OpamPackage.of_string in
match json |> member "failed" |> to_bool_option with
| Some true ->
- let error = json |> member "error" |> to_string in
- let examined = json |> member "examined" |> examined_of_json in
- (pkg, Error (error, examined))
- | _ ->
- match Day11_solution.Solve_result.of_json
- (json |> member "result") with
- | Ok result -> (pkg, Ok result)
- | Error (`Msg e) ->
- (pkg, Error (e, OpamPackage.Name.Set.empty))
+ let error = json |> member "error" |> to_string in
+ let examined = json |> member "examined" |> examined_of_json in
+ (pkg, Error (error, examined))
+ | _ -> (
+ match Day11_solution.Solve_result.of_json (json |> member "result") with
+ | Ok result -> (pkg, Ok result)
+ | Error (`Msg e) -> (pkg, Error (e, OpamPackage.Name.Set.empty)))
let parse_output_file path =
(* One-shot read of the JSONL output file after the worker exits.
@@ -63,94 +68,112 @@ let parse_output_file path =
let results = ref [] in
String.split_on_char '\n' contents
|> List.iter (fun line ->
- if line <> "" then
- match parse_result_line line with
- | r -> results := r :: !results
- | exception _ -> ());
+ if line <> "" then
+ match parse_result_line line with
+ | r -> results := r :: !results
+ | exception _ -> ());
List.rev !results
let solve_many ~sw env ?(pin_dirs = []) ?(constraints = [])
- ?(extra_targets = []) ?(doc = true) ?(pin_target = true)
- ?ocaml_version ?on_progress ~np ~repos targets =
+ ?(extra_targets = []) ?(doc = true) ?(pin_target = true) ?ocaml_version
+ ?on_progress ~np ~repos targets =
if targets = [] then []
else
- let np = max 1 (min np (List.length targets)) in
- let worker_bin = find_worker_bin () in
- Log.debug (fun m -> m "Solving %d targets with %d workers"
- (List.length targets) np);
- (* Partition targets across [np] workers. *)
- let batches = Array.make np [] in
- List.iteri (fun i target ->
- let slot = i mod np in
- batches.(slot) <- target :: batches.(slot)
- ) targets;
- let tmp_dir = Filename.get_temp_dir_name () in
- let pid = Unix.getpid () in
- (* Per-call unique tag so concurrent [solve_many] invocations don't
+ let np = max 1 (min np (List.length targets)) in
+ let worker_bin = find_worker_bin () in
+ Log.debug (fun m ->
+ m "Solving %d targets with %d workers" (List.length targets) np);
+ (* Partition targets across [np] workers. *)
+ let batches = Array.make np [] in
+ List.iteri
+ (fun i target ->
+ let slot = i mod np in
+ batches.(slot) <- target :: batches.(slot))
+ targets;
+ let tmp_dir = Filename.get_temp_dir_name () in
+ let pid = Unix.getpid () in
+ (* Per-call unique tag so concurrent [solve_many] invocations don't
write to the same output file. The previous [{pid}_{slot}] scheme
collided when multiple fibers each invoked [solve_many ~np:1]
(same pid, same slot=0). *)
- let call_tag = Printf.sprintf "%x_%d"
- (Random.bits ()) (Atomic.fetch_and_add solve_many_call_seq 1) in
- let total = List.length targets in
- let done_count = Atomic.make 0 in
- let fs = Eio.Stdenv.fs env in
- (* Run each batch in a fiber. Use Fiber.List.map with max_fibers:np
+ let call_tag =
+ Printf.sprintf "%x_%d" (Random.bits ())
+ (Atomic.fetch_and_add solve_many_call_seq 1)
+ in
+ let total = List.length targets in
+ let done_count = Atomic.make 0 in
+ let fs = Eio.Stdenv.fs env in
+ (* Run each batch in a fiber. Use Fiber.List.map with max_fibers:np
so all workers run concurrently (bounded by np). [sw] lets
cancellation propagate to spawned workers via Sys.Run. *)
- let batch_idxs = List.init np (fun i -> i) in
- let batch_results =
- Eio.Fiber.List.map ~max_fibers:np (fun slot ->
- let batch = List.rev batches.(slot) in
- if batch = [] then []
- else begin
- let output_file = Filename.concat tmp_dir
- (Printf.sprintf "day11_solve_%d_%s_%d.jsonl"
- pid call_tag slot) in
- let repo_args = List.concat_map (fun (repo, sha) ->
- [ "--repo"; repo ^ ":" ^ sha ]
- ) repos in
- let ocaml_args = match ocaml_version with
- | Some pkg -> [ "--ocaml-version"; OpamPackage.to_string pkg ]
- | None -> [] in
- let pin_args = List.concat_map (fun dir ->
- [ "--pin-dir"; dir ]
- ) pin_dirs in
- let constraint_args = List.concat_map (fun pkg ->
- [ "--constraint"; OpamPackage.to_string pkg ]
- ) constraints in
- let extra_target_args = List.concat_map (fun pkg ->
- [ "--extra-target"; OpamPackage.to_string pkg ]
- ) extra_targets in
- let doc_args = if doc then [] else [ "--no-doc" ] in
- let pin_target_args =
- if pin_target then [] else [ "--no-pin-target" ] in
- let cmd = Bos.Cmd.(v worker_bin
- %% of_list repo_args
- % "--output" % output_file
- %% of_list ocaml_args
- %% of_list pin_args
- %% of_list constraint_args
- %% of_list extra_target_args
- %% of_list doc_args
- %% of_list pin_target_args
- %% of_list (List.map OpamPackage.to_string batch)) in
- let out_fpath = Fpath.v output_file in
- let _run : Day11_sys.Run.t =
- Day11_sys.Run.run ~sw env cmd (Some out_fpath) in
- let results =
- try parse_output_file Eio.Path.(fs / output_file)
- with _ -> [] in
- (* Remove the temp file. Ignore errors — the worst case is a
+ let batch_idxs = List.init np (fun i -> i) in
+ let batch_results =
+ Eio.Fiber.List.map ~max_fibers:np
+ (fun slot ->
+ let batch = List.rev batches.(slot) in
+ if batch = [] then []
+ else
+ let output_file =
+ Filename.concat tmp_dir
+ (Printf.sprintf "day11_solve_%d_%s_%d.jsonl" pid call_tag slot)
+ in
+ let repo_args =
+ List.concat_map
+ (fun (repo, sha) -> [ "--repo"; repo ^ ":" ^ sha ])
+ repos
+ in
+ let ocaml_args =
+ match ocaml_version with
+ | Some pkg -> [ "--ocaml-version"; OpamPackage.to_string pkg ]
+ | None -> []
+ in
+ let pin_args =
+ List.concat_map (fun dir -> [ "--pin-dir"; dir ]) pin_dirs
+ in
+ let constraint_args =
+ List.concat_map
+ (fun pkg -> [ "--constraint"; OpamPackage.to_string pkg ])
+ constraints
+ in
+ let extra_target_args =
+ List.concat_map
+ (fun pkg -> [ "--extra-target"; OpamPackage.to_string pkg ])
+ extra_targets
+ in
+ let doc_args = if doc then [] else [ "--no-doc" ] in
+ let pin_target_args =
+ if pin_target then [] else [ "--no-pin-target" ]
+ in
+ let cmd =
+ Bos.Cmd.(
+ v worker_bin
+ %% of_list repo_args
+ % "--output"
+ % output_file
+ %% of_list ocaml_args
+ %% of_list pin_args
+ %% of_list constraint_args
+ %% of_list extra_target_args
+ %% of_list doc_args
+ %% of_list pin_target_args
+ %% of_list (List.map OpamPackage.to_string batch))
+ in
+ let out_fpath = Fpath.v output_file in
+ let _run : Day11_sys.Run.t =
+ Day11_sys.Run.run ~sw env cmd (Some out_fpath)
+ in
+ let results =
+ try parse_output_file Eio.Path.(fs / output_file) with _ -> []
+ in
+ (* Remove the temp file. Ignore errors — the worst case is a
dangling file in TMPDIR, cleaned up by the OS. *)
- (try Eio.Path.unlink Eio.Path.(fs / output_file) with _ -> ());
- let delta = List.length results in
- let new_done = Atomic.fetch_and_add done_count delta + delta in
- (match on_progress with
- | Some f -> f ~done_count:new_done ~total
- | None -> ());
- results
- end
- ) batch_idxs
- in
- List.concat batch_results
+ (try Eio.Path.unlink Eio.Path.(fs / output_file) with _ -> ());
+ let delta = List.length results in
+ let new_done = Atomic.fetch_and_add done_count delta + delta in
+ (match on_progress with
+ | Some f -> f ~done_count:new_done ~total
+ | None -> ());
+ results)
+ batch_idxs
+ in
+ List.concat batch_results
File "day11/solver_pool/solver_pool.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/solver_pool/solver_pool.mli b/_build/default/day11/solver_pool/.formatted/solver_pool.mli
index 43eddda..b8bcd42 100644
--- a/_build/default/day11/solver_pool/solver_pool.mli
+++ b/_build/default/day11/solver_pool/.formatted/solver_pool.mli
@@ -1,13 +1,13 @@
(** Parallel solving via solver_worker subprocesses.
- Spawns solver_worker processes to solve packages in parallel.
- No in-process solver dependency — all solving happens out-of-process.
+ Spawns solver_worker processes to solve packages in parallel. No in-process
+ solver dependency — all solving happens out-of-process.
- Subprocess execution goes through {!Day11_sys.Run}, so the fork
- helper is reused. Each worker's stdout is redirected to a
- per-worker JSONL file; results are parsed after the worker exits.
- The worker fibers are bounded by [np], supervised by the supplied
- switch — cancelling [sw] aborts all in-flight workers. *)
+ Subprocess execution goes through {!Day11_sys.Run}, so the fork helper is
+ reused. Each worker's stdout is redirected to a per-worker JSONL file;
+ results are parsed after the worker exits. The worker fibers are bounded by
+ [np], supervised by the supplied switch — cancelling [sw] aborts all
+ in-flight workers. *)
val solve_many :
sw:Eio.Switch.t ->
@@ -23,22 +23,20 @@ val solve_many :
repos:(string * string) list ->
OpamPackage.t list ->
(OpamPackage.t
- * (Day11_solution.Solve_result.t,
- string * OpamPackage.Name.Set.t) result) list
-(** [solve_many ~sw env ?pin_dirs ?constraints ?doc ?ocaml_version ?on_progress ~np ~repos targets]
- solves all [targets] in parallel by spawning up to [np] solver_worker
- fibers that each invoke [day11-solver-worker].
+ * (Day11_solution.Solve_result.t, string * OpamPackage.Name.Set.t) result)
+ list
+(** [solve_many ~sw env ?pin_dirs ?constraints ?doc ?ocaml_version ?on_progress
+ ~np ~repos targets] solves all [targets] in parallel by spawning up to [np]
+ solver_worker fibers that each invoke [day11-solver-worker].
- [on_progress] is called after each worker finishes with the total
- count of solved targets (across all workers).
- [repos] is a list of [(repo_path, commit_sha)] pairs.
- [pin_dirs] are directories of [.opam] files pinned at version [dev].
- [constraints] pins packages at exact versions.
+ [on_progress] is called after each worker finishes with the total count of
+ solved targets (across all workers). [repos] is a list of
+ [(repo_path, commit_sha)] pairs. [pin_dirs] are directories of [.opam] files
+ pinned at version [dev]. [constraints] pins packages at exact versions.
[doc] controls whether doc dependencies are included (default [true]).
- [pin_target] controls whether each target's exact version is forced
- via an [=] constraint (default [true], for back-compat). Pass
- [false] in latest-version profile mode so the solver can choose
- a different version (e.g. an oxcaml [+ox] variant) when the
- nominal latest doesn't fit the rest of the universe — see
- {!Day11_solver.Solve.solve}.
- Workers run under [sw]; cancelling [sw] terminates them. *)
+ [pin_target] controls whether each target's exact version is forced via an
+ [=] constraint (default [true], for back-compat). Pass [false] in
+ latest-version profile mode so the solver can choose a different version
+ (e.g. an oxcaml [+ox] variant) when the nominal latest doesn't fit the rest
+ of the universe — see {!Day11_solver.Solve.solve}. Workers run under [sw];
+ cancelling [sw] terminates them. *)
File "day11/runner/cpu_slots.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/runner/cpu_slots.ml b/_build/default/day11/runner/.formatted/cpu_slots.ml
index aec96a3..36c8262 100644
--- a/_build/default/day11/runner/cpu_slots.ml
+++ b/_build/default/day11/runner/.formatted/cpu_slots.ml
@@ -1,12 +1,9 @@
-let src = Logs.Src.create "day11.runner.cpu_slots"
- ~doc:"NUMA-aware cpu slot pool"
+let src =
+ Logs.Src.create "day11.runner.cpu_slots" ~doc:"NUMA-aware cpu slot pool"
+
module Log = (val Logs.src_log src)
-type slot = {
- cpuset : string;
- numa_mems : string option;
- node : int;
-}
+type slot = { cpuset : string; numa_mems : string option; node : int }
type t = {
slots : slot Eio.Stream.t;
@@ -21,15 +18,15 @@ let expand_cpulist s =
match String.split_on_char '-' r with
| [ a ] -> [ int_of_string (String.trim a) ]
| [ a; b ] ->
- let a = int_of_string (String.trim a) in
- let b = int_of_string (String.trim b) in
- List.init (b - a + 1) (fun i -> a + i)
+ let a = int_of_string (String.trim a) in
+ let b = int_of_string (String.trim b) in
+ List.init (b - a + 1) (fun i -> a + i)
| _ -> []
in
String.split_on_char ',' s
|> List.concat_map (fun r ->
- let r = String.trim r in
- if r = "" then [] else parse_range r)
+ let r = String.trim r in
+ if r = "" then [] else parse_range r)
|> List.sort_uniq compare
(* Render an int list back into compact Linux cpuset notation,
@@ -44,11 +41,10 @@ let format_cpuset cpus =
match sorted with
| [] -> ""
| x :: xs ->
- go [] x x xs
- |> List.map (fun (a, b) ->
- if a = b then string_of_int a
- else Printf.sprintf "%d-%d" a b)
- |> String.concat ","
+ go [] x x xs
+ |> List.map (fun (a, b) ->
+ if a = b then string_of_int a else Printf.sprintf "%d-%d" a b)
+ |> String.concat ","
let read_file path =
try Some (In_channel.with_open_text path In_channel.input_all)
@@ -62,27 +58,30 @@ let detect_numa () =
let base = "/sys/devices/system/node" in
if not (Sys.file_exists base && Sys.is_directory base) then None
else
- let entries =
- try Sys.readdir base |> Array.to_list
- with _ -> [] in
+ let entries = try Sys.readdir base |> Array.to_list with _ -> [] in
let nodes =
- List.filter_map (fun name ->
- if String.length name > 4 && String.sub name 0 4 = "node" then
- try
- Some (int_of_string
- (String.sub name 4 (String.length name - 4)))
- with _ -> None
- else None) entries
- |> List.sort compare in
+ List.filter_map
+ (fun name ->
+ if String.length name > 4 && String.sub name 0 4 = "node" then
+ try
+ Some (int_of_string (String.sub name 4 (String.length name - 4)))
+ with _ -> None
+ else None)
+ entries
+ |> List.sort compare
+ in
if nodes = [] then None
else
- let pairs = List.filter_map (fun n ->
- let path = Printf.sprintf "%s/node%d/cpulist" base n in
- match read_file path with
- | Some s ->
- let cpus = expand_cpulist (String.trim s) in
- if cpus = [] then None else Some (n, cpus)
- | None -> None) nodes
+ let pairs =
+ List.filter_map
+ (fun n ->
+ let path = Printf.sprintf "%s/node%d/cpulist" base n in
+ match read_file path with
+ | Some s ->
+ let cpus = expand_cpulist (String.trim s) in
+ if cpus = [] then None else Some (n, cpus)
+ | None -> None)
+ nodes
in
if pairs = [] then None else Some pairs
@@ -92,27 +91,21 @@ let detect_numa () =
let detect_flat () =
match read_file "/sys/devices/system/cpu/online" with
| Some s ->
- let cpus = expand_cpulist (String.trim s) in
- if cpus = [] then
- List.init (max 1 (Domain.recommended_domain_count ()))
- (fun i -> i)
- else cpus
+ let cpus = expand_cpulist (String.trim s) in
+ if cpus = [] then
+ List.init (max 1 (Domain.recommended_domain_count ())) (fun i -> i)
+ else cpus
| None ->
- let n =
- try Domain.recommended_domain_count ()
- with _ -> 1 in
- List.init (max 1 n) (fun i -> i)
+ let n = try Domain.recommended_domain_count () with _ -> 1 in
+ List.init (max 1 n) (fun i -> i)
(* Split [cpus] into disjoint chunks of size [n]. Any tail shorter
than [n] is dropped — we'd rather leave a few host CPUs idle than
have one oversize/undersize slot. *)
let chunk_into n cpus =
let rec go acc cur count = function
- | [] ->
- if count = n then List.rev (List.rev cur :: acc)
- else List.rev acc
- | x :: xs when count = n ->
- go (List.rev cur :: acc) [ x ] 1 xs
+ | [] -> if count = n then List.rev (List.rev cur :: acc) else List.rev acc
+ | x :: xs when count = n -> go (List.rev cur :: acc) [ x ] 1 xs
| x :: xs -> go acc (x :: cur) (count + 1) xs
in
go [] [] 0 cpus
@@ -124,21 +117,35 @@ let chunk_into n cpus =
[detect_numa]'s listing. *)
let interleave_by_node base =
let buckets : (int, slot list ref) Hashtbl.t = Hashtbl.create 4 in
- List.iter (fun s ->
- let r = try Hashtbl.find buckets s.node
- with Not_found ->
- let r = ref [] in Hashtbl.add buckets s.node r; r in
- r := s :: !r) base;
- let queues = Hashtbl.fold (fun k v acc -> (k, v) :: acc) buckets []
+ List.iter
+ (fun s ->
+ let r =
+ try Hashtbl.find buckets s.node
+ with Not_found ->
+ let r = ref [] in
+ Hashtbl.add buckets s.node r;
+ r
+ in
+ r := s :: !r)
+ base;
+ let queues =
+ Hashtbl.fold (fun k v acc -> (k, v) :: acc) buckets []
|> List.sort (fun (a, _) (b, _) -> compare a b)
- |> List.map (fun (_, r) -> ref (List.rev !r)) in
+ |> List.map (fun (_, r) -> ref (List.rev !r))
+ in
let rec drain acc =
let any_left = ref false in
- let acc = List.fold_left (fun acc q ->
- match !q with
- | [] -> acc
- | s :: rest -> any_left := true; q := rest; s :: acc
- ) acc queues in
+ let acc =
+ List.fold_left
+ (fun acc q ->
+ match !q with
+ | [] -> acc
+ | s :: rest ->
+ any_left := true;
+ q := rest;
+ s :: acc)
+ acc queues
+ in
if !any_left then drain acc else acc
in
List.rev (drain [])
@@ -151,7 +158,8 @@ let apply_overcommit ~overcommit base =
let overcommit = Float.max 1.0 overcommit in
let n_base = List.length base in
let n_total =
- Float.to_int (Float.round (Float.of_int n_base *. overcommit)) in
+ Float.to_int (Float.round (Float.of_int n_base *. overcommit))
+ in
let n_total = max n_base n_total in
let arr = Array.of_list base in
List.init n_total (fun i -> arr.(i mod n_base))
@@ -162,54 +170,62 @@ let auto ?(overcommit = 1.0) ~cores_per_build () =
let base_slots, layout_desc =
match detect_numa () with
| Some pairs when List.length pairs >= 2 ->
- (* NUMA-aware path: pin each slot to one node's CPUs + mems. *)
- let slots = List.concat_map (fun (node, cpus) ->
- chunk_into cores_per_build cpus
- |> List.map (fun chunk ->
- { cpuset = format_cpuset chunk;
- numa_mems = Some (string_of_int node);
- node })
- ) pairs in
- let desc = pairs
- |> List.map (fun (n, cpus) ->
- Printf.sprintf "node%d:%d" n (List.length cpus))
- |> String.concat " " in
- slots, "numa(" ^ desc ^ ")"
+ (* NUMA-aware path: pin each slot to one node's CPUs + mems. *)
+ let slots =
+ List.concat_map
+ (fun (node, cpus) ->
+ chunk_into cores_per_build cpus
+ |> List.map (fun chunk ->
+ {
+ cpuset = format_cpuset chunk;
+ numa_mems = Some (string_of_int node);
+ node;
+ }))
+ pairs
+ in
+ let desc =
+ pairs
+ |> List.map (fun (n, cpus) ->
+ Printf.sprintf "node%d:%d" n (List.length cpus))
+ |> String.concat " "
+ in
+ (slots, "numa(" ^ desc ^ ")")
| _ ->
- (* Flat path: no NUMA pinning, all slots on one big pool. *)
- let cpus = detect_flat () in
- let slots = chunk_into cores_per_build cpus
- |> List.map (fun chunk ->
- { cpuset = format_cpuset chunk;
- numa_mems = None;
- node = 0 }) in
- slots, Printf.sprintf "flat(%d cpus)" (List.length cpus)
+ (* Flat path: no NUMA pinning, all slots on one big pool. *)
+ let cpus = detect_flat () in
+ let slots =
+ chunk_into cores_per_build cpus
+ |> List.map (fun chunk ->
+ { cpuset = format_cpuset chunk; numa_mems = None; node = 0 })
+ in
+ (slots, Printf.sprintf "flat(%d cpus)" (List.length cpus))
in
if base_slots = [] then
- invalid_arg (Printf.sprintf
- "Cpu_slots.auto: no slots produced (cores_per_build=%d, layout=%s) — \
- host has fewer CPUs than one slot needs"
- cores_per_build layout_desc);
+ invalid_arg
+ (Printf.sprintf
+ "Cpu_slots.auto: no slots produced (cores_per_build=%d, layout=%s) — \
+ host has fewer CPUs than one slot needs"
+ cores_per_build layout_desc);
let base_slots = interleave_by_node base_slots in
let slots = apply_overcommit ~overcommit base_slots in
let n_base = List.length base_slots in
let n = List.length slots in
let stream = Eio.Stream.create n in
List.iter (fun s -> Eio.Stream.add stream s) slots;
- Log.info (fun m -> m "CPU slot pool: %d slots × %d cpus (%s, overcommit=%.2fx of %d base)"
- n cores_per_build layout_desc overcommit n_base);
+ Log.info (fun m ->
+ m "CPU slot pool: %d slots × %d cpus (%s, overcommit=%.2fx of %d base)" n
+ cores_per_build layout_desc overcommit n_base);
{ slots = stream; n_slots = n; cores_per_build; layout = layout_desc }
let n_slots t = t.n_slots
let cores_per_build t = t.cores_per_build
+
let describe t =
- Printf.sprintf "%d slots × %d cpus (%s)"
- t.n_slots t.cores_per_build t.layout
+ Printf.sprintf "%d slots × %d cpus (%s)" t.n_slots t.cores_per_build t.layout
let acquire t = Eio.Stream.take t.slots
let release t slot = Eio.Stream.add t.slots slot
let with_slot t f =
let slot = acquire t in
- Fun.protect ~finally:(fun () -> release t slot)
- (fun () -> f slot)
+ Fun.protect ~finally:(fun () -> release t slot) (fun () -> f slot)
File "day11/runner/cpu_slots.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/runner/cpu_slots.mli b/_build/default/day11/runner/.formatted/cpu_slots.mli
index 154b8b4..c8504d0 100644
--- a/_build/default/day11/runner/cpu_slots.mli
+++ b/_build/default/day11/runner/.formatted/cpu_slots.mli
@@ -1,68 +1,67 @@
(** NUMA-aware CPU slot pool for bounding container concurrency.
- A fixed set of slots is created at startup, each pinned to a
- specific subset of host CPUs and (when the host has multiple
- NUMA nodes) to one NUMA memory node. Build dispatch code calls
- {!acquire} before launching a container and {!release} after;
- acquire blocks the current fiber when every slot is in use.
+ A fixed set of slots is created at startup, each pinned to a specific subset
+ of host CPUs and (when the host has multiple NUMA nodes) to one NUMA memory
+ node. Build dispatch code calls {!acquire} before launching a container and
+ {!release} after; acquire blocks the current fiber when every slot is in
+ use.
Each slot's [(cpuset, numa_mems)] pair threads straight into
- {!Day11_container.Oci_spec.make}'s [?cpuset] / [?numa_mems]
- parameters, which produces [linux.resources.cpu.{cpus,mems}] in
- the OCI config. runc then enforces the pin via cgroup v2
- [cpuset] controllers, so [nproc] inside the container reports
- the slot size and nested [make -j$(nproc)] self-limits.
+ {!Day11_container.Oci_spec.make}'s [?cpuset] / [?numa_mems] parameters,
+ which produces [linux.resources.cpu.{cpus,mems}] in the OCI config. runc
+ then enforces the pin via cgroup v2 [cpuset] controllers, so [nproc] inside
+ the container reports the slot size and nested [make -j$(nproc)]
+ self-limits.
{1 Detection}
- {!auto} reads [/sys/devices/system/node/node*/cpulist]. If the
- host has no NUMA layout (single-socket or [cpulist] unreadable),
- slots are laid out from [/proc/cpuinfo] with [numa_mems = None].
+ {!auto} reads [/sys/devices/system/node/node*/cpulist]. If the host has no
+ NUMA layout (single-socket or [cpulist] unreadable), slots are laid out from
+ [/proc/cpuinfo] with [numa_mems = None].
{1 Layout}
For [cores_per_build = N]:
- {ul
- {- Each NUMA node's CPU list is split into disjoint chunks of
- [N] CPUs. Any tail CPUs (fewer than [N]) are dropped.}
- {- Slots are emitted per-node, in [node -> chunk] order.}} *)
+ - Each NUMA node's CPU list is split into disjoint chunks of [N] CPUs. Any
+ tail CPUs (fewer than [N]) are dropped.
+ - Slots are emitted per-node, in [node -> chunk] order. *)
type t
type slot = {
cpuset : string;
- (** Cpuset spec, e.g. ["0-3"] or ["0-1,20-21"]. Passed directly
- to {!Day11_container.Oci_spec.make}'s [?cpuset]. *)
+ (** Cpuset spec, e.g. ["0-3"] or ["0-1,20-21"]. Passed directly to
+ {!Day11_container.Oci_spec.make}'s [?cpuset]. *)
numa_mems : string option;
- (** NUMA node(s) this slot's memory is pinned to, if any. *)
+ (** NUMA node(s) this slot's memory is pinned to, if any. *)
node : int;
- (** The originating NUMA node index. Useful for per-node
- scheduling decisions or logging. *)
+ (** The originating NUMA node index. Useful for per-node scheduling
+ decisions or logging. *)
}
val auto : ?overcommit:float -> cores_per_build:int -> unit -> t
(** Auto-detect the host NUMA layout and build a slot pool.
- @param cores_per_build Size of each cpuset in cpus. Slots pack
- into each NUMA node's cpu list in disjoint chunks of this
- size; tail cpus shorter than one chunk are dropped.
+ @param cores_per_build
+ Size of each cpuset in cpus. Slots pack into each NUMA node's cpu list in
+ disjoint chunks of this size; tail cpus shorter than one chunk are
+ dropped.
- @param overcommit Multiplier on the base slot count. [1.0]
- (default) gives the strict CPU-bounded pool: a build never
- shares cpus with another build. Values [> 1.0] replicate
- cpusets in the pool so multiple builds can land on the same
- cpuset and the kernel time-slices the cpus between them —
- useful when builds are I/O-bound (network fetches, disk I/O
- during opam-install) and CPU cores sit idle waiting. Rounded
- to the nearest integer slot count (minimum 1 slot). Values
- [< 1.0] are clamped to [1.0].
+ @param overcommit
+ Multiplier on the base slot count. [1.0] (default) gives the strict
+ CPU-bounded pool: a build never shares cpus with another build. Values
+ [> 1.0] replicate cpusets in the pool so multiple builds can land on the
+ same cpuset and the kernel time-slices the cpus between them — useful when
+ builds are I/O-bound (network fetches, disk I/O during opam-install) and
+ CPU cores sit idle waiting. Rounded to the nearest integer slot count
+ (minimum 1 slot). Values [< 1.0] are clamped to [1.0].
- Fails by [invalid_arg] if [cores_per_build < 1] or the host has
- fewer cpus than one chunk. *)
+ Fails by [invalid_arg] if [cores_per_build < 1] or the host has fewer cpus
+ than one chunk. *)
val n_slots : t -> int
-(** Number of slots available — typically used to size the caller's
- own concurrency pool so it never queues more builds than slots. *)
+(** Number of slots available — typically used to size the caller's own
+ concurrency pool so it never queues more builds than slots. *)
val cores_per_build : t -> int
(** Returns the [cores_per_build] value passed to {!auto}. *)
@@ -74,8 +73,8 @@ val release : t -> slot -> unit
(** Return a slot to the pool, unblocking one waiting caller. *)
val with_slot : t -> (slot -> 'a) -> 'a
-(** [with_slot t f] runs [f] while holding a slot, releasing even if
- [f] raises. *)
+(** [with_slot t f] runs [f] while holding a slot, releasing even if [f] raises.
+*)
val describe : t -> string
(** One-line summary of the pool layout for startup logging. *)
File "day11/runner/run_in_layers.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/runner/run_in_layers.ml b/_build/default/day11/runner/.formatted/run_in_layers.ml
index 88bb974..110a31d 100644
--- a/_build/default/day11/runner/run_in_layers.ml
+++ b/_build/default/day11/runner/.formatted/run_in_layers.ml
@@ -1,11 +1,11 @@
-let src = Logs.Src.create "day11.runner.run_in_layers"
- ~doc:"Run a command in a layered container"
+let src =
+ Logs.Src.create "day11.runner.run_in_layers"
+ ~doc:"Run a command in a layered container"
+
module Log = (val Logs.src_log src)
let ( let* ) r f = match r with Ok v -> f v | Error _ as e -> e
-
-let mkdir path =
- Bos.OS.Dir.create ~path:true path |> ignore
+let mkdir path = Bos.OS.Dir.create ~path:true path |> ignore
(** Like [timed] but also stores elapsed time in a ref. *)
let timed_to name dst f =
@@ -13,12 +13,11 @@ let timed_to name dst f =
let r = f () in
let elapsed = Unix.gettimeofday () -. t0 in
dst := elapsed;
- if elapsed > 0.1 then
- Log.info (fun m -> m "%s: %.3fs" name elapsed);
+ if elapsed > 0.1 then Log.info (fun m -> m "%s: %.3fs" name elapsed);
r
-let run ~sw env ~(base : Day11_layer.Base.t)
- ~build_dirs ?prep_upper (spec : Day11_container.Oci_spec.t) =
+let run ~sw env ~(base : Day11_layer.Base.t) ~build_dirs ?prep_upper
+ (spec : Day11_container.Oci_spec.t) =
let t_total = Unix.gettimeofday () in
let t_merge = ref 0. in
let t_prep = ref 0. in
@@ -29,10 +28,10 @@ let run ~sw env ~(base : Day11_layer.Base.t)
let base_fs = Fpath.add_seg base.dir "fs" in
let temp_dir =
let tmp = Fpath.v (Filename.get_temp_dir_name ()) in
- let name = Printf.sprintf "day11_run_%06x"
- (Random.bits () land 0xffffff) in
+ let name = Printf.sprintf "day11_run_%06x" (Random.bits () land 0xffffff) in
let p = Fpath.(tmp / name) in
- Bos.OS.Dir.create ~path:true p |> ignore; p
+ Bos.OS.Dir.create ~path:true p |> ignore;
+ p
in
let upper = Fpath.(temp_dir / "upper") in
let work = Fpath.(temp_dir / "work") in
@@ -76,43 +75,46 @@ let run ~sw env ~(base : Day11_layer.Base.t)
let fixed_overhead =
String.length "lowerdir="
+ String.length (Fpath.to_string base_fs)
- + String.length ",upperdir=" + String.length (Fpath.to_string upper)
- + String.length ",workdir=" + String.length (Fpath.to_string work)
+ + String.length ",upperdir="
+ + String.length (Fpath.to_string upper)
+ + String.length ",workdir="
+ + String.length (Fpath.to_string work)
in
let merged_overhead =
- String.length (Fpath.to_string lower) + 1 (* colon *)
+ String.length (Fpath.to_string lower) + 1
+ (* colon *)
in
let available = 4000 - fixed_overhead in
let separate_dirs, to_merge_dirs =
- Day11_layer.Stack.plan_lowerdir
- ~available ~merged_overhead ~entry_cost:dep_entry_cost
- build_dirs
+ Day11_layer.Stack.plan_lowerdir ~available ~merged_overhead
+ ~entry_cost:dep_entry_cost build_dirs
in
let did_merge = to_merge_dirs <> [] in
- if did_merge then begin
+ if did_merge then (
mkdir lower;
let merge_result =
- timed_to (Printf.sprintf "stack.merge (%d of %d build layers)"
- (List.length to_merge_dirs) (List.length build_dirs)) t_merge
+ timed_to
+ (Printf.sprintf "stack.merge (%d of %d build layers)"
+ (List.length to_merge_dirs)
+ (List.length build_dirs))
+ t_merge
(fun () ->
- Day11_layer.Stack.merge ~sw env ~layer_dirs:to_merge_dirs ~target:lower)
+ Day11_layer.Stack.merge ~sw env ~layer_dirs:to_merge_dirs
+ ~target:lower)
in
- (match merge_result with
- | Ok () -> ()
- | Error (`Msg e) ->
- Log.err (fun m -> m "stack.merge failed: %s" e))
- end;
+ match merge_result with
+ | Ok () -> ()
+ | Error (`Msg e) -> Log.err (fun m -> m "stack.merge failed: %s" e));
(* layer_fs_dirs is the list of dep lowers in the order used in
the overlayfs mount (separate first, then merged-lower if any).
It is also passed to [prep_upper] so domain-aware callers can
read per-dep state from the lowers if they need to. *)
let layer_fs_dirs =
List.map (fun d -> Fpath.(d / "fs")) separate_dirs
- @ (if did_merge then [ lower ] else [])
+ @ if did_merge then [ lower ] else []
in
let cleanup_internals () =
- if did_merge then
- ignore (Day11_sys.Sudo.rm_rf ~sw env lower);
+ if did_merge then ignore (Day11_sys.Sudo.rm_rf ~sw env lower);
ignore (Day11_sys.Sudo.rm_rf ~sw env work);
ignore (Day11_sys.Sudo.rm_rf ~sw env merged);
ignore (Bos.OS.File.delete Fpath.(temp_dir / "config.json"))
@@ -121,25 +123,28 @@ let run ~sw env ~(base : Day11_layer.Base.t)
This is where domain-aware callers seed switch state, chown
home directories, mkdir mount points, etc. *)
(match prep_upper with
- | None -> ()
- | Some f ->
- timed_to "prep_upper" t_prep (fun () ->
- f ~upper ~lowers:(layer_fs_dirs @ [ base_fs ])));
+ | None -> ()
+ | Some f ->
+ timed_to "prep_upper" t_prep (fun () ->
+ f ~upper ~lowers:(layer_fs_dirs @ [ base_fs ])));
(* Mount overlay with all layers as separate lowers *)
let overlay_lowers = layer_fs_dirs @ [ base_fs ] in
- let* () = timed_to "overlay mount" t_mount (fun () ->
- Day11_container.Overlay.mount ~sw env
- ~lower:overlay_lowers ~upper ~work ~target:merged)
+ let* () =
+ timed_to "overlay mount" t_mount (fun () ->
+ Day11_container.Overlay.mount ~sw env ~lower:overlay_lowers ~upper ~work
+ ~target:merged)
in
(* Run container — always clean up overlay + container *)
let run_result =
Fun.protect
~finally:(fun () ->
timed_to "overlay umount" t_umount (fun () ->
- ignore (Day11_container.Overlay.umount ~sw env merged)))
+ ignore (Day11_container.Overlay.umount ~sw env merged)))
(fun () ->
- let* () = Day11_container.Oci_spec.write
- ~root:(Fpath.to_string merged) temp_dir spec in
+ let* () =
+ Day11_container.Oci_spec.write ~root:(Fpath.to_string merged) temp_dir
+ spec
+ in
let container_id =
Printf.sprintf "day11-%s-%d"
(String.sub (Fpath.basename temp_dir) 0
@@ -152,20 +157,21 @@ let run ~sw env ~(base : Day11_layer.Base.t)
ignore (Day11_container.Runc.delete ~sw env container_id))
(fun () ->
timed_to "runc run" t_runc (fun () ->
- Day11_container.Runc.run ~sw env ~bundle:temp_dir
- ~container_id)))
+ Day11_container.Runc.run ~sw env ~bundle:temp_dir ~container_id)))
in
(* Always clean up internals — only upper survives *)
timed_to "cleanup internals" t_cleanup (fun () -> cleanup_internals ());
- let timing = [
- "merge", !t_merge;
- "prep_upper", !t_prep;
- "overlay_mount", !t_mount;
- "runc_run", !t_runc;
- "overlay_umount", !t_umount;
- "cleanup", !t_cleanup;
- "total", Unix.gettimeofday () -. t_total;
- ] in
+ let timing =
+ [
+ ("merge", !t_merge);
+ ("prep_upper", !t_prep);
+ ("overlay_mount", !t_mount);
+ ("runc_run", !t_runc);
+ ("overlay_umount", !t_umount);
+ ("cleanup", !t_cleanup);
+ ("total", Unix.gettimeofday () -. t_total);
+ ]
+ in
match run_result with
| Ok run -> Ok (run, upper, timing)
| Error _ as e ->
File "day11/runner/run_in_layers.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/runner/run_in_layers.mli b/_build/default/day11/runner/.formatted/run_in_layers.mli
index 2545a7f..1896068 100644
--- a/_build/default/day11/runner/run_in_layers.mli
+++ b/_build/default/day11/runner/.formatted/run_in_layers.mli
@@ -1,18 +1,16 @@
(** Run a command in a container with layers stacked.
- Handles the generic container lifecycle: stack a base layer +
- dep layers as an overlayfs, optionally seed the upper with
- domain-specific files via [~prep_upper], mount, run the
- container described by an {!Day11_container.Oci_spec.t}, clean
- up.
+ Handles the generic container lifecycle: stack a base layer + dep layers as
+ an overlayfs, optionally seed the upper with domain-specific files via
+ [~prep_upper], mount, run the container described by an
+ {!Day11_container.Oci_spec.t}, clean up.
- This module knows nothing about opam, opam switches, or doc
- generation. Any domain-specific concerns (writing an opam
- switch-state file, chowning home directories, mkdir'ing mount
- points for the container's bind mounts, choosing the cwd /
- hostname / env / argv that the contained process expects) are
- the caller's responsibility — supplied via [prep_upper] for
- upper-dir prep, and via the [Oci_spec.t] for everything else. *)
+ This module knows nothing about opam, opam switches, or doc generation. Any
+ domain-specific concerns (writing an opam switch-state file, chowning home
+ directories, mkdir'ing mount points for the container's bind mounts,
+ choosing the cwd / hostname / env / argv that the contained process expects)
+ are the caller's responsibility — supplied via [prep_upper] for upper-dir
+ prep, and via the [Oci_spec.t] for everything else. *)
val run :
sw:Eio.Switch.t ->
@@ -21,39 +19,36 @@ val run :
build_dirs:Fpath.t list ->
?prep_upper:(upper:Fpath.t -> lowers:Fpath.t list -> unit) ->
Day11_container.Oci_spec.t ->
- (Day11_sys.Run.t * Fpath.t * (string * float) list,
- [> Rresult.R.msg ]) result
-(** [run ~sw env ~base ~build_dirs ?prep_upper spec] mounts an overlayfs
- rootfs from [base] + [build_dirs], optionally seeded by
- [prep_upper], then runs the container described by [spec].
+ (Day11_sys.Run.t * Fpath.t * (string * float) list, [> Rresult.R.msg ]) result
+(** [run ~sw env ~base ~build_dirs ?prep_upper spec] mounts an overlayfs rootfs
+ from [base] + [build_dirs], optionally seeded by [prep_upper], then runs the
+ container described by [spec].
{b The lifecycle:}
+ Make a temp dir with upper/work/merged/lower subdirs.
- + Touch every dep layer (LRU bookkeeping via
- {!Day11_layer.Last_used}).
+ + Touch every dep layer (LRU bookkeeping via {!Day11_layer.Last_used}).
+ Plan the lowerdir layout via {!Day11_layer.Stack.plan_lowerdir},
- cp-merging excess layers if the mount-options string would
- overflow PAGE_SIZE.
- + Call [prep_upper ~upper ~lowers] (if supplied) so the caller
- can seed the upper with whatever files / chowns / mkdirs the
- container will need. [lowers] is the final list of lowerdirs
- in their mount order (separate dep dirs first, then merged
- lower if any). The caller can read from these to populate
- the upper based on dep contents.
+ cp-merging excess layers if the mount-options string would overflow
+ PAGE_SIZE.
+ + Call [prep_upper ~upper ~lowers] (if supplied) so the caller can seed the
+ upper with whatever files / chowns / mkdirs the container will need.
+ [lowers] is the final list of lowerdirs in their mount order (separate dep
+ dirs first, then merged lower if any). The caller can read from these to
+ populate the upper based on dep contents.
+ Mount overlayfs at [merged].
- + Instantiate [spec] with [merged] as the rootfs path and
- write [config.json] into the bundle dir.
+ + Instantiate [spec] with [merged] as the rootfs path and write
+ [config.json] into the bundle dir.
+ Run runc.
- + Umount and clean up everything except [upper], which the
- caller takes ownership of.
+ + Umount and clean up everything except [upper], which the caller takes
+ ownership of.
- [spec] is a fully-described container template — every field
- except the rootfs path is baked in. {!Day11_container.Oci_spec}
- documents the defaults; the caller is responsible for choosing
- cwd, env, hostname, network, mounts, and argv.
+ [spec] is a fully-described container template — every field except the
+ rootfs path is baked in. {!Day11_container.Oci_spec} documents the defaults;
+ the caller is responsible for choosing cwd, env, hostname, network, mounts,
+ and argv.
- Returns [(run_result, upper_dir, timing)] on success. [timing]
- is an alist of [(phase_name, seconds)] pairs in the order each
- phase ran (merge, prep_upper, overlay_mount, runc_run,
- overlay_umount, cleanup, total). The caller is responsible for
- extracting what they need from [upper_dir] and cleaning it up. *)
+ Returns [(run_result, upper_dir, timing)] on success. [timing] is an alist
+ of [(phase_name, seconds)] pairs in the order each phase ran (merge,
+ prep_upper, overlay_mount, runc_run, overlay_umount, cleanup, total). The
+ caller is responsible for extracting what they need from [upper_dir] and
+ cleaning it up. *)
File "day11/opam_layer/build.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/build.ml b/_build/default/day11/opam_layer/.formatted/build.ml
index cd3a0f0..ca9b0b5 100644
--- a/_build/default/day11/opam_layer/build.ml
+++ b/_build/default/day11/opam_layer/.formatted/build.ml
@@ -6,7 +6,5 @@ type t = {
}
let dir_name b = Day11_layer.Dir.name b.hash
-
let dir ~os_dir b = Day11_layer.Dir.path ~os_dir b.hash
-
let layer ~os_dir b = Day11_layer.Layer.of_hash ~os_dir b.hash
File "day11/opam_layer/build.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/build.mli b/_build/default/day11/opam_layer/.formatted/build.mli
index d424b29..e635c99 100644
--- a/_build/default/day11/opam_layer/build.mli
+++ b/_build/default/day11/opam_layer/.formatted/build.mli
@@ -1,21 +1,18 @@
(** In-memory build DAG node for an opam package layer.
- {!t} is the recursive type used by the planner, executor, and
- cache lookup paths to represent one opam package build. Each node
- carries:
+ {!t} is the recursive type used by the planner, executor, and cache lookup
+ paths to represent one opam package build. Each node carries:
- - a content-addressed [hash] computed from the base image, the
- transitive dep hashes, and the package's effective opam file
+ - a content-addressed [hash] computed from the base image, the transitive
+ dep hashes, and the package's effective opam file
- the [pkg] being built
- - a [deps] list — the *direct* dependency build nodes (which
- themselves carry their own [deps], so the field forms a DAG)
- - a [universe] identifier so that two builds of the same package
- against different sets of co-installed packages get distinct
- cache entries
+ - a [deps] list — the *direct* dependency build nodes (which themselves
+ carry their own [deps], so the field forms a DAG)
+ - a [universe] identifier so that two builds of the same package against
+ different sets of co-installed packages get distinct cache entries
- Use {!dir_name} or {!dir} to derive the on-disk path for a node;
- those wrap {!Day11_layer.Dir} which encodes the
- [build-XXXXXXXXXXXX] convention. *)
+ Use {!dir_name} or {!dir} to derive the on-disk path for a node; those wrap
+ {!Day11_layer.Dir} which encodes the [build-XXXXXXXXXXXX] convention. *)
type t = {
hash : string;
@@ -25,12 +22,11 @@ type t = {
}
val dir_name : t -> string
-(** [dir_name b] returns the layer directory name for [b]
- (e.g. ["build-c9f7404f9f87"]). *)
+(** [dir_name b] returns the layer directory name for [b] (e.g.
+ ["build-c9f7404f9f87"]). *)
val dir : os_dir:Fpath.t -> t -> Fpath.t
-(** [dir ~os_dir b] returns the absolute layer directory under
- [os_dir]. *)
+(** [dir ~os_dir b] returns the absolute layer directory under [os_dir]. *)
val layer : os_dir:Fpath.t -> t -> Day11_layer.Layer.t
(** [layer ~os_dir b] returns a {!Day11_layer.Layer.t} for [b]. *)
File "day11/opam_layer/build_meta.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/build_meta.ml b/_build/default/day11/opam_layer/.formatted/build_meta.ml
index 9369018..4792916 100644
--- a/_build/default/day11/opam_layer/build_meta.ml
+++ b/_build/default/day11/opam_layer/.formatted/build_meta.ml
@@ -5,10 +5,8 @@
Old files where deps was a plain string array still load — each
entry's hash is left empty and callers cross-reference
[layer.json.parent_hashes] (which is parallel-ordered). *)
-type dep = {
- pkg : string;
- hash : string; [@default ""]
-} [@@deriving yojson { strict = false }]
+type dep = { pkg : string; hash : string [@default ""] }
+[@@deriving yojson { strict = false }]
let dep_list_to_yojson (deps : dep list) : Yojson.Safe.t =
`List (List.map dep_to_yojson deps)
@@ -16,26 +14,27 @@ let dep_list_to_yojson (deps : dep list) : Yojson.Safe.t =
let dep_list_of_yojson (json : Yojson.Safe.t) : (dep list, string) result =
match json with
| `List items ->
- List.fold_left (fun acc item ->
- match acc with
- | Error _ as e -> e
- | Ok xs ->
- match item with
- | `String pkg -> Ok (xs @ [ { pkg; hash = "" } ])
- | `Assoc _ ->
- (match dep_of_yojson item with
- | Ok d -> Ok (xs @ [ d ])
- | Error msg -> Error msg)
- | _ -> Error "deps: expected string or object"
- ) (Ok []) items
+ List.fold_left
+ (fun acc item ->
+ match acc with
+ | Error _ as e -> e
+ | Ok xs -> (
+ match item with
+ | `String pkg -> Ok (xs @ [ { pkg; hash = "" } ])
+ | `Assoc _ -> (
+ match dep_of_yojson item with
+ | Ok d -> Ok (xs @ [ d ])
+ | Error msg -> Error msg)
+ | _ -> Error "deps: expected string or object"))
+ (Ok []) items
| _ -> Error "deps: expected array"
type t = {
package : string;
- deps : dep list
- [@default []]
- [@to_yojson dep_list_to_yojson]
- [@of_yojson dep_list_of_yojson];
+ deps : dep list;
+ [@default []]
+ [@to_yojson dep_list_to_yojson]
+ [@of_yojson dep_list_of_yojson]
stack : string list; [@default []]
installed_libs : string list; [@default []]
installed_docs : string list; [@default []]
@@ -43,7 +42,8 @@ type t = {
base_image : string; [@default ""]
cmd : string; [@default ""]
universe : string; [@default ""]
-} [@@deriving yojson { strict = false }]
+}
+[@@deriving yojson { strict = false }]
let filename = "build.json"
@@ -53,8 +53,8 @@ let save layer_dir t =
Yojson.Safe.to_file (Fpath.to_string path) (to_yojson t);
Ok ()
with exn ->
- Rresult.R.error_msgf "Build_meta.save %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ Rresult.R.error_msgf "Build_meta.save %a: %s" Fpath.pp path
+ (Printexc.to_string exn)
let load layer_dir =
let path = Fpath.(layer_dir / "build.json") in
@@ -62,13 +62,14 @@ let load layer_dir =
match of_yojson (Yojson.Safe.from_file (Fpath.to_string path)) with
| Ok t -> Ok t
| Error msg ->
- Rresult.R.error_msgf "Build_meta.load %a: %s" Fpath.pp path msg
+ Rresult.R.error_msgf "Build_meta.load %a: %s" Fpath.pp path msg
with exn ->
- Rresult.R.error_msgf "Build_meta.load %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ Rresult.R.error_msgf "Build_meta.load %a: %s" Fpath.pp path
+ (Printexc.to_string exn)
let exists layer_dir =
- Bos.OS.File.exists Fpath.(layer_dir / "build.json") |> Result.value ~default:false
+ Bos.OS.File.exists Fpath.(layer_dir / "build.json")
+ |> Result.value ~default:false
let load_tree env ~os_dir hash =
let cache : (string, Build.t) Hashtbl.t = Hashtbl.create 16 in
@@ -77,46 +78,51 @@ let load_tree env ~os_dir hash =
match Hashtbl.find_opt cache h with
| Some b -> Ok b
| None ->
- let layer = Day11_layer.Layer.of_hash ~os_dir h in
- let layer_dir = Day11_layer.Layer.dir layer in
- let* build_meta = load layer_dir in
- (* Source the dep hashes from [build.json] (which now carries
+ let layer = Day11_layer.Layer.of_hash ~os_dir h in
+ let layer_dir = Day11_layer.Layer.dir layer in
+ let* build_meta = load layer_dir in
+ (* Source the dep hashes from [build.json] (which now carries
[(pkg, hash)] pairs and is written pre-attempt — so failed
layers have it). Fall back to [layer.json]'s
[parent_hashes] for older layers whose [build.json] still
has empty hash strings from the legacy [string list]
format. *)
- let dep_hashes_from_bm =
- List.filter_map (fun (d : dep) ->
- if d.hash = "" then None else Some d.hash) build_meta.deps
- in
- let* dep_hashes =
- if Lit.length dep_hashes_from_bm = List.length build_meta.deps
- then Ok dep_hashes_from_bm
- else
- (* Legacy build.json without hashes — fall back to
+ let dep_hashes_from_bm =
+ List.filter_map
+ (fun (d : dep) -> if d.hash = "" then None else Some d.hash)
+ build_meta.deps
+ in
+ let* dep_hashes =
+ if List.length dep_hashes_from_bm = List.length build_meta.deps then
+ Ok dep_hashes_from_bm
+ else
+ (* Legacy build.json without hashes — fall back to
layer.json. Failed layers without layer.json end up
with no walkable dep tree, but at least the root node
loads, which is enough for [day11 debug]. *)
- match Day11_layer.Meta.load env
- (Day11_layer.Layer.meta_path layer) with
- | Ok lm -> Ok lm.parent_hashes
- | Error _ -> Ok []
- in
- let* deps = load_deps dep_hashes in
- let build : Build.t = {
- hash = h;
- pkg = OpamPackage.of_string build_meta.package;
- deps;
- universe = Day11_solution.Universe.dummy;
- } in
- Hashtbl.replace cache h build;
- Ok build
+ match
+ Day11_layer.Meta.load env (Day11_layer.Layer.meta_path layer)
+ with
+ | Ok lm -> Ok lm.parent_hashes
+ | Error _ -> Ok []
+ in
+ let* deps = load_deps dep_hashes in
+ let build : Build.t =
+ {
+ hash = h;
+ pkg = OpamPackage.of_string build_meta.package;
+ deps;
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ Hashtbl.replace cache h build;
+ Ok build
and load_deps hashes =
- List.fold_left (fun acc h ->
- let* acc = acc in
- let* dep = load_h h in
- Ok (acc @ [ dep ])
- ) (Ok []) hashes
+ List.fold_left
+ (fun acc h ->
+ let* acc = acc in
+ let* dep = load_h h in
+ Ok (acc @ [ dep ]))
+ (Ok []) hashes
in
load_h hash
File "day11/opam_layer/installed_files.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/installed_files.ml b/_build/default/day11/opam_layer/.formatted/installed_files.ml
index 950219f..83988d7 100644
--- a/_build/default/day11/opam_layer/installed_files.ml
+++ b/_build/default/day11/opam_layer/.formatted/installed_files.ml
@@ -4,16 +4,22 @@ let scan_dir ~extensions ~filenames base_dir =
try
let dir_s = Fpath.to_string dir in
if Sys.file_exists dir_s && Sys.is_directory dir_s then
- Sys.readdir dir_s |> Array.iter (fun name ->
- let full_path = Fpath.(dir / name) in
- let rel_path = if prefix = "" then name else prefix ^ "/" ^ name in
- try
- if Sys.is_directory (Fpath.to_string full_path) then
- walk rel_path full_path
- else if List.exists (fun ext -> Filename.check_suffix name ext) extensions
- || List.mem name filenames then
- result := rel_path :: !result
- with Sys_error _ -> ())
+ Sys.readdir dir_s
+ |> Array.iter (fun name ->
+ let full_path = Fpath.(dir / name) in
+ let rel_path =
+ if prefix = "" then name else prefix ^ "/" ^ name
+ in
+ try
+ if Sys.is_directory (Fpath.to_string full_path) then
+ walk rel_path full_path
+ else if
+ List.exists
+ (fun ext -> Filename.check_suffix name ext)
+ extensions
+ || List.mem name filenames
+ then result := rel_path :: !result
+ with Sys_error _ -> ())
with Sys_error _ -> ()
in
walk "" base_dir;
@@ -24,15 +30,12 @@ let scan_libs ~layer_dir =
Fpath.(layer_dir / "fs" / "home" / "opam" / ".opam" / "default" / "lib")
in
scan_dir
- ~extensions:[ ".cmi"; ".cmti"; ".cmt"; ".cma"; ".cmxa"; ".cmx"; ".ml"; ".mli" ]
- ~filenames:[ "META"; "dune-package" ]
- lib_dir
+ ~extensions:
+ [ ".cmi"; ".cmti"; ".cmt"; ".cma"; ".cmxa"; ".cmx"; ".ml"; ".mli" ]
+ ~filenames:[ "META"; "dune-package" ] lib_dir
let scan_docs ~layer_dir =
let doc_dir =
Fpath.(layer_dir / "fs" / "home" / "opam" / ".opam" / "default" / "doc")
in
- scan_dir
- ~extensions:[ ".mld" ]
- ~filenames:[ "odoc-config.sexp" ]
- doc_dir
+ scan_dir ~extensions:[ ".mld" ] ~filenames:[ "odoc-config.sexp" ] doc_dir
File "day11/opam_layer/build_meta.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/build_meta.mli b/_build/default/day11/opam_layer/.formatted/build_meta.mli
index c3f63c6..02058ff 100644
--- a/_build/default/day11/opam_layer/build_meta.mli
+++ b/_build/default/day11/opam_layer/.formatted/build_meta.mli
@@ -1,85 +1,80 @@
(** Opam build sidecar: per-layer metadata for opam package builds.
- Lives next to {!Day11_layer.Meta} as [build.json] in the
- layer directory. The presence of this file marks a layer as the
- output of an opam package build (as opposed to e.g. a doc layer,
- see {!Doc_meta}, or a future layer kind that doesn't yet exist).
+ Lives next to {!Day11_layer.Meta} as [build.json] in the layer directory.
+ The presence of this file marks a layer as the output of an opam package
+ build (as opposed to e.g. a doc layer, see {!Doc_meta}, or a future layer
+ kind that doesn't yet exist).
- The opam-specific information is kept here so that
- {!Day11_layer.Meta} can stay generic and reusable across
- layer kinds. *)
+ The opam-specific information is kept here so that {!Day11_layer.Meta} can
+ stay generic and reusable across layer kinds. *)
type dep = {
- pkg : string;
- (** Direct dependency, as a [name.version] string. *)
+ pkg : string; (** Direct dependency, as a [name.version] string. *)
hash : string;
- (** Layer hash of the dep's build. Matches the corresponding entry
- in {!Day11_layer.Meta.t.parent_hashes}. Empty when reading an
- older [build.json] that recorded deps as plain strings. *)
+ (** Layer hash of the dep's build. Matches the corresponding entry in
+ {!Day11_layer.Meta.t.parent_hashes}. Empty when reading an older
+ [build.json] that recorded deps as plain strings. *)
}
type t = {
package : string;
- (** The opam package this layer was built for, as a
- [name.version] string. *)
+ (** The opam package this layer was built for, as a [name.version] string.
+ *)
deps : dep list;
- (** Direct dependencies with their layer hashes. Order is parallel
- to {!Day11_layer.Meta.t.parent_hashes}. *)
+ (** Direct dependencies with their layer hashes. Order is parallel to
+ {!Day11_layer.Meta.t.parent_hashes}. *)
stack : string list;
- (** Transitive dependency layer hashes in overlayfs-stack order —
- the exact lower stack this build ran over (direct deps frontmost
- / topmost). A superset of {!deps}, which lists only direct
- dependencies; recording the full ordered closure lets a tool
- reconstruct the rootfs without walking and re-ordering the
- dependency DAG itself. Empty in older [build.json] files (fall
- back to deriving it from the DAG). *)
+ (** Transitive dependency layer hashes in overlayfs-stack order — the
+ exact lower stack this build ran over (direct deps frontmost /
+ topmost). A superset of {!deps}, which lists only direct dependencies;
+ recording the full ordered closure lets a tool reconstruct the rootfs
+ without walking and re-ordering the dependency DAG itself. Empty in
+ older [build.json] files (fall back to deriving it from the DAG). *)
installed_libs : string list;
- (** Files under [/home/opam/.opam/default/lib/] that this build
- installed. Discovered by {!Installed_files.scan_libs} after
- the container exits. *)
+ (** Files under [/home/opam/.opam/default/lib/] that this build installed.
+ Discovered by {!Installed_files.scan_libs} after the container exits.
+ *)
installed_docs : string list;
- (** Files under [/home/opam/.opam/default/doc/] that this build
- installed. Discovered by {!Installed_files.scan_docs}. *)
+ (** Files under [/home/opam/.opam/default/doc/] that this build installed.
+ Discovered by {!Installed_files.scan_docs}. *)
patches : string list;
- (** Filenames of patch files applied to this package before
- building, if any. *)
+ (** Filenames of patch files applied to this package before building, if
+ any. *)
base_image : string;
- (** The base Docker image the build used (e.g.
- ["debian-12-ocaml-5.2:abc123"]). Persisting it lets a cold
- rerun re-import the base layer without consulting an external
- profile. Empty in older [build.json] files. *)
+ (** The base Docker image the build used (e.g.
+ ["debian-12-ocaml-5.2:abc123"]). Persisting it lets a cold rerun
+ re-import the base layer without consulting an external profile. Empty
+ in older [build.json] files. *)
cmd : string;
- (** The shell command run inside the build container, e.g.
- ["opam-build -v fmt.0.9.0 --patch /patches/000.patch"]. Empty
- in older [build.json] files. *)
+ (** The shell command run inside the build container, e.g.
+ ["opam-build -v fmt.0.9.0 --patch /patches/000.patch"]. Empty in older
+ [build.json] files. *)
universe : string;
- (** The doc-deps universe digest this build was emitted into.
- Identifies which link-time mount stack a doc layer must use to
- be consistent with this package. Empty in older [build.json]
- files. *)
+ (** The doc-deps universe digest this build was emitted into. Identifies
+ which link-time mount stack a doc layer must use to be consistent with
+ this package. Empty in older [build.json] files. *)
}
val filename : string
-(** ["build.json"] — the on-disk filename relative to the layer
- directory. *)
+(** ["build.json"] — the on-disk filename relative to the layer directory. *)
val save : Fpath.t -> t -> (unit, [> Rresult.R.msg ]) result
(** [save layer_dir t] writes [t] as [layer_dir/build.json]. *)
val load : Fpath.t -> (t, [> Rresult.R.msg ]) result
-(** [load layer_dir] reads [layer_dir/build.json] and parses it.
- Returns [Error] if the file is missing or malformed. *)
+(** [load layer_dir] reads [layer_dir/build.json] and parses it. Returns [Error]
+ if the file is missing or malformed. *)
val exists : Fpath.t -> bool
-(** [exists layer_dir] is [true] iff [layer_dir/build.json] exists.
- Use this to identify "this is an opam build layer" without
- needing to parse the contents. *)
+(** [exists layer_dir] is [true] iff [layer_dir/build.json] exists. Use this to
+ identify "this is an opam build layer" without needing to parse the
+ contents. *)
val load_tree :
Eio_unix.Stdenv.base ->
- os_dir:Fpath.t -> string ->
+ os_dir:Fpath.t ->
+ string ->
(Build.t, [> Rresult.R.msg ]) result
-(** [load_tree env ~os_dir hash] reconstructs a {!Build.t} tree by
- recursively reading layer.json + build.json files starting at
- the layer for [hash]. The [hash] is the full hash (not
- truncated). *)
+(** [load_tree env ~os_dir hash] reconstructs a {!Build.t} tree by recursively
+ reading layer.json + build.json files starting at the layer for [hash]. The
+ [hash] is the full hash (not truncated). *)
File "day11/opam_layer/installed_files.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/installed_files.mli b/_build/default/day11/opam_layer/.formatted/installed_files.mli
index 845693a..5c557d2 100644
--- a/_build/default/day11/opam_layer/installed_files.mli
+++ b/_build/default/day11/opam_layer/.formatted/installed_files.mli
@@ -1,17 +1,15 @@
(** Scan a layer's overlay for installed files.
- After a build, the overlay [fs/] directory contains new and changed
- files. These functions scan for documentation-relevant and library
- files within the opam switch prefix. The switch is always ["default"]. *)
+ After a build, the overlay [fs/] directory contains new and changed files.
+ These functions scan for documentation-relevant and library files within the
+ opam switch prefix. The switch is always ["default"]. *)
val scan_libs : layer_dir:Fpath.t -> string list
-(** [scan_libs ~layer_dir] scans
- [layer_dir/fs/home/opam/.opam/default/lib/] for [.cmi], [.cmti],
- [.cmt], [.cma], [.cmxa], [.cmx], [.ml], [.mli], [META], and
+(** [scan_libs ~layer_dir] scans [layer_dir/fs/home/opam/.opam/default/lib/] for
+ [.cmi], [.cmti], [.cmt], [.cma], [.cmxa], [.cmx], [.ml], [.mli], [META], and
[dune-package] files. Returns sorted relative paths within [lib/]. *)
val scan_docs : layer_dir:Fpath.t -> string list
-(** [scan_docs ~layer_dir] scans
- [layer_dir/fs/home/opam/.opam/default/doc/] for [.mld] and
- [odoc-config.sexp] files. Returns sorted relative paths within
+(** [scan_docs ~layer_dir] scans [layer_dir/fs/home/opam/.opam/default/doc/] for
+ [.mld] and [odoc-config.sexp] files. Returns sorted relative paths within
[doc/]. *)
File "day11/opam_layer/opam_repo.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/opam_repo.ml b/_build/default/day11/opam_layer/.formatted/opam_repo.ml
index 3ad5522..fa267bb 100644
--- a/_build/default/day11/opam_layer/opam_repo.ml
+++ b/_build/default/day11/opam_layer/.formatted/opam_repo.ml
@@ -5,65 +5,73 @@ let create parent_dir =
Bos.OS.File.write Fpath.(path / "repo") {|opam-version: "2.0"|} |> ignore;
Ok path
with exn ->
- Rresult.R.error_msgf "Opam_repo.create %a: %s"
- Fpath.pp parent_dir (Printexc.to_string exn)
+ Rresult.R.error_msgf "Opam_repo.create %a: %s" Fpath.pp parent_dir
+ (Printexc.to_string exn)
let build_merged ~dest opam_repositories =
try
- if not (Bos.OS.Dir.exists dest |> Result.get_ok) then begin
+ if not (Bos.OS.Dir.exists dest |> Result.get_ok) then (
Bos.OS.Dir.create ~path:true dest |> ignore;
- List.iteri (fun i repo ->
- let src = Fpath.v repo in
- if i = 0 then begin
- let cmd = Printf.sprintf "cp -a %s/. %s/"
- (Fpath.to_string src) (Fpath.to_string dest) in
- if Sys.command cmd <> 0 then
- failwith (Printf.sprintf "cp -a failed for %s" repo)
- end else begin
- let src_pkgs = Fpath.(src / "packages") in
- if Bos.OS.Dir.exists src_pkgs |> Result.get_ok then begin
- let dst_pkgs = Fpath.(dest / "packages") in
- Bos.OS.Dir.create ~path:true dst_pkgs |> ignore;
- let cmd = Printf.sprintf "cp -a %s/. %s/"
- (Fpath.to_string src_pkgs) (Fpath.to_string dst_pkgs) in
+ List.iteri
+ (fun i repo ->
+ let src = Fpath.v repo in
+ if i = 0 then (
+ let cmd =
+ Printf.sprintf "cp -a %s/. %s/" (Fpath.to_string src)
+ (Fpath.to_string dest)
+ in
if Sys.command cmd <> 0 then
- failwith (Printf.sprintf "cp -a failed for %s packages" repo)
- end
- end
- ) opam_repositories
- end;
+ failwith (Printf.sprintf "cp -a failed for %s" repo))
+ else
+ let src_pkgs = Fpath.(src / "packages") in
+ if Bos.OS.Dir.exists src_pkgs |> Result.get_ok then (
+ let dst_pkgs = Fpath.(dest / "packages") in
+ Bos.OS.Dir.create ~path:true dst_pkgs |> ignore;
+ let cmd =
+ Printf.sprintf "cp -a %s/. %s/" (Fpath.to_string src_pkgs)
+ (Fpath.to_string dst_pkgs)
+ in
+ if Sys.command cmd <> 0 then
+ failwith (Printf.sprintf "cp -a failed for %s packages" repo)))
+ opam_repositories);
Ok ()
with exn ->
Rresult.R.error_msgf "Opam_repo.build_merged: %s" (Printexc.to_string exn)
let populate ~opam_repo ~opam_repositories packages =
try
- List.iter (fun dep_pkg ->
- let name = OpamPackage.name_to_string dep_pkg in
- let pkg_str = OpamPackage.to_string dep_pkg in
- let rel = Fpath.(v "packages" / name / pkg_str) in
- List.find_map (fun repo ->
- let src = Fpath.(repo // rel) in
- if Bos.OS.Dir.exists src |> Result.get_ok then Some src else None
- ) opam_repositories
- |> Option.iter (fun src ->
- let dst = Fpath.(opam_repo // rel) in
- Bos.OS.Dir.create ~path:true dst |> ignore;
- let src_opam = Fpath.(src / "opam") in
- if Bos.OS.File.exists src_opam |> Result.get_ok then
- Bos.OS.File.read src_opam |> Result.get_ok
- |> Bos.OS.File.write Fpath.(dst / "opam") |> ignore;
- let src_files = Fpath.(src / "files") in
- if Bos.OS.Dir.exists src_files |> Result.get_ok then begin
- let dst_files = Fpath.(dst / "files") in
- Bos.OS.Dir.create dst_files |> ignore;
- Sys.readdir (Fpath.to_string src_files) |> Array.iter (fun f ->
- let content =
- Bos.OS.File.read Fpath.(src_files / f) |> Result.get_ok
- in
- Bos.OS.File.write Fpath.(dst_files / f) content |> ignore)
- end)
- ) packages;
+ List.iter
+ (fun dep_pkg ->
+ let name = OpamPackage.name_to_string dep_pkg in
+ let pkg_str = OpamPackage.to_string dep_pkg in
+ let rel = Fpath.(v "packages" / name / pkg_str) in
+ List.find_map
+ (fun repo ->
+ let src = Fpath.(repo // rel) in
+ if Bos.OS.Dir.exists src |> Result.get_ok then Some src else None)
+ opam_repositories
+ |> Option.iter (fun src ->
+ let dst = Fpath.(opam_repo // rel) in
+ Bos.OS.Dir.create ~path:true dst |> ignore;
+ let src_opam = Fpath.(src / "opam") in
+ if Bos.OS.File.exists src_opam |> Result.get_ok then
+ Bos.OS.File.read src_opam
+ |> Result.get_ok
+ |> Bos.OS.File.write Fpath.(dst / "opam")
+ |> ignore;
+ let src_files = Fpath.(src / "files") in
+ if Bos.OS.Dir.exists src_files |> Result.get_ok then (
+ let dst_files = Fpath.(dst / "files") in
+ Bos.OS.Dir.create dst_files |> ignore;
+ Sys.readdir (Fpath.to_string src_files)
+ |> Array.iter (fun f ->
+ let content =
+ Bos.OS.File.read Fpath.(src_files / f)
+ |> Result.get_ok
+ in
+ Bos.OS.File.write Fpath.(dst_files / f) content
+ |> ignore))))
+ packages;
Ok ()
with exn ->
Rresult.R.error_msgf "Opam_repo.populate: %s" (Printexc.to_string exn)
@@ -75,73 +83,77 @@ let snapshot_to_layer ~layer_dir ~opam_repositories ?(patches = []) pkg =
let name = OpamPackage.name_to_string pkg in
let pkg_str = OpamPackage.to_string pkg in
let rel = Fpath.(v "packages" / name / pkg_str) in
- let src_opt = List.find_map (fun repo ->
- let src = Fpath.(repo // rel) in
- if Bos.OS.Dir.exists src |> Result.get_ok then Some src else None
- ) opam_repositories in
+ let src_opt =
+ List.find_map
+ (fun repo ->
+ let src = Fpath.(repo // rel) in
+ if Bos.OS.Dir.exists src |> Result.get_ok then Some src else None)
+ opam_repositories
+ in
match src_opt with
| None ->
- Rresult.R.error_msgf "Opam_repo.snapshot_to_layer: package %s not \
- found in any of %d source repos" pkg_str
- (List.length opam_repositories)
+ Rresult.R.error_msgf
+ "Opam_repo.snapshot_to_layer: package %s not found in any of %d \
+ source repos"
+ pkg_str
+ (List.length opam_repositories)
| Some src ->
- let repo_dir = Fpath.(layer_dir / "opam-repository") in
- Bos.OS.Dir.create ~path:true repo_dir |> ignore;
- Bos.OS.File.write Fpath.(repo_dir / "repo") {|opam-version: "2.0"|}
- |> ignore;
- let dst = Fpath.(repo_dir // rel) in
- Bos.OS.Dir.create ~path:true dst |> ignore;
- let src_opam = Fpath.(src / "opam") in
- let dst_opam = Fpath.(dst / "opam") in
- let opam_content =
- if Bos.OS.File.exists src_opam |> Result.get_ok
- then Bos.OS.File.read src_opam |> Result.get_ok
- else ""
- in
- let dst_files = Fpath.(dst / "files") in
- let src_files = Fpath.(src / "files") in
- if Bos.OS.Dir.exists src_files |> Result.get_ok then begin
- Bos.OS.Dir.create dst_files |> ignore;
- Sys.readdir (Fpath.to_string src_files) |> Array.iter (fun f ->
- let content =
- Bos.OS.File.read Fpath.(src_files / f) |> Result.get_ok
- in
- Bos.OS.File.write Fpath.(dst_files / f) content |> ignore)
- end;
- let patch_basenames =
- if patches = [] then []
- else begin
- Bos.OS.Dir.create ~path:true dst_files |> ignore;
- List.mapi (fun i path ->
- let bn =
- Printf.sprintf "%03d-%s" i (Fpath.basename path) in
- let content = Bos.OS.File.read path |> Result.get_ok in
- Bos.OS.File.write Fpath.(dst_files / bn) content
- |> ignore;
- bn
- ) patches
- end
- in
- (* Write the (possibly patched) opam file. If we added patches,
+ let repo_dir = Fpath.(layer_dir / "opam-repository") in
+ Bos.OS.Dir.create ~path:true repo_dir |> ignore;
+ Bos.OS.File.write Fpath.(repo_dir / "repo") {|opam-version: "2.0"|}
+ |> ignore;
+ let dst = Fpath.(repo_dir // rel) in
+ Bos.OS.Dir.create ~path:true dst |> ignore;
+ let src_opam = Fpath.(src / "opam") in
+ let dst_opam = Fpath.(dst / "opam") in
+ let opam_content =
+ if Bos.OS.File.exists src_opam |> Result.get_ok then
+ Bos.OS.File.read src_opam |> Result.get_ok
+ else ""
+ in
+ let dst_files = Fpath.(dst / "files") in
+ let src_files = Fpath.(src / "files") in
+ if Bos.OS.Dir.exists src_files |> Result.get_ok then (
+ Bos.OS.Dir.create dst_files |> ignore;
+ Sys.readdir (Fpath.to_string src_files)
+ |> Array.iter (fun f ->
+ let content =
+ Bos.OS.File.read Fpath.(src_files / f) |> Result.get_ok
+ in
+ Bos.OS.File.write Fpath.(dst_files / f) content |> ignore));
+ let patch_basenames =
+ if patches = [] then []
+ else (
+ Bos.OS.Dir.create ~path:true dst_files |> ignore;
+ List.mapi
+ (fun i path ->
+ let bn = Printf.sprintf "%03d-%s" i (Fpath.basename path) in
+ let content = Bos.OS.File.read path |> Result.get_ok in
+ Bos.OS.File.write Fpath.(dst_files / bn) content |> ignore;
+ bn)
+ patches)
+ in
+ (* Write the (possibly patched) opam file. If we added patches,
parse the original, splice them into the [patches:] field, and
re-serialise — opam will then apply them naturally at install
time without needing the day11 [--patch] mechanism. *)
- let final_opam =
- if patch_basenames = [] then opam_content
- else
- let opam = OpamFile.OPAM.read_from_string opam_content in
- let existing = OpamFile.OPAM.patches opam in
- let new_patches =
- List.map (fun b ->
- (OpamFilename.Base.of_string b, None)) patch_basenames
- in
- let opam' =
- OpamFile.OPAM.with_patches (existing @ new_patches) opam in
- OpamFile.OPAM.write_to_string opam'
- in
- Bos.OS.File.write dst_opam final_opam |> ignore;
- Ok ()
+ let final_opam =
+ if patch_basenames = [] then opam_content
+ else
+ let opam = OpamFile.OPAM.read_from_string opam_content in
+ let existing = OpamFile.OPAM.patches opam in
+ let new_patches =
+ List.map
+ (fun b -> (OpamFilename.Base.of_string b, None))
+ patch_basenames
+ in
+ let opam' =
+ OpamFile.OPAM.with_patches (existing @ new_patches) opam
+ in
+ OpamFile.OPAM.write_to_string opam'
+ in
+ Bos.OS.File.write dst_opam final_opam |> ignore;
+ Ok ()
with exn ->
Rresult.R.error_msgf "Opam_repo.snapshot_to_layer: %s"
(Printexc.to_string exn)
-
File "day11/opam_layer/opam_repo.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/opam_repo.mli b/_build/default/day11/opam_layer/.formatted/opam_repo.mli
index 276a6f1..07c2fc2 100644
--- a/_build/default/day11/opam_layer/opam_repo.mli
+++ b/_build/default/day11/opam_layer/.formatted/opam_repo.mli
@@ -1,36 +1,31 @@
(** Opam repository assembly.
- Assembles the [opam-repository/] subdirectory inside a layer or
- temp directory. This is pure filesystem work — copies opam files
- from source repositories. *)
+ Assembles the [opam-repository/] subdirectory inside a layer or temp
+ directory. This is pure filesystem work — copies opam files from source
+ repositories. *)
-val create :
- Fpath.t -> (Fpath.t, [> Rresult.R.msg ]) result
-(** [create parent_dir] creates an [opam-repository/] subdirectory
- under [parent_dir] with a [repo] file. Returns the path to the
- created directory. *)
+val create : Fpath.t -> (Fpath.t, [> Rresult.R.msg ]) result
+(** [create parent_dir] creates an [opam-repository/] subdirectory under
+ [parent_dir] with a [repo] file. Returns the path to the created directory.
+*)
val build_merged :
- dest:Fpath.t ->
- string list ->
- (unit, [> Rresult.R.msg ]) result
-(** [build_merged ~dest opam_repositories] assembles a merged opam
- repository at [dest] by overlaying entries from each source repo,
- later ones overriding earlier ones at the package level. The first
- entry is copied wholesale (for top-level files like [repo] and
- [version]); subsequent entries contribute only their [packages/]
- trees. A no-op if [dest] already exists. *)
+ dest:Fpath.t -> string list -> (unit, [> Rresult.R.msg ]) result
+(** [build_merged ~dest opam_repositories] assembles a merged opam repository at
+ [dest] by overlaying entries from each source repo, later ones overriding
+ earlier ones at the package level. The first entry is copied wholesale (for
+ top-level files like [repo] and [version]); subsequent entries contribute
+ only their [packages/] trees. A no-op if [dest] already exists. *)
val populate :
opam_repo:Fpath.t ->
opam_repositories:Fpath.t list ->
OpamPackage.t list ->
(unit, [> Rresult.R.msg ]) result
-(** [populate ~opam_repo ~opam_repositories packages] copies the opam
- file (and any [files/] directory) for each package in [packages]
- from the first matching directory in [opam_repositories] into
- [opam_repo]. Packages not found in any repository are silently
- skipped. *)
+(** [populate ~opam_repo ~opam_repositories packages] copies the opam file (and
+ any [files/] directory) for each package in [packages] from the first
+ matching directory in [opam_repositories] into [opam_repo]. Packages not
+ found in any repository are silently skipped. *)
val snapshot_to_layer :
layer_dir:Fpath.t ->
@@ -38,18 +33,15 @@ val snapshot_to_layer :
?patches:Fpath.t list ->
OpamPackage.t ->
(unit, [> Rresult.R.msg ]) result
-(** [snapshot_to_layer ~layer_dir ~opam_repositories ?patches pkg]
- writes a single-package opam-repository slice into
- [<layer_dir>/opam-repository/], containing just [pkg]'s [opam]
- file and [files/] directory.
-
- If [?patches] is supplied, each patch file is copied into the
- slice's [files/] directory under a stable [NNN-<basename>] name
- and added to the opam file's [patches:] field. The result is a
- self-contained slice that can be mounted at
- [/home/opam/.opam/repo/default] for a deterministic re-install,
- with patches applied natively by opam (no [--patch] flag needed).
-
- Returns [Error] if [pkg] isn't present in any of
- [opam_repositories]. *)
-
+(** [snapshot_to_layer ~layer_dir ~opam_repositories ?patches pkg] writes a
+ single-package opam-repository slice into [<layer_dir>/opam-repository/],
+ containing just [pkg]'s [opam] file and [files/] directory.
+
+ If [?patches] is supplied, each patch file is copied into the slice's
+ [files/] directory under a stable [NNN-<basename>] name and added to the
+ opam file's [patches:] field. The result is a self-contained slice that can
+ be mounted at [/home/opam/.opam/repo/default] for a deterministic
+ re-install, with patches applied natively by opam (no [--patch] flag
+ needed).
+
+ Returns [Error] if [pkg] isn't present in any of [opam_repositories]. *)
File "day11/opam_layer/opamh.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/opamh.ml b/_build/default/day11/opam_layer/.formatted/opamh.ml
index dc139d7..f085eab 100644
--- a/_build/default/day11/opam_layer/opamh.ml
+++ b/_build/default/day11/opam_layer/.formatted/opamh.ml
@@ -1,17 +1,31 @@
let compiler_packages =
List.map OpamPackage.Name.of_string
- [ "base-bigarray"; "base-domains"; "base-effects"; "base-nnp";
- "base-threads"; "base-unix"; "host-arch-x86"; "host-system-other";
- "ocaml"; "ocaml-base-compiler"; "ocaml-compiler"; "ocaml-config";
- "ocaml-options-vanilla"; "ocaml-system"; "ocaml-variants" ]
+ [
+ "base-bigarray";
+ "base-domains";
+ "base-effects";
+ "base-nnp";
+ "base-threads";
+ "base-unix";
+ "host-arch-x86";
+ "host-system-other";
+ "ocaml";
+ "ocaml-base-compiler";
+ "ocaml-compiler";
+ "ocaml-config";
+ "ocaml-options-vanilla";
+ "ocaml-system";
+ "ocaml-variants";
+ ]
let dump_state packages_dirs state_file =
try
let content =
- List.concat_map (fun dir ->
- try Sys.readdir (Fpath.to_string dir) |> Array.to_list
- with Sys_error _ -> []
- ) packages_dirs
+ List.concat_map
+ (fun dir ->
+ try Sys.readdir (Fpath.to_string dir) |> Array.to_list
+ with Sys_error _ -> [])
+ packages_dirs
in
let packages =
List.filter_map OpamPackage.of_string_opt content
@@ -23,15 +37,16 @@ let dump_state packages_dirs state_file =
packages
in
let s = OpamPackage.Set.of_list packages in
- let new_state = {
- OpamTypes.sel_installed = s;
- sel_roots = s;
- sel_pinned = OpamPackage.Set.empty;
- sel_compiler = OpamPackage.Set.of_list sel_compiler;
- } in
+ let new_state =
+ {
+ OpamTypes.sel_installed = s;
+ sel_roots = s;
+ sel_pinned = OpamPackage.Set.empty;
+ sel_compiler = OpamPackage.Set.of_list sel_compiler;
+ }
+ in
OpamFilename.write
(OpamFilename.raw (Fpath.to_string state_file))
(OpamFile.SwitchSelections.write_to_string new_state);
Ok ()
- with exn ->
- Rresult.R.error_msgf "dump_state: %s" (Printexc.to_string exn)
+ with exn -> Rresult.R.error_msgf "dump_state: %s" (Printexc.to_string exn)
File "day11/opam_layer/opamh.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/opamh.mli b/_build/default/day11/opam_layer/.formatted/opamh.mli
index 4a5db4a..42de503 100644
--- a/_build/default/day11/opam_layer/opamh.mli
+++ b/_build/default/day11/opam_layer/.formatted/opamh.mli
@@ -4,6 +4,6 @@ val compiler_packages : OpamPackage.Name.t list
(** The set of packages that form the compiler stack. *)
val dump_state : Fpath.t list -> Fpath.t -> (unit, [> Rresult.R.msg ]) result
-(** [dump_state packages_dirs state_file] reads the installed packages
- from all [packages_dirs], identifies compiler packages, and writes
- a switch-state file at [state_file]. *)
+(** [dump_state packages_dirs state_file] reads the installed packages from all
+ [packages_dirs], identifies compiler packages, and writes a switch-state
+ file at [state_file]. *)
File "day11/opam_layer/tool.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/tool.ml b/_build/default/day11/opam_layer/.formatted/tool.ml
index 34f07b6..911d9e6 100644
--- a/_build/default/day11/opam_layer/tool.ml
+++ b/_build/default/day11/opam_layer/.formatted/tool.ml
@@ -1,5 +1 @@
-type t = {
- hash : string;
- dir : Fpath.t;
- builds : Build.t list;
-}
+type t = { hash : string; dir : Fpath.t; builds : Build.t list }
File "day11/opam_layer/tool.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/tool.mli b/_build/default/day11/opam_layer/.formatted/tool.mli
index f4daa6f..26314b1 100644
--- a/_build/default/day11/opam_layer/tool.mli
+++ b/_build/default/day11/opam_layer/.formatted/tool.mli
@@ -1,9 +1,5 @@
-(** A "tool" is a doc-pipeline aggregate of one or more opam package
- layers (e.g. odoc, odoc-md, odoc_driver_voodoo, plus their deps)
- used as a fixed input to doc generation containers. *)
+(** A "tool" is a doc-pipeline aggregate of one or more opam package layers
+ (e.g. odoc, odoc-md, odoc_driver_voodoo, plus their deps) used as a fixed
+ input to doc generation containers. *)
-type t = {
- hash : string;
- dir : Fpath.t;
- builds : Build.t list;
-}
+type t = { hash : string; dir : Fpath.t; builds : Build.t list }
File "day11/sys/test/test_sys.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/test/test_sys.ml b/_build/default/day11/sys/test/.formatted/test_sys.ml
index 3f06d09..71f2de9 100644
--- a/_build/default/day11/sys/test/test_sys.ml
+++ b/_build/default/day11/sys/test/.formatted/test_sys.ml
@@ -14,97 +14,105 @@ let is_error msg = function
| Error _ -> ()
| Ok _ -> Alcotest.fail (msg ^ ": expected Error, got Ok")
-let read_file path =
- Bos.OS.File.read path |> Result.get_ok
+let read_file path = Bos.OS.File.read path |> Result.get_ok
(* ── Run tests ───────────────────────────────────────────────────── *)
-let test_run_echo () = with_eio @@ fun ~sw env ->
+let test_run_echo () =
+ with_eio @@ fun ~sw env ->
let cmd = Bos.Cmd.(v "echo" % "hello") in
let r = Run.run ~sw env cmd None in
Alcotest.(check string) "stdout" "hello\n" r.output;
Alcotest.(check string) "stderr" "" r.errors;
- Alcotest.(check bool) "exit 0"
- true (r.status = `Exited 0);
+ Alcotest.(check bool) "exit 0" true (r.status = `Exited 0);
Alcotest.(check bool) "time > 0" true (r.time >= 0.0)
-let test_run_failure () = with_eio @@ fun ~sw env ->
+let test_run_failure () =
+ with_eio @@ fun ~sw env ->
let cmd = Bos.Cmd.(v "false") in
let r = Run.run ~sw env cmd None in
- Alcotest.(check bool) "exit 1"
- true (r.status = `Exited 1)
+ Alcotest.(check bool) "exit 1" true (r.status = `Exited 1)
-let test_run_stderr () = with_eio @@ fun ~sw env ->
+let test_run_stderr () =
+ with_eio @@ fun ~sw env ->
let cmd = Bos.Cmd.(v "sh" % "-c" % "echo err >&2") in
let r = Run.run ~sw env cmd None in
Alcotest.(check string) "stderr captured" "err\n" r.errors;
Alcotest.(check string) "stdout empty" "" r.output
-let test_run_output_file_passthrough () = with_eio @@ fun ~sw env ->
+let test_run_output_file_passthrough () =
+ with_eio @@ fun ~sw env ->
let path = Fpath.v "/tmp/test_marker" in
let cmd = Bos.Cmd.(v "echo" % "x") in
let r = Run.run ~sw env cmd (Some path) in
- Alcotest.(check bool) "output_file stored"
- true (r.output_file = Some path)
+ Alcotest.(check bool) "output_file stored" true (r.output_file = Some path)
-let test_run_signaled () = with_eio @@ fun ~sw env ->
+let test_run_signaled () =
+ with_eio @@ fun ~sw env ->
(* SIGKILL can't be caught — guaranteed to produce Signaled status *)
let cmd = Bos.Cmd.(v "sh" % "-c" % "kill -KILL $$") in
let r = Run.run ~sw env cmd None in
- Alcotest.(check bool) "signaled"
- true (match r.status with `Signaled _ -> true | _ -> false)
+ Alcotest.(check bool)
+ "signaled" true
+ (match r.status with `Signaled _ -> true | _ -> false)
-let test_run_concurrent () = with_eio @@ fun ~sw env ->
+let test_run_concurrent () =
+ with_eio @@ fun ~sw env ->
(* Multiple fibers spawning concurrently must each get their own
correct stdout — no crossed wires on the shared helper socket. *)
let n = 8 in
let inputs = List.init n (fun i -> i) in
let results =
- Eio.Fiber.List.map (fun i ->
- let cmd = Bos.Cmd.(v "echo" % string_of_int i) in
- i, Run.run ~sw env cmd None)
- inputs
+ Eio.Fiber.List.map
+ (fun i ->
+ let cmd = Bos.Cmd.(v "echo" % string_of_int i) in
+ (i, Run.run ~sw env cmd None))
+ inputs
in
- List.iter (fun (i, r) ->
- Alcotest.(check string) (Printf.sprintf "stdout %d" i)
- (string_of_int i ^ "\n") r.Run.output;
- Alcotest.(check bool) (Printf.sprintf "exit %d" i)
- true (r.Run.status = `Exited 0))
+ List.iter
+ (fun (i, r) ->
+ Alcotest.(check string)
+ (Printf.sprintf "stdout %d" i)
+ (string_of_int i ^ "\n")
+ r.Run.output;
+ Alcotest.(check bool)
+ (Printf.sprintf "exit %d" i)
+ true
+ (r.Run.status = `Exited 0))
results
-let test_run_nonexistent_binary () = with_eio @@ fun ~sw env ->
+let test_run_nonexistent_binary () =
+ with_eio @@ fun ~sw env ->
(* Run.run returns a t, not a result — a nonexistent binary should
either produce a Signaled/Exited status or raise Eio.Exn.Io.
It must NOT raise Failure. *)
try
let r = Run.run ~sw env Bos.Cmd.(v "nonexistent_binary_xyz") None in
(* If it returns, it should have a non-zero exit *)
- Alcotest.(check bool) "non-zero exit"
- true (r.status <> `Exited 0)
+ Alcotest.(check bool) "non-zero exit" true (r.status <> `Exited 0)
with
| Eio.Exn.Io _ ->
(* Eio wraps the spawn failure — this is acceptable *)
()
- | Failure msg when msg = "not implemented" ->
- Alcotest.fail "not implemented"
-
+ | Failure msg when msg = "not implemented" -> Alcotest.fail "not implemented"
(* ── Dir_lock tests ──────────────────────────────────────────────── *)
-let test_dir_lock_basic () = with_tmp_dir @@ fun dir ->
+let test_dir_lock_basic () =
+ with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "layer") in
mkdir target;
let executed = ref false in
let r =
- Dir_lock.with_lock target
- (fun ~set_temp_log_path:_ _path ->
- executed := true;
- Ok ())
+ Dir_lock.with_lock target (fun ~set_temp_log_path:_ _path ->
+ executed := true;
+ Ok ())
in
is_ok "lock" r;
Alcotest.(check bool) "body executed" true !executed
-let test_dir_lock_skips_when_marker_exists () = with_tmp_dir @@ fun dir ->
+let test_dir_lock_skips_when_marker_exists () =
+ with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "layer") in
mkdir target;
let marker = Fpath.v "layer.json" in
@@ -113,13 +121,14 @@ let test_dir_lock_skips_when_marker_exists () = with_tmp_dir @@ fun dir ->
let r =
Dir_lock.with_lock ~marker_file:marker target
(fun ~set_temp_log_path:_ _path ->
- executed := true;
- Ok ())
+ executed := true;
+ Ok ())
in
is_ok "lock" r;
Alcotest.(check bool) "body skipped" false !executed
-let test_dir_lock_mutual_exclusion () = with_eio @@ fun ~sw:_ _env ->
+let test_dir_lock_mutual_exclusion () =
+ with_eio @@ fun ~sw:_ _env ->
with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "layer") in
mkdir target;
@@ -127,45 +136,42 @@ let test_dir_lock_mutual_exclusion () = with_eio @@ fun ~sw:_ _env ->
let log = ref [] in
Eio.Fiber.both
(fun () ->
- Dir_lock.with_lock target
- (fun ~set_temp_log_path:_ _path ->
- log := "a-enter" :: !log;
- Eio.Fiber.yield ();
- log := "a-exit" :: !log;
- Ok ())
- |> ignore)
+ Dir_lock.with_lock target (fun ~set_temp_log_path:_ _path ->
+ log := "a-enter" :: !log;
+ Eio.Fiber.yield ();
+ log := "a-exit" :: !log;
+ Ok ())
+ |> ignore)
(fun () ->
- Dir_lock.with_lock target
- (fun ~set_temp_log_path:_ _path ->
- log := "b-enter" :: !log;
- Eio.Fiber.yield ();
- log := "b-exit" :: !log;
- Ok ())
- |> ignore);
+ Dir_lock.with_lock target (fun ~set_temp_log_path:_ _path ->
+ log := "b-enter" :: !log;
+ Eio.Fiber.yield ();
+ log := "b-exit" :: !log;
+ Ok ())
+ |> ignore);
let log = List.rev !log in
(* One must fully complete before the other enters *)
- let a_first = log = ["a-enter"; "a-exit"; "b-enter"; "b-exit"] in
- let b_first = log = ["b-enter"; "b-exit"; "a-enter"; "a-exit"] in
- Alcotest.(check bool) "serialized"
- true (a_first || b_first)
+ let a_first = log = [ "a-enter"; "a-exit"; "b-enter"; "b-exit" ] in
+ let b_first = log = [ "b-enter"; "b-exit"; "a-enter"; "a-exit" ] in
+ Alcotest.(check bool) "serialized" true (a_first || b_first)
-let test_dir_lock_cleanup_on_error () = with_tmp_dir @@ fun dir ->
+let test_dir_lock_cleanup_on_error () =
+ with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "layer") in
mkdir target;
let r =
- Dir_lock.with_lock target
- (fun ~set_temp_log_path:_ _path ->
- Error (`Msg "intentional"))
+ Dir_lock.with_lock target (fun ~set_temp_log_path:_ _path ->
+ Error (`Msg "intentional"))
in
is_error "body error propagated" r;
(* Lock file should be cleaned up — a second lock should succeed *)
let r2 =
- Dir_lock.with_lock target
- (fun ~set_temp_log_path:_ _path -> Ok ())
+ Dir_lock.with_lock target (fun ~set_temp_log_path:_ _path -> Ok ())
in
is_ok "second lock after error" r2
-let test_dir_lock_body_raises () = with_tmp_dir @@ fun dir ->
+let test_dir_lock_body_raises () =
+ with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "layer") in
mkdir target;
(* Body raises rather than returning Error — Fun.protect must still
@@ -173,60 +179,59 @@ let test_dir_lock_body_raises () = with_tmp_dir @@ fun dir ->
let raised =
try
let _ : (unit, [ `Msg of string ]) result =
- Dir_lock.with_lock target
- (fun ~set_temp_log_path:_ _ -> raise Exit)
- in false
+ Dir_lock.with_lock target (fun ~set_temp_log_path:_ _ -> raise Exit)
+ in
+ false
with Exit -> true
in
Alcotest.(check bool) "exception escaped" true raised;
(* A second acquisition must succeed — would deadlock if mutex leaked *)
- let r = Dir_lock.with_lock target
- (fun ~set_temp_log_path:_ _ -> Ok ()) in
+ let r = Dir_lock.with_lock target (fun ~set_temp_log_path:_ _ -> Ok ()) in
is_ok "second lock after raise" r
-let test_dir_lock_cross_process () = with_tmp_dir @@ fun dir ->
+let test_dir_lock_cross_process () =
+ with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "layer") in
mkdir target;
let lock_path = Fpath.to_string Fpath.(target + ".lock") in
match Unix.fork () with
| 0 ->
- (* Child: take POSIX lockf and hold for 500ms, then exit *)
- (try
- let fd = Unix.openfile lock_path
- [ Unix.O_CREAT; Unix.O_RDWR ] 0o644 in
- Unix.lockf fd Unix.F_LOCK 0;
- Unix.sleepf 0.5;
- Unix.close fd
- with _ -> ());
- Unix._exit 0
+ (* Child: take POSIX lockf and hold for 500ms, then exit *)
+ (try
+ let fd = Unix.openfile lock_path [ Unix.O_CREAT; Unix.O_RDWR ] 0o644 in
+ Unix.lockf fd Unix.F_LOCK 0;
+ Unix.sleepf 0.5;
+ Unix.close fd
+ with _ -> ());
+ Unix._exit 0
| child_pid ->
- (* Parent: give child a moment to grab the lock, then attempt our
+ (* Parent: give child a moment to grab the lock, then attempt our
own. The cross-process lockf path must wait until the child
releases. *)
- Unix.sleepf 0.1;
- let t_start = Unix.gettimeofday () in
- let r = Dir_lock.with_lock target
- (fun ~set_temp_log_path:_ _ -> Ok ()) in
- let elapsed = Unix.gettimeofday () -. t_start in
- is_ok "cross-process lock" r;
- Alcotest.(check bool) "waited for child"
- true (elapsed >= 0.3);
- ignore (Unix.waitpid [] child_pid)
-
-let test_dir_lock_with_lock_file () = with_tmp_dir @@ fun dir ->
+ Unix.sleepf 0.1;
+ let t_start = Unix.gettimeofday () in
+ let r = Dir_lock.with_lock target (fun ~set_temp_log_path:_ _ -> Ok ()) in
+ let elapsed = Unix.gettimeofday () -. t_start in
+ is_ok "cross-process lock" r;
+ Alcotest.(check bool) "waited for child" true (elapsed >= 0.3);
+ ignore (Unix.waitpid [] child_pid)
+
+let test_dir_lock_with_lock_file () =
+ with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "layer") in
mkdir target;
let locks_dir = Fpath.(dir / "locks") in
mkdir locks_dir;
let lock_file = Fpath.(locks_dir / "build-yojson.2.2.2.lock") in
let r =
- Dir_lock.with_lock ~lock_file target
- (fun ~set_temp_log_path:_ _path -> Ok ())
+ Dir_lock.with_lock ~lock_file target (fun ~set_temp_log_path:_ _path ->
+ Ok ())
in
is_ok "lock with explicit lock_file" r;
(* Lock file should have been created *)
- Alcotest.(check bool) "lock file created"
- true (Bos.OS.File.exists lock_file |> Result.get_ok)
+ Alcotest.(check bool)
+ "lock file created" true
+ (Bos.OS.File.exists lock_file |> Result.get_ok)
(* ── Tree tests ──────────────────────────────────────────────────── *)
@@ -240,21 +245,24 @@ let populate_tree dir =
write_file Fpath.(dir / "sub" / "b.txt") "bbb";
write_file Fpath.(dir / "sub" / "c.txt") "ccc"
-let test_tree_copy () = with_tmp_dir @@ fun dir ->
+let test_tree_copy () =
+ with_tmp_dir @@ fun dir ->
let src = Fpath.(dir / "src") in
let tgt = Fpath.(dir / "tgt") in
mkdir src;
populate_tree src;
let r = Tree.copy ~source:src ~target:tgt in
is_ok "copy" r;
- Alcotest.(check string) "a.txt"
- "aaa" (read_file Fpath.(tgt / "a.txt"));
- Alcotest.(check string) "sub/b.txt"
- "bbb" (read_file Fpath.(tgt / "sub" / "b.txt"));
- Alcotest.(check string) "sub/c.txt"
- "ccc" (read_file Fpath.(tgt / "sub" / "c.txt"))
-
-let test_tree_hardlink () = with_tmp_dir @@ fun dir ->
+ Alcotest.(check string) "a.txt" "aaa" (read_file Fpath.(tgt / "a.txt"));
+ Alcotest.(check string)
+ "sub/b.txt" "bbb"
+ (read_file Fpath.(tgt / "sub" / "b.txt"));
+ Alcotest.(check string)
+ "sub/c.txt" "ccc"
+ (read_file Fpath.(tgt / "sub" / "c.txt"))
+
+let test_tree_hardlink () =
+ with_tmp_dir @@ fun dir ->
let src = Fpath.(dir / "src") in
let tgt = Fpath.(dir / "tgt") in
mkdir src;
@@ -262,15 +270,14 @@ let test_tree_hardlink () = with_tmp_dir @@ fun dir ->
let r = Tree.hardlink ~source:src ~target:tgt in
is_ok "hardlink" r;
(* Contents should match *)
- Alcotest.(check string) "a.txt"
- "aaa" (read_file Fpath.(tgt / "a.txt"));
+ Alcotest.(check string) "a.txt" "aaa" (read_file Fpath.(tgt / "a.txt"));
(* Verify they're actually hardlinks (same inode) *)
let src_stat = Unix.stat (Fpath.to_string Fpath.(src / "a.txt")) in
let tgt_stat = Unix.stat (Fpath.to_string Fpath.(tgt / "a.txt")) in
- Alcotest.(check int) "same inode"
- src_stat.Unix.st_ino tgt_stat.Unix.st_ino
+ Alcotest.(check int) "same inode" src_stat.Unix.st_ino tgt_stat.Unix.st_ino
-let test_tree_hardlink_symlink () = with_tmp_dir @@ fun dir ->
+let test_tree_hardlink_symlink () =
+ with_tmp_dir @@ fun dir ->
let src = Fpath.(dir / "src") in
let tgt = Fpath.(dir / "tgt") in
mkdir src;
@@ -280,12 +287,14 @@ let test_tree_hardlink_symlink () = with_tmp_dir @@ fun dir ->
is_ok "hardlink with symlink" r;
let link_path = Fpath.to_string Fpath.(tgt / "link.txt") in
let stat = Unix.lstat link_path in
- Alcotest.(check bool) "preserved as symlink"
- true (stat.Unix.st_kind = Unix.S_LNK);
- Alcotest.(check string) "link target preserved"
- "real.txt" (Unix.readlink link_path)
+ Alcotest.(check bool)
+ "preserved as symlink" true
+ (stat.Unix.st_kind = Unix.S_LNK);
+ Alcotest.(check string)
+ "link target preserved" "real.txt" (Unix.readlink link_path)
-let test_tree_clense () = with_tmp_dir @@ fun dir ->
+let test_tree_clense () =
+ with_tmp_dir @@ fun dir ->
(* clense removes files from target whose mtime matches source.
In production, matching files are hardlinks (same inode) from the
overlay lower dir, so mtime equality is exact. We simulate this
@@ -304,15 +313,19 @@ let test_tree_clense () = with_tmp_dir @@ fun dir ->
let r = Tree.clense ~source:src ~target:tgt in
is_ok "clense" r;
(* a.txt should survive (different mtime — link was broken) *)
- Alcotest.(check bool) "a.txt survives"
- true (Bos.OS.File.exists Fpath.(tgt / "a.txt") |> Result.get_ok);
+ Alcotest.(check bool)
+ "a.txt survives" true
+ (Bos.OS.File.exists Fpath.(tgt / "a.txt") |> Result.get_ok);
(* b.txt and c.txt should be removed (same inode/mtime as source) *)
- Alcotest.(check bool) "sub/b.txt removed"
- false (Bos.OS.File.exists Fpath.(tgt / "sub" / "b.txt") |> Result.get_ok);
- Alcotest.(check bool) "sub/c.txt removed"
- false (Bos.OS.File.exists Fpath.(tgt / "sub" / "c.txt") |> Result.get_ok)
-
-let test_tree_copy_permission_error () = with_tmp_dir @@ fun dir ->
+ Alcotest.(check bool)
+ "sub/b.txt removed" false
+ (Bos.OS.File.exists Fpath.(tgt / "sub" / "b.txt") |> Result.get_ok);
+ Alcotest.(check bool)
+ "sub/c.txt removed" false
+ (Bos.OS.File.exists Fpath.(tgt / "sub" / "c.txt") |> Result.get_ok)
+
+let test_tree_copy_permission_error () =
+ with_tmp_dir @@ fun dir ->
let src = Fpath.(dir / "src") in
mkdir src;
populate_tree src;
@@ -326,7 +339,8 @@ let test_tree_copy_permission_error () = with_tmp_dir @@ fun dir ->
(* ── Atomic_swap tests ───────────────────────────────────────────── *)
-let test_atomic_swap_full_cycle () = with_eio @@ fun ~sw env ->
+let test_atomic_swap_full_cycle () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "docs" / "yojson" / "2.2.2") in
mkdir Fpath.(dir / "docs" / "yojson");
@@ -335,10 +349,12 @@ let test_atomic_swap_full_cycle () = with_eio @@ fun ~sw env ->
let committed = Atomic_swap.commit ~sw env target |> ok_or_fail "commit" in
Alcotest.(check bool) "committed" true committed;
(* Final dir should have our content *)
- Alcotest.(check string) "content"
- "<html/>" (read_file Fpath.(target / "index.html"))
+ Alcotest.(check string)
+ "content" "<html/>"
+ (read_file Fpath.(target / "index.html"))
-let test_atomic_swap_rollback () = with_eio @@ fun ~sw env ->
+let test_atomic_swap_rollback () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "docs" / "pkg" / "1.0") in
mkdir Fpath.(dir / "docs" / "pkg");
@@ -346,13 +362,16 @@ let test_atomic_swap_rollback () = with_eio @@ fun ~sw env ->
write_file Fpath.(staging / "index.html") "<html/>";
Atomic_swap.rollback ~sw env target |> is_ok "rollback";
(* Staging dir should be gone *)
- Alcotest.(check bool) "staging removed"
- false (Bos.OS.Dir.exists staging |> Result.get_ok);
+ Alcotest.(check bool)
+ "staging removed" false
+ (Bos.OS.Dir.exists staging |> Result.get_ok);
(* Target should not exist *)
- Alcotest.(check bool) "target absent"
- false (Bos.OS.Dir.exists target |> Result.get_ok)
+ Alcotest.(check bool)
+ "target absent" false
+ (Bos.OS.Dir.exists target |> Result.get_ok)
-let test_atomic_swap_cleanup_stale () = with_eio @@ fun ~sw env ->
+let test_atomic_swap_cleanup_stale () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
(* Create stale .new and .old dirs that a crash would leave *)
let stale_new = Fpath.(dir / "p" / "yojson" / "2.2.2.new") in
@@ -362,12 +381,15 @@ let test_atomic_swap_cleanup_stale () = with_eio @@ fun ~sw env ->
write_file Fpath.(stale_new / "junk") "x";
write_file Fpath.(stale_old / "junk") "x";
Atomic_swap.cleanup_stale ~sw env dir |> is_ok "cleanup";
- Alcotest.(check bool) ".new removed"
- false (Bos.OS.Dir.exists stale_new |> Result.get_ok);
- Alcotest.(check bool) ".old removed"
- false (Bos.OS.Dir.exists stale_old |> Result.get_ok)
-
-let test_atomic_swap_commit_no_staging () = with_eio @@ fun ~sw env ->
+ Alcotest.(check bool)
+ ".new removed" false
+ (Bos.OS.Dir.exists stale_new |> Result.get_ok);
+ Alcotest.(check bool)
+ ".old removed" false
+ (Bos.OS.Dir.exists stale_old |> Result.get_ok)
+
+let test_atomic_swap_commit_no_staging () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "docs" / "pkg" / "1.0") in
mkdir Fpath.(dir / "docs" / "pkg");
@@ -375,7 +397,8 @@ let test_atomic_swap_commit_no_staging () = with_eio @@ fun ~sw env ->
let committed = Atomic_swap.commit ~sw env target |> ok_or_fail "commit" in
Alcotest.(check bool) "no staging => no commit" false committed
-let test_atomic_swap_commit_replaces_existing () = with_eio @@ fun ~sw env ->
+let test_atomic_swap_commit_replaces_existing () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "docs" / "pkg" / "1.0") in
mkdir Fpath.(dir / "docs" / "pkg");
@@ -388,9 +411,9 @@ let test_atomic_swap_commit_replaces_existing () = with_eio @@ fun ~sw env ->
write_file Fpath.(s2 / "index.html") "v2";
let committed = Atomic_swap.commit ~sw env target |> ok_or_fail "commit2" in
Alcotest.(check bool) "committed" true committed;
- Alcotest.(check string) "content replaced"
- "v2" (read_file Fpath.(target / "index.html"))
-
+ Alcotest.(check string)
+ "content replaced" "v2"
+ (read_file Fpath.(target / "index.html"))
(* ── Util tests ──────────────────────────────────────────────────── *)
@@ -398,7 +421,8 @@ let test_nproc () =
let n = Util.nproc () in
Alcotest.(check bool) "nproc > 0" true (n > 0)
-let test_dir_size () = with_tmp_dir @@ fun dir ->
+let test_dir_size () =
+ with_tmp_dir @@ fun dir ->
write_file Fpath.(dir / "a") (String.make 100 'x');
write_file Fpath.(dir / "b") (String.make 200 'y');
let size = Util.dir_size dir |> ok_or_fail "dir_size" in
@@ -415,8 +439,7 @@ let test_dir_size_nonexistent () =
for a password or is not installed. *)
let test_sudo_run_echo () =
- if not (Day11_test_util.Test_util.sudo_available ()) then
- Alcotest.skip ()
+ if not (Day11_test_util.Test_util.sudo_available ()) then Alcotest.skip ()
else
with_eio @@ fun ~sw env ->
let cmd = Bos.Cmd.(v "echo" % "ok") in
@@ -425,8 +448,7 @@ let test_sudo_run_echo () =
Alcotest.(check bool) "exit 0" true (r.Run.status = `Exited 0)
let test_sudo_rm_rf () =
- if not (Day11_test_util.Test_util.sudo_available ()) then
- Alcotest.skip ()
+ if not (Day11_test_util.Test_util.sudo_available ()) then Alcotest.skip ()
else
with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
@@ -434,8 +456,9 @@ let test_sudo_rm_rf () =
mkdir target;
write_file Fpath.(target / "f") "x";
Sudo.rm_rf ~sw env target |> ok_or_fail "rm_rf";
- Alcotest.(check bool) "removed"
- false (Bos.OS.Dir.exists target |> Result.get_ok)
+ Alcotest.(check bool)
+ "removed" false
+ (Bos.OS.Dir.exists target |> Result.get_ok)
(* ── Test registration ───────────────────────────────────────────── *)
@@ -463,10 +486,8 @@ let () =
test_dir_lock_mutual_exclusion;
Alcotest.test_case "cleanup on error" `Quick
test_dir_lock_cleanup_on_error;
- Alcotest.test_case "body raises" `Quick
- test_dir_lock_body_raises;
- Alcotest.test_case "cross-process" `Quick
- test_dir_lock_cross_process;
+ Alcotest.test_case "body raises" `Quick test_dir_lock_body_raises;
+ Alcotest.test_case "cross-process" `Quick test_dir_lock_cross_process;
Alcotest.test_case "with explicit lock_file" `Quick
test_dir_lock_with_lock_file;
] );
@@ -482,8 +503,7 @@ let () =
] );
( "Atomic_swap",
[
- Alcotest.test_case "full cycle" `Quick
- test_atomic_swap_full_cycle;
+ Alcotest.test_case "full cycle" `Quick test_atomic_swap_full_cycle;
Alcotest.test_case "rollback" `Quick test_atomic_swap_rollback;
Alcotest.test_case "cleanup stale" `Quick
test_atomic_swap_cleanup_stale;
@@ -497,7 +517,7 @@ let () =
Alcotest.test_case "run echo" `Quick test_sudo_run_echo;
Alcotest.test_case "rm_rf" `Quick test_sudo_rm_rf;
] );
-( "Util",
+ ( "Util",
[
Alcotest.test_case "nproc" `Quick test_nproc;
Alcotest.test_case "dir_size" `Quick test_dir_size;
File "day11/solution/test/test_graph.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solution/test/test_graph.ml b/_build/default/day11/solution/test/.formatted/test_graph.ml
index 1ff167e..dc2e9df 100644
--- a/_build/default/day11/solution/test/test_graph.ml
+++ b/_build/default/day11/solution/test/.formatted/test_graph.ml
@@ -24,23 +24,22 @@ let test_transitive_deps () =
let s = make_solution () in
let t = Deps.transitive_deps s in
let a_deps = OpamPackage.Map.find (pkg "a.1") t in
- Alcotest.(check bool) "a has b"
- true (OpamPackage.Set.mem (pkg "b.1") a_deps);
- Alcotest.(check bool) "a has c"
- true (OpamPackage.Set.mem (pkg "c.1") a_deps);
+ Alcotest.(check bool) "a has b" true (OpamPackage.Set.mem (pkg "b.1") a_deps);
+ Alcotest.(check bool) "a has c" true (OpamPackage.Set.mem (pkg "c.1") a_deps);
let c_deps = OpamPackage.Map.find (pkg "c.1") t in
- Alcotest.(check bool) "c empty"
- true (OpamPackage.Set.is_empty c_deps)
+ Alcotest.(check bool) "c empty" true (OpamPackage.Set.is_empty c_deps)
let test_extract_ocaml_version () =
let s =
OpamPackage.Map.empty
- |> OpamPackage.Map.add (pkg "ocaml-base-compiler.5.1.0") OpamPackage.Set.empty
+ |> OpamPackage.Map.add
+ (pkg "ocaml-base-compiler.5.1.0")
+ OpamPackage.Set.empty
|> OpamPackage.Map.add (pkg "dune.3.0") OpamPackage.Set.empty
in
let v = Deps.extract_ocaml_version s in
- Alcotest.(check (option string)) "found compiler"
- (Some "ocaml-base-compiler.5.1.0")
+ Alcotest.(check (option string))
+ "found compiler" (Some "ocaml-base-compiler.5.1.0")
(Option.map OpamPackage.to_string v)
let test_extract_ocaml_version_none () =
@@ -55,42 +54,39 @@ let test_rdeps_transitive () =
let s =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "c.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "b.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
- |> OpamPackage.Map.add (pkg "a.1")
- (OpamPackage.Set.singleton (pkg "b.1"))
+ |> OpamPackage.Map.add (pkg "b.1") (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "a.1") (OpamPackage.Set.singleton (pkg "b.1"))
in
let rdeps = Rdeps.find [ s ] (pkg "c.1") in
(* both a and b transitively depend on c *)
- Alcotest.(check bool) "b is rdep of c"
- true (OpamPackage.Set.mem (pkg "b.1") rdeps);
- Alcotest.(check bool) "a is transitive rdep of c"
- true (OpamPackage.Set.mem (pkg "a.1") rdeps);
+ Alcotest.(check bool)
+ "b is rdep of c" true
+ (OpamPackage.Set.mem (pkg "b.1") rdeps);
+ Alcotest.(check bool)
+ "a is transitive rdep of c" true
+ (OpamPackage.Set.mem (pkg "a.1") rdeps);
(* c is not an rdep of itself *)
- Alcotest.(check bool) "c not rdep of itself"
- false (OpamPackage.Set.mem (pkg "c.1") rdeps)
+ Alcotest.(check bool)
+ "c not rdep of itself" false
+ (OpamPackage.Set.mem (pkg "c.1") rdeps)
let test_rdeps_not_found () =
let s = make_solution () in
let rdeps = Rdeps.find [ s ] (pkg "nonexistent.1") in
- Alcotest.(check bool) "empty"
- true (OpamPackage.Set.is_empty rdeps)
+ Alcotest.(check bool) "empty" true (OpamPackage.Set.is_empty rdeps)
let test_rdeps_multiple () =
(* s1: a -> b -> c, s2: d -> c *)
let s1 =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "c.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "b.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
- |> OpamPackage.Map.add (pkg "a.1")
- (OpamPackage.Set.singleton (pkg "b.1"))
+ |> OpamPackage.Map.add (pkg "b.1") (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "a.1") (OpamPackage.Set.singleton (pkg "b.1"))
in
let s2 =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "c.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "d.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "d.1") (OpamPackage.Set.singleton (pkg "c.1"))
in
let rdeps = Rdeps.find [ s1; s2 ] (pkg "c.1") in
Alcotest.(check bool) "a from s1" true (OpamPackage.Set.mem (pkg "a.1") rdeps);
@@ -110,23 +106,27 @@ let test_solution_json_roundtrip () =
let s = make_json_solution () in
let json = Json.to_json s in
let s2 = Json.of_json json |> ok_or_fail "of_json" in
- Alcotest.(check bool) "roundtrip"
- true (OpamPackage.Map.equal OpamPackage.Set.equal s s2)
+ Alcotest.(check bool)
+ "roundtrip" true
+ (OpamPackage.Map.equal OpamPackage.Set.equal s s2)
let test_solution_string_roundtrip () =
let s = make_json_solution () in
let str = Json.to_string s in
let s2 = Json.of_string str |> ok_or_fail "of_string" in
- Alcotest.(check bool) "roundtrip"
- true (OpamPackage.Map.equal OpamPackage.Set.equal s s2)
+ Alcotest.(check bool)
+ "roundtrip" true
+ (OpamPackage.Map.equal OpamPackage.Set.equal s s2)
-let test_solution_file_roundtrip () = with_tmp_dir @@ fun dir ->
+let test_solution_file_roundtrip () =
+ with_tmp_dir @@ fun dir ->
let path = Fpath.(dir / "solution.json") in
let s = make_json_solution () in
Json.save path s |> is_ok "save";
let s2 = Json.load path |> ok_or_fail "load" in
- Alcotest.(check bool) "roundtrip"
- true (OpamPackage.Map.equal OpamPackage.Set.equal s s2)
+ Alcotest.(check bool)
+ "roundtrip" true
+ (OpamPackage.Map.equal OpamPackage.Set.equal s s2)
let test_solution_corrupt () =
is_error "corrupt" (Json.of_json (`String "not an object"));
@@ -143,16 +143,19 @@ let () =
( "Deps",
[
Alcotest.test_case "transitive_deps" `Quick test_transitive_deps;
-Alcotest.test_case "extract_ocaml_version" `Quick
+ Alcotest.test_case "extract_ocaml_version" `Quick
test_extract_ocaml_version;
Alcotest.test_case "extract_ocaml_version none" `Quick
test_extract_ocaml_version_none;
] );
( "Json",
[
- Alcotest.test_case "json roundtrip" `Quick test_solution_json_roundtrip;
- Alcotest.test_case "string roundtrip" `Quick test_solution_string_roundtrip;
- Alcotest.test_case "file roundtrip" `Quick test_solution_file_roundtrip;
+ Alcotest.test_case "json roundtrip" `Quick
+ test_solution_json_roundtrip;
+ Alcotest.test_case "string roundtrip" `Quick
+ test_solution_string_roundtrip;
+ Alcotest.test_case "file roundtrip" `Quick
+ test_solution_file_roundtrip;
Alcotest.test_case "corrupt input" `Quick test_solution_corrupt;
Alcotest.test_case "load missing" `Quick test_solution_load_missing;
] );
File "day11/layer/test/test_layer.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/test/test_layer.ml b/_build/default/day11/layer/test/.formatted/test_layer.ml
index 249601b..069d03c 100644
--- a/_build/default/day11/layer/test/test_layer.ml
+++ b/_build/default/day11/layer/test/.formatted/test_layer.ml
@@ -7,34 +7,36 @@ let is_ok msg r = ok_or_fail msg r |> ignore
(* ── Meta tests ────────────────────────────────────────────── *)
-let test_layer_meta_roundtrip () = with_eio @@ fun ~sw:_ env ->
+let test_layer_meta_roundtrip () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let path = Fpath.(dir / "layer.json") in
- let meta : Meta.t = {
- exit_status = -1;
- parent_hashes = [ "abc123"; "def456" ];
- uid = 1000; gid = 1000;
- base_hash = "test";
- disk_usage = 0;
- timing = Meta.empty_timing;
- created_at = "2024-01-01T00:00:00Z";
- failed_dep = None;
- } in
+ let meta : Meta.t =
+ {
+ exit_status = -1;
+ parent_hashes = [ "abc123"; "def456" ];
+ uid = 1000;
+ gid = 1000;
+ base_hash = "test";
+ disk_usage = 0;
+ timing = Meta.empty_timing;
+ created_at = "2024-01-01T00:00:00Z";
+ failed_dep = None;
+ }
+ in
Meta.save env path meta |> is_ok "save";
let m = Meta.load env path |> ok_or_fail "load" in
Alcotest.(check int) "exit_status" (-1) m.exit_status;
- Alcotest.(check (list string)) "parents"
- [ "abc123"; "def456" ] m.parent_hashes
+ Alcotest.(check (list string))
+ "parents" [ "abc123"; "def456" ] m.parent_hashes
(* ── Dir tests ─────────────────────────────────────────────── *)
let test_layer_dir_name () =
- Alcotest.(check string) "12-char hash"
- "c9f7404f9f87"
+ Alcotest.(check string)
+ "12-char hash" "c9f7404f9f87"
(Dir.name "c9f7404f9f87a8b3c4d5e6f7");
- Alcotest.(check string) "short hash"
- "abc"
- (Dir.name "abc")
+ Alcotest.(check string) "short hash" "abc" (Dir.name "abc")
(* ── Symlinks tests ────────────────────────────────────────── *)
@@ -42,28 +44,31 @@ let symlink_exists path =
try (Unix.lstat (Fpath.to_string path)).Unix.st_kind = Unix.S_LNK
with Unix.Unix_error _ -> false
-let test_symlink_create () = with_eio @@ fun ~sw:_ env ->
+let test_symlink_create () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let packages_dir = Fpath.(dir / "packages") in
- Symlinks.ensure env
- ~packages_dir ~id:"yojson.2.2.2" ~layer_name:"build-abc123"
+ Symlinks.ensure env ~packages_dir ~id:"yojson.2.2.2"
+ ~layer_name:"build-abc123"
|> is_ok "create";
let link = Fpath.(packages_dir / "yojson.2.2.2" / "build-abc123") in
Alcotest.(check bool) "symlink exists" true (symlink_exists link)
-let test_symlink_idempotent () = with_eio @@ fun ~sw:_ env ->
+let test_symlink_idempotent () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let packages_dir = Fpath.(dir / "packages") in
- Symlinks.ensure env
- ~packages_dir ~id:"yojson.2.2.2" ~layer_name:"build-abc123"
+ Symlinks.ensure env ~packages_dir ~id:"yojson.2.2.2"
+ ~layer_name:"build-abc123"
|> is_ok "first";
- Symlinks.ensure env
- ~packages_dir ~id:"yojson.2.2.2" ~layer_name:"build-abc123"
+ Symlinks.ensure env ~packages_dir ~id:"yojson.2.2.2"
+ ~layer_name:"build-abc123"
|> is_ok "second"
(* ── Scan tests ──────────────────────────────────────────────────── *)
-let test_list_layers () = with_eio @@ fun ~sw:_ env ->
+let test_list_layers () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
mkdir Fpath.(dir / "build-abc123");
mkdir Fpath.(dir / "doc-def456");
@@ -71,27 +76,26 @@ let test_list_layers () = with_eio @@ fun ~sw:_ env ->
write_file Fpath.(dir / "somefile") "not a dir";
let layers = Scan.list_layers env dir in
let names = List.map fst layers in
- Alcotest.(check bool) "has build"
- true (List.mem "build-abc123" names);
- Alcotest.(check bool) "has doc"
- true (List.mem "doc-def456" names);
- Alcotest.(check bool) "has packages"
- true (List.mem "packages" names);
- Alcotest.(check bool) "no file"
- false (List.mem "somefile" names)
-
-let test_list_layers_empty () = with_eio @@ fun ~sw:_ env ->
+ Alcotest.(check bool) "has build" true (List.mem "build-abc123" names);
+ Alcotest.(check bool) "has doc" true (List.mem "doc-def456" names);
+ Alcotest.(check bool) "has packages" true (List.mem "packages" names);
+ Alcotest.(check bool) "no file" false (List.mem "somefile" names)
+
+let test_list_layers_empty () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let layers = Scan.list_layers env Fpath.(dir / "nonexistent") in
Alcotest.(check (list string)) "empty" [] (List.map fst layers)
-let test_list_package_symlinks () = with_eio @@ fun ~sw:_ env ->
+let test_list_package_symlinks () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let pkg_dir = Fpath.(dir / "yojson.2.2.2") in
mkdir pkg_dir;
Unix.symlink "../../build-abc" (Fpath.to_string Fpath.(pkg_dir / "build-abc"));
Unix.symlink "../../doc-def" (Fpath.to_string Fpath.(pkg_dir / "doc-def"));
- Unix.symlink "../../build-abc" (Fpath.to_string Fpath.(pkg_dir / "blessed-build"));
+ Unix.symlink "../../build-abc"
+ (Fpath.to_string Fpath.(pkg_dir / "blessed-build"));
let all = Scan.list_package_symlinks env dir "yojson.2.2.2" in
Alcotest.(check int) "3 total" 3 (List.length all);
let filtered =
@@ -100,22 +104,21 @@ let test_list_package_symlinks () = with_eio @@ fun ~sw:_ env ->
env dir "yojson.2.2.2"
in
let names = List.map fst filtered in
- Alcotest.(check bool) "has build"
- true (List.mem "build-abc" names);
- Alcotest.(check bool) "has doc"
- true (List.mem "doc-def" names);
- Alcotest.(check bool) "no blessed"
- false (List.mem "blessed-build" names)
+ Alcotest.(check bool) "has build" true (List.mem "build-abc" names);
+ Alcotest.(check bool) "has doc" true (List.mem "doc-def" names);
+ Alcotest.(check bool) "no blessed" false (List.mem "blessed-build" names)
(* ── Stack tests ─────────────────────────────────────────────────── *)
-let test_stack_empty () = with_eio @@ fun ~sw env ->
+let test_stack_empty () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
let target = Fpath.(dir / "lower") in
mkdir target;
Stack.merge ~sw env ~layer_dirs:[] ~target |> is_ok "empty merge"
-let test_stack_skips_missing_fs () = with_eio @@ fun ~sw env ->
+let test_stack_skips_missing_fs () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
let layer = Fpath.(dir / "build-abc") in
mkdir layer;
@@ -123,7 +126,8 @@ let test_stack_skips_missing_fs () = with_eio @@ fun ~sw env ->
mkdir target;
Stack.merge ~sw env ~layer_dirs:[ layer ] ~target |> is_ok "skip no fs"
-let test_stack_single_layer () = with_eio @@ fun ~sw env ->
+let test_stack_single_layer () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
let layer = Fpath.(dir / "build-aaa") in
mkdir Fpath.(layer / "fs" / "usr" / "lib");
@@ -132,13 +136,16 @@ let test_stack_single_layer () = with_eio @@ fun ~sw env ->
let target = Fpath.(dir / "lower") in
mkdir target;
Stack.merge ~sw env ~layer_dirs:[ layer ] ~target |> is_ok "merge";
- Alcotest.(check bool) "hello.txt"
- true (Bos.OS.File.exists Fpath.(target / "hello.txt") |> Result.get_ok);
- Alcotest.(check bool) "nested file"
- true (Bos.OS.File.exists Fpath.(target / "usr" / "lib" / "libfoo.a")
- |> Result.get_ok)
+ Alcotest.(check bool)
+ "hello.txt" true
+ (Bos.OS.File.exists Fpath.(target / "hello.txt") |> Result.get_ok);
+ Alcotest.(check bool)
+ "nested file" true
+ (Bos.OS.File.exists Fpath.(target / "usr" / "lib" / "libfoo.a")
+ |> Result.get_ok)
-let test_stack_multiple_layers () = with_eio @@ fun ~sw env ->
+let test_stack_multiple_layers () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
let layer1 = Fpath.(dir / "build-aaa") in
mkdir Fpath.(layer1 / "fs");
@@ -151,26 +158,28 @@ let test_stack_multiple_layers () = with_eio @@ fun ~sw env ->
let target = Fpath.(dir / "lower") in
mkdir target;
Stack.merge ~sw env ~layer_dirs:[ layer1; layer2 ] ~target |> is_ok "merge";
- Alcotest.(check bool) "base.txt"
- true (Bos.OS.File.exists Fpath.(target / "base.txt") |> Result.get_ok);
- Alcotest.(check bool) "extra.txt"
- true (Bos.OS.File.exists Fpath.(target / "extra.txt") |> Result.get_ok);
- let content = Bos.OS.File.read Fpath.(target / "shared.txt") |> Result.get_ok in
+ Alcotest.(check bool)
+ "base.txt" true
+ (Bos.OS.File.exists Fpath.(target / "base.txt") |> Result.get_ok);
+ Alcotest.(check bool)
+ "extra.txt" true
+ (Bos.OS.File.exists Fpath.(target / "extra.txt") |> Result.get_ok);
+ let content =
+ Bos.OS.File.read Fpath.(target / "shared.txt") |> Result.get_ok
+ in
Alcotest.(check string) "first layer wins" "from-layer1" content
(* ── plan_lowerdir tests ─────────────────────────────────────────── *)
let fake_layers ~prefix n =
- List.init n (fun i ->
- Fpath.v (Printf.sprintf "%s/build-%012d" prefix i))
+ List.init n (fun i -> Fpath.v (Printf.sprintf "%s/build-%012d" prefix i))
-let entry_cost d =
- String.length (Fpath.to_string Fpath.(d / "fs")) + 1
+let entry_cost d = String.length (Fpath.to_string Fpath.(d / "fs")) + 1
let test_plan_lowerdir_all_separate () =
let layers = fake_layers ~prefix:"/c" 10 in
- let separate, to_merge = Stack.plan_lowerdir
- ~available:3900 ~merged_overhead:30 ~entry_cost layers
+ let separate, to_merge =
+ Stack.plan_lowerdir ~available:3900 ~merged_overhead:30 ~entry_cost layers
in
Alcotest.(check int) "all kept separate" 10 (List.length separate);
Alcotest.(check int) "nothing to merge" 0 (List.length to_merge)
@@ -178,30 +187,31 @@ let test_plan_lowerdir_all_separate () =
let test_plan_lowerdir_split () =
let prefix = "/home/jjl25/cache/debian-bookworm-x86_64" in
let layers = fake_layers ~prefix 200 in
- let separate, to_merge = Stack.plan_lowerdir
- ~available:3900 ~merged_overhead:35 ~entry_cost layers
+ let separate, to_merge =
+ Stack.plan_lowerdir ~available:3900 ~merged_overhead:35 ~entry_cost layers
in
- Alcotest.(check int) "total preserved" 200
+ Alcotest.(check int)
+ "total preserved" 200
(List.length separate + List.length to_merge);
Alcotest.(check bool) "did split" true (to_merge <> []);
Alcotest.(check bool) "kept some separate" true (separate <> []);
let sep_cost = List.fold_left (fun a d -> a + entry_cost d) 0 separate in
Alcotest.(check bool)
- (Printf.sprintf "separate cost %d + merged %d ≤ available 3900"
- sep_cost 35)
- true (sep_cost + 35 <= 3900)
+ (Printf.sprintf "separate cost %d + merged %d ≤ available 3900" sep_cost 35)
+ true
+ (sep_cost + 35 <= 3900)
let test_plan_lowerdir_empty () =
- let separate, to_merge = Stack.plan_lowerdir
- ~available:3900 ~merged_overhead:30 ~entry_cost []
+ let separate, to_merge =
+ Stack.plan_lowerdir ~available:3900 ~merged_overhead:30 ~entry_cost []
in
Alcotest.(check int) "separate" 0 (List.length separate);
Alcotest.(check int) "to_merge" 0 (List.length to_merge)
let test_plan_lowerdir_short_paths_no_split () =
let layers = fake_layers ~prefix:"/c" 150 in
- let separate, to_merge = Stack.plan_lowerdir
- ~available:3900 ~merged_overhead:30 ~entry_cost layers
+ let separate, to_merge =
+ Stack.plan_lowerdir ~available:3900 ~merged_overhead:30 ~entry_cost layers
in
Alcotest.(check int) "all separate" 150 (List.length separate);
Alcotest.(check int) "no merge" 0 (List.length to_merge)
@@ -209,37 +219,40 @@ let test_plan_lowerdir_short_paths_no_split () =
let test_plan_lowerdir_boundary () =
let layers = fake_layers ~prefix:"/c" 5 in
let per = entry_cost (List.hd layers) in
- let separate, to_merge = Stack.plan_lowerdir
- ~available:(5 * per) ~merged_overhead:1 ~entry_cost layers
+ let separate, to_merge =
+ Stack.plan_lowerdir ~available:(5 * per) ~merged_overhead:1 ~entry_cost
+ layers
in
Alcotest.(check int) "all fit at boundary" 5 (List.length separate);
Alcotest.(check int) "no merge" 0 (List.length to_merge);
- let separate, to_merge = Stack.plan_lowerdir
- ~available:(5 * per - 1) ~merged_overhead:0 ~entry_cost layers
+ let separate, to_merge =
+ Stack.plan_lowerdir
+ ~available:((5 * per) - 1)
+ ~merged_overhead:0 ~entry_cost layers
in
Alcotest.(check int) "one short" 4 (List.length separate);
Alcotest.(check int) "one merged" 1 (List.length to_merge)
(* ── Snapshot tests ──────────────────────────────────────────────── *)
-let test_snapshot_empty () = with_eio @@ fun ~sw:_ env ->
+let test_snapshot_empty () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let snap = Snapshot.take env dir in
Alcotest.(check int) "size" 0 (Snapshot.size snap);
Alcotest.(check bool) "is_empty" true (Snapshot.is_empty snap)
-let test_snapshot_diff_new_file () = with_eio @@ fun ~sw:_ env ->
+let test_snapshot_diff_new_file () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
write_file Fpath.(dir / "existing") "before";
let before = Snapshot.take env dir in
write_file Fpath.(dir / "new-file") "after";
let changed = Snapshot.diff env ~before dir in
- Alcotest.(check (list string))
- "only new file"
- [ "new-file" ]
- changed
+ Alcotest.(check (list string)) "only new file" [ "new-file" ] changed
-let test_snapshot_diff_modified () = with_eio @@ fun ~sw:_ env ->
+let test_snapshot_diff_modified () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
write_file Fpath.(dir / "f") "one";
let before = Snapshot.take env dir in
@@ -249,7 +262,8 @@ let test_snapshot_diff_modified () = with_eio @@ fun ~sw:_ env ->
let changed = Snapshot.diff env ~before dir in
Alcotest.(check (list string)) "modified" [ "f" ] changed
-let test_snapshot_diff_unchanged () = with_eio @@ fun ~sw:_ env ->
+let test_snapshot_diff_unchanged () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
write_file Fpath.(dir / "f") "same";
let before = Snapshot.take env dir in
@@ -258,39 +272,43 @@ let test_snapshot_diff_unchanged () = with_eio @@ fun ~sw:_ env ->
(* ── Relocations tests ───────────────────────────────────────────── *)
-let test_relocations_clean () = with_eio @@ fun ~sw:_ env ->
+let test_relocations_clean () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
write_file Fpath.(dir / "file") "hello world";
let hits = Relocations.scan env ~layer_fs:dir ~forbidden:[ "/tmp/abc" ] in
Alcotest.(check int) "no hits" 0 (List.length hits)
-let test_relocations_hit () = with_eio @@ fun ~sw:_ env ->
+let test_relocations_hit () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
mkdir Fpath.(dir / "bin");
- write_file Fpath.(dir / "bin" / "tool")
+ write_file
+ Fpath.(dir / "bin" / "tool")
"the path is /tmp/build_xyz/prefix/lib";
- let hits = Relocations.scan env ~layer_fs:dir
- ~forbidden:[ "/tmp/build_xyz" ] in
+ let hits =
+ Relocations.scan env ~layer_fs:dir ~forbidden:[ "/tmp/build_xyz" ]
+ in
Alcotest.(check int) "one file with hit" 1 (List.length hits);
- (match hits with
- | [ (rel, _) ] ->
- Alcotest.(check string) "rel path" "bin/tool" rel
- | _ -> Alcotest.fail "expected one hit")
+ match hits with
+ | [ (rel, _) ] -> Alcotest.(check string) "rel path" "bin/tool" rel
+ | _ -> Alcotest.fail "expected one hit"
-let test_relocations_roundtrip () = with_eio @@ fun ~sw:_ env ->
+let test_relocations_roundtrip () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let data = [ ("bin/ocaml", [ "/tmp/build_xyz" ]) ] in
let path = Fpath.(dir / "relocations.json") in
Relocations.save env path data |> is_ok "save";
match Relocations.load env path with
| None -> Alcotest.fail "load failed"
- | Some rs ->
- Alcotest.(check int) "one entry" 1 (List.length rs);
- (match rs with
- | [ (k, v) ] ->
- Alcotest.(check string) "key" "bin/ocaml" k;
- Alcotest.(check (list string)) "hits" [ "/tmp/build_xyz" ] v
- | _ -> Alcotest.fail "mismatch")
+ | Some rs -> (
+ Alcotest.(check int) "one entry" 1 (List.length rs);
+ match rs with
+ | [ (k, v) ] ->
+ Alcotest.(check string) "key" "bin/ocaml" k;
+ Alcotest.(check (list string)) "hits" [ "/tmp/build_xyz" ] v
+ | _ -> Alcotest.fail "mismatch")
(* ── Test registration ───────────────────────────────────────────── *)
@@ -298,13 +316,8 @@ let () =
Alcotest.run "day11_layer"
[
( "Meta",
- [
- Alcotest.test_case "roundtrip" `Quick test_layer_meta_roundtrip;
- ] );
- ( "Dir",
- [
- Alcotest.test_case "name" `Quick test_layer_dir_name;
- ] );
+ [ Alcotest.test_case "roundtrip" `Quick test_layer_meta_roundtrip ] );
+ ("Dir", [ Alcotest.test_case "name" `Quick test_layer_dir_name ]);
( "Symlinks",
[
Alcotest.test_case "create" `Quick test_symlink_create;
@@ -314,12 +327,14 @@ let () =
[
Alcotest.test_case "list_layers" `Quick test_list_layers;
Alcotest.test_case "list_layers empty" `Quick test_list_layers_empty;
- Alcotest.test_case "list_package_symlinks" `Quick test_list_package_symlinks;
+ Alcotest.test_case "list_package_symlinks" `Quick
+ test_list_package_symlinks;
] );
( "Stack",
[
Alcotest.test_case "empty" `Quick test_stack_empty;
- Alcotest.test_case "skips missing fs" `Quick test_stack_skips_missing_fs;
+ Alcotest.test_case "skips missing fs" `Quick
+ test_stack_skips_missing_fs;
Alcotest.test_case "single layer" `Quick test_stack_single_layer;
Alcotest.test_case "multiple layers" `Quick test_stack_multiple_layers;
Alcotest.test_case "plan_lowerdir all separate" `Quick
@@ -338,7 +353,8 @@ let () =
Alcotest.test_case "empty" `Quick test_snapshot_empty;
Alcotest.test_case "diff new file" `Quick test_snapshot_diff_new_file;
Alcotest.test_case "diff modified" `Slow test_snapshot_diff_modified;
- Alcotest.test_case "diff unchanged" `Quick test_snapshot_diff_unchanged;
+ Alcotest.test_case "diff unchanged" `Quick
+ test_snapshot_diff_unchanged;
] );
( "Relocations",
[
File "day11/solver/context.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/context.ml b/_build/default/day11/solver/.formatted/context.ml
index c3654af..ccb3e17 100644
--- a/_build/default/day11/solver/context.ml
+++ b/_build/default/day11/solver/.formatted/context.ml
@@ -1,6 +1,4 @@
-type rejection =
- | UserConstraint of OpamFormula.atom
- | Unavailable
+type rejection = UserConstraint of OpamFormula.atom | Unavailable
type t = {
env : string -> OpamVariable.variable_contents option;
@@ -17,12 +15,19 @@ type t = {
let create ?(prefer_oldest = false) ?(test = OpamPackage.Name.Set.empty)
?(pins = OpamPackage.Name.Map.empty) ?(doc = false) ?(post = true)
~constraints ~env ~packages () =
- { env; packages; pins; constraints; test; prefer_oldest; doc; post;
- examined_packages = ref OpamPackage.Name.Set.empty }
-
-let user_restrictions t name =
- OpamPackage.Name.Map.find_opt name t.constraints
-
+ {
+ env;
+ packages;
+ pins;
+ constraints;
+ test;
+ prefer_oldest;
+ doc;
+ post;
+ examined_packages = ref OpamPackage.Name.Set.empty;
+ }
+
+let user_restrictions t name = OpamPackage.Name.Map.find_opt name t.constraints
let dev = OpamPackage.Version.of_string "dev"
let env t pkg v =
@@ -30,22 +35,23 @@ let env t pkg v =
else
match OpamVariable.Full.to_string v with
| "version" ->
- Some (OpamTypes.S
- (OpamPackage.Version.to_string (OpamPackage.version pkg)))
+ Some
+ (OpamTypes.S (OpamPackage.Version.to_string (OpamPackage.version pkg)))
| x -> t.env x
-(** Read the [x-extra-doc-deps] extension field of a package's opam
- file. These are pkg names listed under
+(** Read the [x-extra-doc-deps] extension field of a package's opam file. These
+ are pkg names listed under
- {[ x-extra-doc-deps: [ "odoc-driver" "sherlodoc" "odig" ] ]}
+ {[
+ x-extra-doc-deps: [ "odoc-driver" "sherlodoc" "odig" ]
+ ]}
- The intent of the field is "pull these in when generating my
- full doc-driver-rendered docs" — semantically equivalent to
- declaring each one in [depends:] guarded by [{with-doc & post}].
- {!augment_with_extra_doc_deps} below realises that equivalence
- by synthesising those formula atoms inside [filter_deps], so
- the standard opam pipeline (solver + post-solve dep computation)
- handles them transitively without any other code path needing
+ The intent of the field is "pull these in when generating my full
+ doc-driver-rendered docs" — semantically equivalent to declaring each one in
+ [depends:] guarded by [{with-doc & post}]. {!augment_with_extra_doc_deps}
+ below realises that equivalence by synthesising those formula atoms inside
+ [filter_deps], so the standard opam pipeline (solver + post-solve dep
+ computation) handles them transitively without any other code path needing
to consult the extension field directly. *)
let get_extra_doc_deps opamfile =
let open OpamParserTypes.FullPos in
@@ -53,58 +59,56 @@ let get_extra_doc_deps opamfile =
match OpamStd.String.Map.find_opt "x-extra-doc-deps" extensions with
| None -> OpamPackage.Name.Set.empty
| Some value ->
- let extract_name item =
- match item.pelem with
- | String name -> Some name
- | Option (inner, _) ->
- (match inner.pelem with
- | String name -> Some name
- | _ -> None)
- | _ -> None
- in
- let extract_names acc v =
- match v.pelem with
- | List { pelem = items; _ } ->
- List.fold_left (fun acc item ->
- match extract_name item with
- | Some name ->
- OpamPackage.Name.Set.add
- (OpamPackage.Name.of_string name) acc
- | None -> acc
- ) acc items
- | _ -> acc
- in
- extract_names OpamPackage.Name.Set.empty value
+ let extract_name item =
+ match item.pelem with
+ | String name -> Some name
+ | Option (inner, _) -> (
+ match inner.pelem with String name -> Some name | _ -> None)
+ | _ -> None
+ in
+ let extract_names acc v =
+ match v.pelem with
+ | List { pelem = items; _ } ->
+ List.fold_left
+ (fun acc item ->
+ match extract_name item with
+ | Some name ->
+ OpamPackage.Name.Set.add
+ (OpamPackage.Name.of_string name)
+ acc
+ | None -> acc)
+ acc items
+ | _ -> acc
+ in
+ extract_names OpamPackage.Name.Set.empty value
(** Look up [pkg]'s opam file via pins or the in-memory git_packages. *)
let opam_of_pkg t pkg =
let name = OpamPackage.name pkg in
match OpamPackage.Name.Map.find_opt name t.pins with
| Some (_ver, opam) -> opam
- | None ->
- try Day11_opam.Git_packages.get_package t.packages pkg
- with Not_found -> OpamFile.OPAM.empty
-
-(** Augment a depends formula with synthetic [{with-doc & post}]
- atoms for every entry in [x-extra-doc-deps]. The result is what
- the package would have looked like if those entries had been
- declared in [depends:] under that filter — making them
- standards-compliant opam, evaluated transitively by the solver
- and by post-solve dep computation, instead of only being
- consulted as roots for the target package. *)
+ | None -> (
+ try Day11_opam.Git_packages.get_package t.packages pkg
+ with Not_found -> OpamFile.OPAM.empty)
+
+(** Augment a depends formula with synthetic [{with-doc & post}] atoms for every
+ entry in [x-extra-doc-deps]. The result is what the package would have
+ looked like if those entries had been declared in [depends:] under that
+ filter — making them standards-compliant opam, evaluated transitively by the
+ solver and by post-solve dep computation, instead of only being consulted as
+ roots for the target package. *)
let augment_with_extra_doc_deps t pkg formula =
let opam = opam_of_pkg t pkg in
let extras = get_extra_doc_deps opam in
if OpamPackage.Name.Set.is_empty extras then formula
else
let with_doc =
- OpamTypes.FIdent ([], OpamVariable.of_string "with-doc", None) in
- let post =
- OpamTypes.FIdent ([], OpamVariable.of_string "post", None) in
+ OpamTypes.FIdent ([], OpamVariable.of_string "with-doc", None)
+ in
+ let post = OpamTypes.FIdent ([], OpamVariable.of_string "post", None) in
let with_doc_and_post = OpamTypes.FAnd (with_doc, post) in
let mk_atom n : OpamTypes.filtered_formula =
- OpamFormula.Atom
- (n, OpamFormula.Atom (OpamTypes.Filter with_doc_and_post))
+ OpamFormula.Atom (n, OpamFormula.Atom (OpamTypes.Filter with_doc_and_post))
in
let extras_formula =
OpamPackage.Name.Set.elements extras
@@ -113,23 +117,22 @@ let augment_with_extra_doc_deps t pkg formula =
in
OpamFormula.And (formula, extras_formula)
-(** Rewrite OxCaml patch-or-guard disjunctions to put the patches
- side first. opam-0install processes a disjunction's left
- branch first and rarely backtracks across multiple
- disjunctions when a later constraint forces the other branch.
- With [.guard] lex-max and the formula's natural ordering
- putting it on the left ([oxcaml-X | oxcaml-X-patches]), the
- solver commits to [.guard] — which then conflicts with the
- actual upstream package the target wanted. Swapping to
- [oxcaml-X-patches | oxcaml-X] makes the satisfiable branch
- the first try, the solver commits there, and the chain
- propagates [-patches.enabled] throughout. No-op on package
- names not matching the [oxcaml-X / oxcaml-X-patches] shape. *)
+(** Rewrite OxCaml patch-or-guard disjunctions to put the patches side first.
+ opam-0install processes a disjunction's left branch first and rarely
+ backtracks across multiple disjunctions when a later constraint forces the
+ other branch. With [.guard] lex-max and the formula's natural ordering
+ putting it on the left ([oxcaml-X | oxcaml-X-patches]), the solver commits
+ to [.guard] — which then conflicts with the actual upstream package the
+ target wanted. Swapping to [oxcaml-X-patches | oxcaml-X] makes the
+ satisfiable branch the first try, the solver commits there, and the chain
+ propagates [-patches.enabled] throughout. No-op on package names not
+ matching the [oxcaml-X / oxcaml-X-patches] shape. *)
let is_oxcaml_guard_pair a b =
let a_s = OpamPackage.Name.to_string a in
let b_s = OpamPackage.Name.to_string b in
- String.length a_s > 7 && String.sub a_s 0 7 = "oxcaml-"
- && not (Astring.String.is_suffix ~affix:"-patches" a_s)
+ String.length a_s > 7
+ && String.sub a_s 0 7 = "oxcaml-"
+ && (not (Astring.String.is_suffix ~affix:"-patches" a_s))
&& b_s = a_s ^ "-patches"
let rec swap_guard_pairs : OpamTypes.formula -> OpamTypes.formula = function
@@ -137,67 +140,63 @@ let rec swap_guard_pairs : OpamTypes.formula -> OpamTypes.formula = function
| OpamFormula.Atom _ as a -> a
| OpamFormula.Block f -> OpamFormula.Block (swap_guard_pairs f)
| OpamFormula.And (l, r) ->
- OpamFormula.And (swap_guard_pairs l, swap_guard_pairs r)
- | OpamFormula.Or (l, r) ->
- let l' = swap_guard_pairs l and r' = swap_guard_pairs r in
- (match l', r' with
- | OpamFormula.Atom (a, _), OpamFormula.Atom (b, _)
- when is_oxcaml_guard_pair a b ->
- OpamFormula.Or (r', l')
- | _ -> OpamFormula.Or (l', r'))
+ OpamFormula.And (swap_guard_pairs l, swap_guard_pairs r)
+ | OpamFormula.Or (l, r) -> (
+ let l' = swap_guard_pairs l and r' = swap_guard_pairs r in
+ match (l', r') with
+ | OpamFormula.Atom (a, _), OpamFormula.Atom (b, _)
+ when is_oxcaml_guard_pair a b ->
+ OpamFormula.Or (r', l')
+ | _ -> OpamFormula.Or (l', r'))
let filter_deps t pkg f =
- let dev =
- OpamPackage.Version.compare (OpamPackage.version pkg) dev = 0 in
- let test =
- OpamPackage.Name.Set.mem (OpamPackage.name pkg) t.test in
+ let dev = OpamPackage.Version.compare (OpamPackage.version pkg) dev = 0 in
+ let test = OpamPackage.Name.Set.mem (OpamPackage.name pkg) t.test in
augment_with_extra_doc_deps t pkg f
|> OpamFilter.partial_filter_formula (env t pkg)
- |> OpamFilter.filter_deps ~build:true ~post:t.post ~test
- ~doc:t.doc ~dev ~dev_setup:false ~default:false
+ |> OpamFilter.filter_deps ~build:true ~post:t.post ~test ~doc:t.doc ~dev
+ ~dev_setup:false ~default:false
|> swap_guard_pairs
let version_compare t (v1, v1_avoid, _) (v2, v2_avoid, _) =
match (v1_avoid, v2_avoid) with
| true, true | false, false ->
- if t.prefer_oldest then
- OpamPackage.Version.compare v1 v2
- else
- OpamPackage.Version.compare v2 v1
+ if t.prefer_oldest then OpamPackage.Version.compare v1 v2
+ else OpamPackage.Version.compare v2 v1
| true, false -> 1
| false, true -> -1
let candidates t name =
- t.examined_packages :=
- OpamPackage.Name.Set.add name !(t.examined_packages);
+ t.examined_packages := OpamPackage.Name.Set.add name !(t.examined_packages);
match OpamPackage.Name.Map.find_opt name t.pins with
- | Some (version, opam) ->
+ | Some (version, opam) -> (
let pkg = OpamPackage.create name version in
let available = OpamFile.OPAM.available opam in
- (match OpamFilter.eval ~default:(B false) (env t pkg) available with
- | B true -> [ (version, Ok opam) ]
- | _ -> [ (version, Error Unavailable) ])
+ match OpamFilter.eval ~default:(B false) (env t pkg) available with
+ | B true -> [ (version, Ok opam) ]
+ | _ -> [ (version, Error Unavailable) ])
| None ->
let versions = Day11_opam.Git_packages.get_versions t.packages name in
let user_constraints = user_restrictions t name in
OpamPackage.Version.Map.bindings versions
|> List.filter_map (fun (v, opam) ->
let pkg = OpamPackage.create name v in
- let avoid =
- OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam in
+ let avoid = OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam in
let available = OpamFile.OPAM.available opam in
- match OpamFilter.eval_to_bool ~default:false
- (env t pkg) available with
+ match
+ OpamFilter.eval_to_bool ~default:false (env t pkg) available
+ with
| true -> Some (v, avoid, opam)
| false -> None)
|> (fun l ->
- if List.for_all (fun (_, avoid, _) -> avoid) l then [] else l)
+ if List.for_all (fun (_, avoid, _) -> avoid) l then [] else l)
|> List.sort (version_compare t)
|> List.map (fun (v, _, opam) ->
match user_constraints with
- | Some test when
- not (OpamFormula.check_version_formula
- (OpamFormula.Atom test) v) ->
+ | Some test
+ when not
+ (OpamFormula.check_version_formula (OpamFormula.Atom test)
+ v) ->
(v, Error (UserConstraint (name, Some test)))
| _ -> (v, Ok opam))
@@ -205,9 +204,7 @@ let pp_rejection f = function
| UserConstraint x ->
Fmt.pf f "Rejected by user-specified constraint %s"
(OpamFormula.string_of_atom x)
- | Unavailable ->
- Fmt.string f "Availability condition not satisfied"
+ | Unavailable -> Fmt.string f "Availability condition not satisfied"
let examined_packages t = !(t.examined_packages)
-
let with_doc_post ~doc ~post t = { t with doc; post }
File "day11/solver/context.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/context.mli b/_build/default/day11/solver/.formatted/context.mli
index 93fbd0a..836191a 100644
--- a/_build/default/day11/solver/context.mli
+++ b/_build/default/day11/solver/.formatted/context.mli
@@ -5,13 +5,10 @@
solver.
Supports [prefer_oldest] for reproducible solves, doc/post dependency
- filtering, user constraints, pinned packages, and tracking which
- packages were examined (for incremental reuse). *)
-
-type rejection =
- | UserConstraint of OpamFormula.atom
- | Unavailable
+ filtering, user constraints, pinned packages, and tracking which packages
+ were examined (for incremental reuse). *)
+type rejection = UserConstraint of OpamFormula.atom | Unavailable
type t
val create :
@@ -27,18 +24,20 @@ val create :
t
val candidates :
- t -> OpamPackage.Name.t ->
+ t ->
+ OpamPackage.Name.t ->
(OpamPackage.Version.t * (OpamFile.OPAM.t, rejection) result) list
val filter_deps :
- t -> OpamPackage.t -> OpamTypes.filtered_formula ->
- OpamFormula.t
+ t -> OpamPackage.t -> OpamTypes.filtered_formula -> OpamFormula.t
val user_restrictions :
t -> OpamPackage.Name.t -> OpamFormula.version_constraint option
val env :
- t -> OpamPackage.t -> OpamVariable.Full.t ->
+ t ->
+ OpamPackage.t ->
+ OpamVariable.Full.t ->
OpamVariable.variable_contents option
val pp_rejection : rejection Fmt.t
@@ -47,6 +46,5 @@ val examined_packages : t -> OpamPackage.Name.Set.t
(** Returns the set of package names examined during solving. *)
val with_doc_post : doc:bool -> post:bool -> t -> t
-(** Create a context with different doc/post settings for recomputing
- dependency edges under alternate filter flags. Internal to the
- solver library. *)
+(** Create a context with different doc/post settings for recomputing dependency
+ edges under alternate filter flags. Internal to the solver library. *)
File "day11/solver/dot_solution.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/dot_solution.ml b/_build/default/day11/solver/.formatted/dot_solution.ml
index ce0c66c..9b469bb 100644
--- a/_build/default/day11/solver/dot_solution.ml
+++ b/_build/default/day11/solver/.formatted/dot_solution.ml
@@ -7,8 +7,12 @@ let to_string pkgs =
| [] -> None
| [ p ] -> Some (" " ^ quoted pkg ^ " -> " ^ quoted p ^ ";")
| lst ->
- Some (" " ^ quoted pkg ^ " -> {"
- ^ (lst |> List.map quoted |> String.concat " ") ^ "}"))
+ Some
+ (" "
+ ^ quoted pkg
+ ^ " -> {"
+ ^ (lst |> List.map quoted |> String.concat " ")
+ ^ "}"))
|> String.concat "\n"
in
"digraph opam {\n" ^ graph ^ "\n}\n"
File "day11/solver/dot_solution.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/dot_solution.mli b/_build/default/day11/solver/.formatted/dot_solution.mli
index 5f6e5a2..3af28cb 100644
--- a/_build/default/day11/solver/dot_solution.mli
+++ b/_build/default/day11/solver/.formatted/dot_solution.mli
@@ -3,6 +3,8 @@
val to_string : OpamPackage.Set.t OpamPackage.Map.t -> string
(** [to_string solution] renders the dependency graph as a DOT digraph. *)
-val save : Fpath.t -> OpamPackage.Set.t OpamPackage.Map.t ->
+val save :
+ Fpath.t ->
+ OpamPackage.Set.t OpamPackage.Map.t ->
(unit, [> Rresult.R.msg ]) result
(** [save path solution] writes the DOT graph to [path]. *)
File "day11/solver/solve.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/solve.ml b/_build/default/day11/solver/.formatted/solve.ml
index 033317d..d677136 100644
--- a/_build/default/day11/solver/solve.ml
+++ b/_build/default/day11/solver/.formatted/solve.ml
@@ -10,29 +10,29 @@ let get_extra_doc_deps opamfile =
let extract_name item =
match item.pelem with
| String name -> Some name
- | Option (inner, _) ->
- (match inner.pelem with
- | String name -> Some name
- | _ -> None)
+ | Option (inner, _) -> (
+ match inner.pelem with String name -> Some name | _ -> None)
| _ -> None
in
let extract_names acc v =
match v.pelem with
| List { pelem = items; _ } ->
- List.fold_left (fun acc item ->
- match extract_name item with
- | Some name ->
- OpamPackage.Name.Set.add
- (OpamPackage.Name.of_string name) acc
- | None -> acc
- ) acc items
+ List.fold_left
+ (fun acc item ->
+ match extract_name item with
+ | Some name ->
+ OpamPackage.Name.Set.add
+ (OpamPackage.Name.of_string name)
+ acc
+ | None -> acc)
+ acc items
| _ -> acc
in
extract_names OpamPackage.Name.Set.empty value
-let solve_internal ~packages:pkgs ~env ?(constraints = OpamPackage.Name.Map.empty)
- ?(pins = OpamPackage.Name.Map.empty)
- ?(prefer_oldest = false) ?(doc = true)
+let solve_internal ~packages:pkgs ~env
+ ?(constraints = OpamPackage.Name.Map.empty)
+ ?(pins = OpamPackage.Name.Map.empty) ?(prefer_oldest = false) ?(doc = true)
?(extra_targets = []) ?(pin_target = true) target =
let name = OpamPackage.name target in
let version = OpamPackage.version target in
@@ -41,11 +41,10 @@ let solve_internal ~packages:pkgs ~env ?(constraints = OpamPackage.Name.Map.empt
match OpamPackage.Name.Map.find_opt name constraints with
| Some (`Eq, existing)
when not (OpamPackage.Version.equal existing version) ->
- (* Caller asked us to pin the target but a conflicting [=]
+ (* Caller asked us to pin the target but a conflicting [=]
constraint is already set. Bail out below. *)
- constraints
- | _ ->
- OpamPackage.Name.Map.add name (`Eq, version) constraints
+ constraints
+ | _ -> OpamPackage.Name.Map.add name (`Eq, version) constraints
else
(* Latest-mode solve: don't add an [=] constraint on the target
— the solver picks any version that satisfies the rest of
@@ -58,172 +57,212 @@ let solve_internal ~packages:pkgs ~env ?(constraints = OpamPackage.Name.Map.empt
match OpamPackage.Name.Map.find_opt name constraints with
| Some (`Eq, existing)
when pin_target && not (OpamPackage.Version.equal existing version) ->
- let msg = Printf.sprintf "Target %s conflicts with constraint %s = %s"
- (OpamPackage.to_string target)
- (OpamPackage.Name.to_string name)
- (OpamPackage.Version.to_string existing) in
- Error (msg, OpamPackage.Name.Set.empty)
- | _ ->
- let constraints = List.fold_left (fun acc et ->
- OpamPackage.Name.Map.add (OpamPackage.name et)
- (`Eq, OpamPackage.version et) acc
- ) constraints extra_targets in
- let context =
- Context.create ~prefer_oldest ~constraints ~pins ~env ~packages:pkgs
- ~doc ()
- in
- let compiler_root =
- let compiler_names = List.map OpamPackage.Name.of_string
- [ "ocaml-base-compiler"; "ocaml-variants"; "ocaml-system" ] in
- List.find_opt (fun n ->
- OpamPackage.Name.Map.mem n constraints) compiler_names
- in
- (* Include x-extra-doc-deps as additional roots so they end up in the
- solution for cross-referencing during doc generation.
- Skip when doc=false (tool builds don't need doc deps). *)
- let extra_doc_roots = if not doc then [] else
- let opam =
- match OpamPackage.Name.Map.find_opt name pins with
- | Some (_ver, opam) -> opam
- | None ->
- try Day11_opam.Git_packages.get_package pkgs target
- with Not_found -> OpamFile.OPAM.empty
- in
- let open OpamParserTypes.FullPos in
- let extensions = OpamFile.OPAM.extensions opam in
- match OpamStd.String.Map.find_opt "x-extra-doc-deps" extensions with
- | None -> []
- | Some value ->
- let extract_name (item : OpamParserTypes.FullPos.value) =
- match item.pelem with
- | String s -> Some (OpamPackage.Name.of_string s)
- | Option ({ pelem = String s; _ }, _) ->
- Some (OpamPackage.Name.of_string s)
- | _ -> None
+ let msg =
+ Printf.sprintf "Target %s conflicts with constraint %s = %s"
+ (OpamPackage.to_string target)
+ (OpamPackage.Name.to_string name)
+ (OpamPackage.Version.to_string existing)
in
- let names = match value.pelem with
- | List { pelem = items; _ } ->
- List.filter_map extract_name items
- | _ -> []
+ Error (msg, OpamPackage.Name.Set.empty)
+ | _ -> (
+ let constraints =
+ List.fold_left
+ (fun acc et ->
+ OpamPackage.Name.Map.add (OpamPackage.name et)
+ (`Eq, OpamPackage.version et)
+ acc)
+ constraints extra_targets
in
- (* Drop doc-pipeline tools: they're mounted from the
+ let context =
+ Context.create ~prefer_oldest ~constraints ~pins ~env ~packages:pkgs
+ ~doc ()
+ in
+ let compiler_root =
+ let compiler_names =
+ List.map OpamPackage.Name.of_string
+ [ "ocaml-base-compiler"; "ocaml-variants"; "ocaml-system" ]
+ in
+ List.find_opt
+ (fun n -> OpamPackage.Name.Map.mem n constraints)
+ compiler_names
+ in
+ (* Include x-extra-doc-deps as additional roots so they end up in the
+ solution for cross-referencing during doc generation.
+ Skip when doc=false (tool builds don't need doc deps). *)
+ let extra_doc_roots =
+ if not doc then []
+ else
+ let opam =
+ match OpamPackage.Name.Map.find_opt name pins with
+ | Some (_ver, opam) -> opam
+ | None -> (
+ try Day11_opam.Git_packages.get_package pkgs target
+ with Not_found -> OpamFile.OPAM.empty)
+ in
+ let open OpamParserTypes.FullPos in
+ let extensions = OpamFile.OPAM.extensions opam in
+ match OpamStd.String.Map.find_opt "x-extra-doc-deps" extensions with
+ | None -> []
+ | Some value ->
+ let extract_name (item : OpamParserTypes.FullPos.value) =
+ match item.pelem with
+ | String s -> Some (OpamPackage.Name.of_string s)
+ | Option ({ pelem = String s; _ }, _) ->
+ Some (OpamPackage.Name.of_string s)
+ | _ -> None
+ in
+ let names =
+ match value.pelem with
+ | List { pelem = items; _ } ->
+ List.filter_map extract_name items
+ | _ -> []
+ in
+ (* Drop doc-pipeline tools: they're mounted from the
pre-built tool layer at doc-build time, not from this
solve. Including them here puts their full closure
(cmdliner / yojson / eio / progress) into the target's
doc-deps, which keys the build-dag universe and
multiplies per-universe rebuilds. *)
- List.filter (fun n ->
- not (Day11_solution.Tool_names.is_tool_only n)) names
- in
- let extra_target_roots = List.map OpamPackage.name extra_targets in
- let roots =
- (match compiler_root with Some c -> [ c ] | None -> [])
- @ [ name ] @ extra_doc_roots @ extra_target_roots in
- match Solver.solve context roots with
- | Error e ->
- let examined = Context.examined_packages context in
- Error (Solver.diagnostics ~verbose:true e, examined)
- | Ok selections ->
- let examined = Context.examined_packages context in
- let solved_pkgs = Solver.packages_of_result selections in
- let solved_names =
- List.fold_left (fun acc p ->
- OpamPackage.Name.Set.add (OpamPackage.name p) acc)
- OpamPackage.Name.Set.empty solved_pkgs
+ List.filter
+ (fun n -> not (Day11_solution.Tool_names.is_tool_only n))
+ names
in
- let compute_deps ~doc ~post ~extra_doc =
- let ctx = Context.with_doc_post ~doc ~post context in
- List.fold_left (fun acc pkg ->
- let opam =
- match OpamPackage.Name.Map.find_opt (OpamPackage.name pkg) pins with
- | Some (_ver, opam) -> opam
- | None ->
- try Day11_opam.Git_packages.get_package pkgs pkg
- with Not_found -> OpamFile.OPAM.empty
- in
- let deps =
- Context.filter_deps ctx pkg
- (OpamFile.OPAM.depends opam)
- in
- let dep_names =
- OpamFormula.fold_left
- (fun acc (dep_name, _) ->
- OpamPackage.Name.Set.add dep_name acc)
- OpamPackage.Name.Set.empty deps
- in
- let depopts = OpamFile.OPAM.depopts opam in
- let depopt_names =
- OpamFormula.fold_left
- (fun acc (dep_name, _) ->
- if OpamPackage.Name.Set.mem dep_name solved_names
- then OpamPackage.Name.Set.add dep_name acc
- else acc)
- OpamPackage.Name.Set.empty depopts
- in
- let all_dep_names =
- OpamPackage.Name.Set.union dep_names depopt_names
+ let extra_target_roots = List.map OpamPackage.name extra_targets in
+ let roots =
+ (match compiler_root with Some c -> [ c ] | None -> [])
+ @ [ name ]
+ @ extra_doc_roots
+ @ extra_target_roots
+ in
+ match Solver.solve context roots with
+ | Error e ->
+ let examined = Context.examined_packages context in
+ Error (Solver.diagnostics ~verbose:true e, examined)
+ | Ok selections ->
+ let examined = Context.examined_packages context in
+ let solved_pkgs = Solver.packages_of_result selections in
+ let solved_names =
+ List.fold_left
+ (fun acc p -> OpamPackage.Name.Set.add (OpamPackage.name p) acc)
+ OpamPackage.Name.Set.empty solved_pkgs
in
- (* When computing doc deps, also include per-package
+ let compute_deps ~doc ~post ~extra_doc =
+ let ctx = Context.with_doc_post ~doc ~post context in
+ List.fold_left
+ (fun acc pkg ->
+ let opam =
+ match
+ OpamPackage.Name.Map.find_opt (OpamPackage.name pkg) pins
+ with
+ | Some (_ver, opam) -> opam
+ | None -> (
+ try Day11_opam.Git_packages.get_package pkgs pkg
+ with Not_found -> OpamFile.OPAM.empty)
+ in
+ let deps =
+ Context.filter_deps ctx pkg (OpamFile.OPAM.depends opam)
+ in
+ let dep_names =
+ OpamFormula.fold_left
+ (fun acc (dep_name, _) ->
+ OpamPackage.Name.Set.add dep_name acc)
+ OpamPackage.Name.Set.empty deps
+ in
+ let depopts = OpamFile.OPAM.depopts opam in
+ let depopt_names =
+ OpamFormula.fold_left
+ (fun acc (dep_name, _) ->
+ if OpamPackage.Name.Set.mem dep_name solved_names then
+ OpamPackage.Name.Set.add dep_name acc
+ else acc)
+ OpamPackage.Name.Set.empty depopts
+ in
+ let all_dep_names =
+ OpamPackage.Name.Set.union dep_names depopt_names
+ in
+ (* When computing doc deps, also include per-package
x-extra-doc-deps (intersected with the solved set). *)
- let all_dep_names =
- if extra_doc then
- let extra = get_extra_doc_deps opam in
- let extra = OpamPackage.Name.Set.filter (fun n ->
- not (Day11_solution.Tool_names.is_tool_only n)) extra in
- let extra_in_solution =
- OpamPackage.Name.Set.inter extra solved_names in
- OpamPackage.Name.Set.union all_dep_names extra_in_solution
- else
- all_dep_names
+ let all_dep_names =
+ if extra_doc then
+ let extra = get_extra_doc_deps opam in
+ let extra =
+ OpamPackage.Name.Set.filter
+ (fun n ->
+ not (Day11_solution.Tool_names.is_tool_only n))
+ extra
+ in
+ let extra_in_solution =
+ OpamPackage.Name.Set.inter extra solved_names
+ in
+ OpamPackage.Name.Set.union all_dep_names extra_in_solution
+ else all_dep_names
+ in
+ let dep_pkgs =
+ List.filter
+ (fun p ->
+ OpamPackage.Name.Set.mem (OpamPackage.name p)
+ all_dep_names)
+ solved_pkgs
+ |> OpamPackage.Set.of_list
+ in
+ OpamPackage.Map.add pkg dep_pkgs acc)
+ OpamPackage.Map.empty solved_pkgs
in
- let dep_pkgs =
- List.filter (fun p ->
- OpamPackage.Name.Set.mem (OpamPackage.name p) all_dep_names)
- solved_pkgs
- |> OpamPackage.Set.of_list
+ let build_deps =
+ compute_deps ~doc:false ~post:false ~extra_doc:false
in
- OpamPackage.Map.add pkg dep_pkgs acc
- ) OpamPackage.Map.empty solved_pkgs
- in
- let build_deps = compute_deps ~doc:false ~post:false ~extra_doc:false in
- let doc_deps = compute_deps ~doc:true ~post:true ~extra_doc:true in
- let packages = OpamPackage.Set.of_list solved_pkgs in
- Ok ({ Day11_solution.Solve_result.packages; build_deps; doc_deps; examined },
- examined)
+ let doc_deps = compute_deps ~doc:true ~post:true ~extra_doc:true in
+ let packages = OpamPackage.Set.of_list solved_pkgs in
+ Ok
+ ( {
+ Day11_solution.Solve_result.packages;
+ build_deps;
+ doc_deps;
+ examined;
+ },
+ examined ))
let add_ocaml_constraint ?ocaml_version constraints =
match ocaml_version with
- | Some pkg ->
- let constraints =
- OpamPackage.Name.Map.add (OpamPackage.name pkg)
- (`Eq, OpamPackage.version pkg) constraints in
- (* Pin the [ocaml] virtual to the matching major.minor.patch
+ | Some pkg -> (
+ let constraints =
+ OpamPackage.Name.Map.add (OpamPackage.name pkg)
+ (`Eq, OpamPackage.version pkg)
+ constraints
+ in
+ (* Pin the [ocaml] virtual to the matching major.minor.patch
(stripping [+ox] / [~rc1] suffixes). Without this, a single-
target tool solve leaves [ocaml] free and opam picks the
highest-ranked match of [ocaml >= ...]. *)
- let ver_str = OpamPackage.Version.to_string (OpamPackage.version pkg) in
- let base_ver =
- let stop_at c = try String.index ver_str c
- with Not_found -> String.length ver_str in
- let cut = min (stop_at '+') (stop_at '~') in
- String.sub ver_str 0 cut in
- (try
- let v = OpamPackage.Version.of_string base_ver in
- OpamPackage.Name.Map.add
- (OpamPackage.Name.of_string "ocaml") (`Eq, v) constraints
- with _ -> constraints)
+ let ver_str = OpamPackage.Version.to_string (OpamPackage.version pkg) in
+ let base_ver =
+ let stop_at c =
+ try String.index ver_str c with Not_found -> String.length ver_str
+ in
+ let cut = min (stop_at '+') (stop_at '~') in
+ String.sub ver_str 0 cut
+ in
+ try
+ let v = OpamPackage.Version.of_string base_ver in
+ OpamPackage.Name.Map.add
+ (OpamPackage.Name.of_string "ocaml")
+ (`Eq, v) constraints
+ with _ -> constraints)
| None ->
- OpamPackage.Name.Map.add
- (OpamPackage.Name.of_string "ocaml-base-compiler")
- (`Geq, OpamPackage.Version.of_string "4.08.0")
- constraints
+ OpamPackage.Name.Map.add
+ (OpamPackage.Name.of_string "ocaml-base-compiler")
+ (`Geq, OpamPackage.Version.of_string "4.08.0")
+ constraints
-let solve ~packages ~env ?constraints ?pins ?prefer_oldest
- ?(doc = true) ?(extra_targets = []) ?(pin_target = true)
- ?ocaml_version target =
- let constraints = add_ocaml_constraint ?ocaml_version
- (Option.value ~default:OpamPackage.Name.Map.empty constraints) in
- match solve_internal ~packages ~env ~constraints ?pins
- ?prefer_oldest ~doc ~extra_targets ~pin_target target with
+let solve ~packages ~env ?constraints ?pins ?prefer_oldest ?(doc = true)
+ ?(extra_targets = []) ?(pin_target = true) ?ocaml_version target =
+ let constraints =
+ add_ocaml_constraint ?ocaml_version
+ (Option.value ~default:OpamPackage.Name.Map.empty constraints)
+ in
+ match
+ solve_internal ~packages ~env ~constraints ?pins ?prefer_oldest ~doc
+ ~extra_targets ~pin_target target
+ with
| Ok (result, _examined) -> Ok result
| Error (msg, examined) -> Error (msg, examined)
File "day11/solver/solve.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/solve.mli b/_build/default/day11/solver/.formatted/solve.mli
index 64cf600..f5017bb 100644
--- a/_build/default/day11/solver/solve.mli
+++ b/_build/default/day11/solver/.formatted/solve.mli
@@ -1,10 +1,10 @@
(** Dependency solving.
- The main entry point for resolving package dependencies using
- opam-0install. Takes a target package and an opam-repository,
- returns a {!Day11_solution.Solve_result.t} containing both the build
- dependency graph (acyclic, for build ordering) and the doc
- dependency graph (may have cycles, for odoc cross-referencing). *)
+ The main entry point for resolving package dependencies using opam-0install.
+ Takes a target package and an opam-repository, returns a
+ {!Day11_solution.Solve_result.t} containing both the build dependency graph
+ (acyclic, for build ordering) and the doc dependency graph (may have cycles,
+ for odoc cross-referencing). *)
val solve :
packages:Day11_opam.Git_packages.t ->
@@ -18,31 +18,29 @@ val solve :
?ocaml_version:OpamPackage.t ->
OpamPackage.t ->
(Day11_solution.Solve_result.t, string * OpamPackage.Name.Set.t) result
-(** [solve ~packages ~env ?pins ?pin_target ?doc ?ocaml_version target]
- solves the dependencies for [target].
+(** [solve ~packages ~env ?pins ?pin_target ?doc ?ocaml_version target] solves
+ the dependencies for [target].
- Returns a {!Day11_solution.Solve_result.t} with both [build_deps]
- (for topological build ordering) and [doc_deps] (for odoc
- cross-referencing, including [{post}] deps and per-package
- [x-extra-doc-deps]).
+ Returns a {!Day11_solution.Solve_result.t} with both [build_deps] (for
+ topological build ordering) and [doc_deps] (for odoc cross-referencing,
+ including [{post}] deps and per-package [x-extra-doc-deps]).
- The error case includes the [examined] set so incremental solvers
- can cache failures too.
+ The error case includes the [examined] set so incremental solvers can cache
+ failures too.
When [doc] is true (default), [{with-doc}] dependencies and
- [x-extra-doc-deps] are included in the solve and in [doc_deps].
- Set [~doc:false] for tool builds that don't need doc deps;
- in that case [doc_deps] equals [build_deps].
+ [x-extra-doc-deps] are included in the solve and in [doc_deps]. Set
+ [~doc:false] for tool builds that don't need doc deps; in that case
+ [doc_deps] equals [build_deps].
- When [ocaml_version] is provided, the compiler is pinned to that
- version. Otherwise defaults to [>= 4.08].
+ When [ocaml_version] is provided, the compiler is pinned to that version.
+ Otherwise defaults to [>= 4.08].
- When [pin_target] is [true] (default), an [=] constraint is added
- on the target's exact version — used for {e all-versions}
- universe modes where each (name, version) pair is solved
- independently. When [false], the target's version is treated as a
- hint only and the solver picks any version that fits. Use this
- for {e latest-version} profile mode: the input may be the latest
- in the repo, but if the rest of the universe forces a different
- version (e.g. an oxcaml [+ox] variant), the solver lands there
- instead of failing. *)
+ When [pin_target] is [true] (default), an [=] constraint is added on the
+ target's exact version — used for {e all-versions} universe modes where each
+ (name, version) pair is solved independently. When [false], the target's
+ version is treated as a hint only and the solver picks any version that
+ fits. Use this for {e latest-version} profile mode: the input may be the
+ latest in the repo, but if the rest of the universe forces a different
+ version (e.g. an oxcaml [+ox] variant), the solver lands there instead of
+ failing. *)
File "day11/solver/solver_worker.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/solver_worker.ml b/_build/default/day11/solver/.formatted/solver_worker.ml
index 61cc5bb..58cf742 100644
--- a/_build/default/day11/solver/solver_worker.ml
+++ b/_build/default/day11/solver/.formatted/solver_worker.ml
@@ -13,7 +13,7 @@ open Cmdliner
let repo_conv =
let parse s =
match String.split_on_char ':' s with
- | [path] -> Ok (path, None)
+ | [ path ] -> Ok (path, None)
| path :: rest -> Ok (path, Some (String.concat ":" rest))
| [] -> Error (`Msg "empty repo spec")
in
@@ -25,8 +25,12 @@ let repo_conv =
Arg.conv (parse, pp)
let repo_term =
- let doc = "opam-repository path with optional commit SHA (repeatable, layered in order)" in
- Arg.(non_empty & opt_all repo_conv [] & info [ "repo" ] ~docv:"PATH[:SHA]" ~doc)
+ let doc =
+ "opam-repository path with optional commit SHA (repeatable, layered in \
+ order)"
+ in
+ Arg.(
+ non_empty & opt_all repo_conv [] & info [ "repo" ] ~docv:"PATH[:SHA]" ~doc)
let output_term =
let doc = "Output file (one JSON per line); defaults to stdout" in
@@ -34,7 +38,8 @@ let output_term =
let ocaml_version_term =
let doc = "Compiler version (e.g. ocaml-base-compiler.5.2.1)" in
- Arg.(value & opt (some string) None & info [ "ocaml-version" ] ~docv:"PKG" ~doc)
+ Arg.(
+ value & opt (some string) None & info [ "ocaml-version" ] ~docv:"PKG" ~doc)
let pin_dir_term =
let doc = "Directory of .opam files to pin at version dev (repeatable)" in
@@ -42,26 +47,31 @@ let pin_dir_term =
let constraint_term =
let doc = "Pin package at exact version, e.g. NAME.VERSION (repeatable)" in
- Arg.(value & opt_all string [] & info [ "constraint" ] ~docv:"NAME.VERSION" ~doc)
+ Arg.(
+ value & opt_all string [] & info [ "constraint" ] ~docv:"NAME.VERSION" ~doc)
let extra_target_term =
- let doc = "Additional root at exact version, e.g. NAME.VERSION. \
- Like --constraint, but also adds to the solve roots so the \
- solver must install it (not just constrain its version if \
- it ends up in the solution). Repeatable." in
- Arg.(value & opt_all string [] & info
- [ "extra-target" ] ~docv:"NAME.VERSION" ~doc)
+ let doc =
+ "Additional root at exact version, e.g. NAME.VERSION. Like --constraint, \
+ but also adds to the solve roots so the solver must install it (not just \
+ constrain its version if it ends up in the solution). Repeatable."
+ in
+ Arg.(
+ value
+ & opt_all string []
+ & info [ "extra-target" ] ~docv:"NAME.VERSION" ~doc)
let no_doc_term =
let doc = "Disable doc dependencies" in
Arg.(value & flag & info [ "no-doc" ] ~doc)
let no_pin_target_term =
- let doc = "Don't pin each target to its given version. Use \
- when the target version on the command line is just a \
- hint and the solver should be free to pick another \
- version (e.g. an oxcaml [+ox] variant) when the rest \
- of the universe doesn't fit the nominal version." in
+ let doc =
+ "Don't pin each target to its given version. Use when the target version \
+ on the command line is just a hint and the solver should be free to pick \
+ another version (e.g. an oxcaml [+ox] variant) when the rest of the \
+ universe doesn't fit the nominal version."
+ in
Arg.(value & flag & info [ "no-pin-target" ] ~doc)
let arch_term =
@@ -74,7 +84,8 @@ let os_term =
let os_distribution_term =
let doc = "Distribution (default debian)" in
- Arg.(value & opt string "debian" & info [ "os-distribution" ] ~docv:"DIST" ~doc)
+ Arg.(
+ value & opt string "debian" & info [ "os-distribution" ] ~docv:"DIST" ~doc)
let os_family_term =
let doc = "OS family (default debian)" in
@@ -89,87 +100,114 @@ let targets_term =
Arg.(non_empty & pos_all string [] & info [] ~docv:"PKG" ~doc)
let read_pins_from_dir dir =
- let opam_files = Sys.readdir dir |> Array.to_list
- |> List.filter (fun f -> Filename.check_suffix f ".opam") in
- List.fold_left (fun acc filename ->
- let name = Filename.chop_suffix filename ".opam" in
- let path = Filename.concat dir filename in
- try
- let opam = OpamFile.OPAM.read
- (OpamFile.make (OpamFilename.raw path)) in
- OpamPackage.Name.Map.add
- (OpamPackage.Name.of_string name)
- (OpamPackage.Version.of_string "dev", opam) acc
- with _ -> acc
- ) OpamPackage.Name.Map.empty opam_files
+ let opam_files =
+ Sys.readdir dir
+ |> Array.to_list
+ |> List.filter (fun f -> Filename.check_suffix f ".opam")
+ in
+ List.fold_left
+ (fun acc filename ->
+ let name = Filename.chop_suffix filename ".opam" in
+ let path = Filename.concat dir filename in
+ try
+ let opam = OpamFile.OPAM.read (OpamFile.make (OpamFilename.raw path)) in
+ OpamPackage.Name.Map.add
+ (OpamPackage.Name.of_string name)
+ (OpamPackage.Version.of_string "dev", opam)
+ acc
+ with _ -> acc)
+ OpamPackage.Name.Map.empty opam_files
let parse_constraints constraint_strs =
- List.fold_left (fun acc s ->
- let pkg = OpamPackage.of_string s in
- OpamPackage.Name.Map.add (OpamPackage.name pkg)
- (`Eq, OpamPackage.version pkg) acc
- ) OpamPackage.Name.Map.empty constraint_strs
+ List.fold_left
+ (fun acc s ->
+ let pkg = OpamPackage.of_string s in
+ OpamPackage.Name.Map.add (OpamPackage.name pkg)
+ (`Eq, OpamPackage.version pkg)
+ acc)
+ OpamPackage.Name.Map.empty constraint_strs
let examined_to_json examined =
- `List (OpamPackage.Name.Set.fold (fun n acc ->
- `String (OpamPackage.Name.to_string n) :: acc) examined [])
-
-let solve_one ~packages ~env ~pins ~constraints ~extra_targets ~doc
- ~pin_target ?ocaml_version pkg =
- match Day11_solver.Solve.solve ~packages ~env
- ~pins ~constraints ~extra_targets ~doc ~pin_target
- ?ocaml_version pkg with
+ `List
+ (OpamPackage.Name.Set.fold
+ (fun n acc -> `String (OpamPackage.Name.to_string n) :: acc)
+ examined [])
+
+let solve_one ~packages ~env ~pins ~constraints ~extra_targets ~doc ~pin_target
+ ?ocaml_version pkg =
+ match
+ Day11_solver.Solve.solve ~packages ~env ~pins ~constraints ~extra_targets
+ ~doc ~pin_target ?ocaml_version pkg
+ with
| Ok result ->
- `Assoc [
- ("package", `String (OpamPackage.to_string pkg));
- ("result", Day11_solution.Solve_result.to_json result);
- ]
+ `Assoc
+ [
+ ("package", `String (OpamPackage.to_string pkg));
+ ("result", Day11_solution.Solve_result.to_json result);
+ ]
| Error (msg, examined) ->
- `Assoc [
- ("failed", `Bool true);
- ("package", `String (OpamPackage.to_string pkg));
- ("error", `String msg);
- ("examined", examined_to_json examined);
- ]
+ `Assoc
+ [
+ ("failed", `Bool true);
+ ("package", `String (OpamPackage.to_string pkg));
+ ("error", `String msg);
+ ("examined", examined_to_json examined);
+ ]
let run repo_list output ocaml_version pin_dirs constraint_strs
- extra_target_strs no_doc no_pin_target
- arch os os_distribution os_family os_version targets =
+ extra_target_strs no_doc no_pin_target arch os os_distribution os_family
+ os_version targets =
let packages, _repos_with_shas =
- Day11_opam.Git_packages.of_repositories repo_list in
- let env = Day11_opam.Opam_env.std_env
- ~arch ~os ~os_distribution ~os_family ~os_version () in
- let oc = match output with
- | None -> stdout
- | Some path -> open_out path in
- let ocaml_version =
- Option.map OpamPackage.of_string ocaml_version in
- let pins = List.fold_left (fun acc dir ->
- OpamPackage.Name.Map.union (fun _a b -> b) acc
- (read_pins_from_dir dir)
- ) OpamPackage.Name.Map.empty pin_dirs in
+ Day11_opam.Git_packages.of_repositories repo_list
+ in
+ let env =
+ Day11_opam.Opam_env.std_env ~arch ~os ~os_distribution ~os_family
+ ~os_version ()
+ in
+ let oc = match output with None -> stdout | Some path -> open_out path in
+ let ocaml_version = Option.map OpamPackage.of_string ocaml_version in
+ let pins =
+ List.fold_left
+ (fun acc dir ->
+ OpamPackage.Name.Map.union (fun _a b -> b) acc (read_pins_from_dir dir))
+ OpamPackage.Name.Map.empty pin_dirs
+ in
let constraints = parse_constraints constraint_strs in
let extra_targets = List.map OpamPackage.of_string extra_target_strs in
let doc = not no_doc in
let pin_target = not no_pin_target in
- List.iter (fun target_str ->
- let pkg = OpamPackage.of_string target_str in
- let json = solve_one ~packages ~env ~pins ~constraints ~extra_targets
- ~doc ~pin_target ?ocaml_version pkg in
- output_string oc (Yojson.Safe.to_string json);
- output_char oc '\n';
- flush oc
- ) targets;
+ List.iter
+ (fun target_str ->
+ let pkg = OpamPackage.of_string target_str in
+ let json =
+ solve_one ~packages ~env ~pins ~constraints ~extra_targets ~doc
+ ~pin_target ?ocaml_version pkg
+ in
+ output_string oc (Yojson.Safe.to_string json);
+ output_char oc '\n';
+ flush oc)
+ targets;
if output <> None then close_out oc
let cmd =
let doc = "Solve packages and write solutions as JSON lines" in
let info = Cmd.info "solver_worker" ~doc in
Cmd.v info
- Term.(const run $ repo_term $ output_term $ ocaml_version_term
- $ pin_dir_term $ constraint_term $ extra_target_term $ no_doc_term
- $ no_pin_target_term
- $ arch_term $ os_term $ os_distribution_term $ os_family_term
- $ os_version_term $ targets_term)
+ Term.(
+ const run
+ $ repo_term
+ $ output_term
+ $ ocaml_version_term
+ $ pin_dir_term
+ $ constraint_term
+ $ extra_target_term
+ $ no_doc_term
+ $ no_pin_target_term
+ $ arch_term
+ $ os_term
+ $ os_distribution_term
+ $ os_family_term
+ $ os_version_term
+ $ targets_term)
let () = exit (Cmd.eval cmd)
File "day11/batch/test/test_batch.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/test/test_batch.ml b/_build/default/day11/batch/test/.formatted/test_batch.ml
index af11040..0eb0b50 100644
--- a/_build/default/day11/batch/test/test_batch.ml
+++ b/_build/default/day11/batch/test/.formatted/test_batch.ml
@@ -13,17 +13,17 @@ let test_blessing_single_universe () =
let solution =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "c.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "b.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "b.1") (OpamPackage.Set.singleton (pkg "c.1"))
in
- let blessings = Blessing.compute_blessings
- [ (pkg "b.1", solution) ] in
+ let blessings = Blessing.compute_blessings [ (pkg "b.1", solution) ] in
match blessings with
| [ (_, map) ] ->
- Alcotest.(check bool) "b blessed"
- true (Blessing.is_blessed map (pkg "b.1"));
- Alcotest.(check bool) "c blessed"
- true (Blessing.is_blessed map (pkg "c.1"))
+ Alcotest.(check bool)
+ "b blessed" true
+ (Blessing.is_blessed map (pkg "b.1"));
+ Alcotest.(check bool)
+ "c blessed" true
+ (Blessing.is_blessed map (pkg "c.1"))
| _ -> Alcotest.fail "expected 1 blessing map"
let test_blessing_two_universes () =
@@ -32,8 +32,7 @@ let test_blessing_two_universes () =
let sol1 =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "c.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "a.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "a.1") (OpamPackage.Set.singleton (pkg "c.1"))
in
let sol2 =
OpamPackage.Map.empty
@@ -42,13 +41,15 @@ let test_blessing_two_universes () =
|> OpamPackage.Map.add (pkg "b.1")
(OpamPackage.Set.of_list [ pkg "c.1"; pkg "d.1" ])
in
- let blessings = Blessing.compute_blessings
- [ (pkg "a.1", sol1); (pkg "b.1", sol2) ] in
+ let blessings =
+ Blessing.compute_blessings [ (pkg "a.1", sol1); (pkg "b.1", sol2) ]
+ in
Alcotest.(check int) "2 maps" 2 (List.length blessings);
(* c.1 should be blessed in sol2 (richer: 3 packages vs 2) *)
let _, map2 = List.nth blessings 1 in
- Alcotest.(check bool) "c blessed in richer"
- true (Blessing.is_blessed map2 (pkg "c.1"))
+ Alcotest.(check bool)
+ "c blessed in richer" true
+ (Blessing.is_blessed map2 (pkg "c.1"))
let test_blessing_empty () =
let blessings = Blessing.compute_blessings [] in
@@ -59,66 +60,97 @@ let test_blessing_compiler_tiebreaker () =
Should prefer the newer compiler. *)
let sol_old =
OpamPackage.Map.empty
- |> OpamPackage.Map.add (pkg "ocaml-base-compiler.4.14.0")
+ |> OpamPackage.Map.add
+ (pkg "ocaml-base-compiler.4.14.0")
OpamPackage.Set.empty
|> OpamPackage.Map.add (pkg "c.1")
(OpamPackage.Set.singleton (pkg "ocaml-base-compiler.4.14.0"))
in
let sol_new =
OpamPackage.Map.empty
- |> OpamPackage.Map.add (pkg "ocaml-base-compiler.5.4.1")
+ |> OpamPackage.Map.add
+ (pkg "ocaml-base-compiler.5.4.1")
OpamPackage.Set.empty
|> OpamPackage.Map.add (pkg "c.1")
(OpamPackage.Set.singleton (pkg "ocaml-base-compiler.5.4.1"))
in
- let blessings = Blessing.compute_blessings
- [ (pkg "a.1", sol_old); (pkg "b.1", sol_new) ] in
+ let blessings =
+ Blessing.compute_blessings [ (pkg "a.1", sol_old); (pkg "b.1", sol_new) ]
+ in
(* c.1 has 1 dep in both — tiebreaker should pick 5.4.1 *)
let _, map_new = List.nth blessings 1 in
- Alcotest.(check bool) "c blessed in newer compiler solution"
- true (Blessing.is_blessed map_new (pkg "c.1"))
+ Alcotest.(check bool)
+ "c blessed in newer compiler solution" true
+ (Blessing.is_blessed map_new (pkg "c.1"))
let test_blessed_universes () =
let sol =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "c.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "b.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "b.1") (OpamPackage.Set.singleton (pkg "c.1"))
in
- let blessed = Blessing.compute_blessed_universes
- [ (pkg "b.1", sol) ] in
+ let blessed = Blessing.compute_blessed_universes [ (pkg "b.1", sol) ] in
(* Both packages should have blessed universes *)
- Alcotest.(check bool) "b has blessed universe"
- true (Hashtbl.mem blessed (pkg "b.1"));
- Alcotest.(check bool) "c has blessed universe"
- true (Hashtbl.mem blessed (pkg "c.1"))
+ Alcotest.(check bool)
+ "b has blessed universe" true
+ (Hashtbl.mem blessed (pkg "b.1"));
+ Alcotest.(check bool)
+ "c has blessed universe" true
+ (Hashtbl.mem blessed (pkg "c.1"))
(* ── Dag_executor tests ──────────────────────────────────────────── *)
-let test_dag_executor_basic () = with_eio @@ fun ~sw:_ env ->
+let test_dag_executor_basic () =
+ with_eio @@ fun ~sw:_ env ->
let completed = ref [] in
let node_c : Day11_opam_layer.Build.t =
- { hash = "build-c"; pkg = pkg "c.1"; deps = []; universe = Day11_solution.Universe.dummy } in
+ {
+ hash = "build-c";
+ pkg = pkg "c.1";
+ deps = [];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
let node_b : Day11_opam_layer.Build.t =
- { hash = "build-b"; pkg = pkg "b.1"; deps = [node_c]; universe = Day11_solution.Universe.dummy } in
+ {
+ hash = "build-b";
+ pkg = pkg "b.1";
+ deps = [ node_c ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
let nodes = [ node_c; node_b ] in
Dag_executor.execute env ~np:2
~on_complete:(fun ~stats:_ ~cached:_ node success ->
completed := (OpamPackage.to_string node.pkg, success) :: !completed)
~on_cascade:(fun ~failed:_ ~failed_dep:_ -> ())
nodes
- (fun _node -> true); (* all succeed *)
+ (fun _node -> true);
+ (* all succeed *)
let completed = List.rev !completed in
Alcotest.(check int) "2 completed" 2 (List.length completed);
(* c must complete before b *)
Alcotest.(check string) "first" "c.1" (fst (List.hd completed))
-let test_dag_executor_failure_cascade () = with_eio @@ fun ~sw:_ env ->
+let test_dag_executor_failure_cascade () =
+ with_eio @@ fun ~sw:_ env ->
let cascaded = ref [] in
let node_c : Day11_opam_layer.Build.t =
- { hash = "build-c"; pkg = pkg "c.1"; deps = []; universe = Day11_solution.Universe.dummy } in
+ {
+ hash = "build-c";
+ pkg = pkg "c.1";
+ deps = [];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
let node_b : Day11_opam_layer.Build.t =
- { hash = "build-b"; pkg = pkg "b.1"; deps = [node_c]; universe = Day11_solution.Universe.dummy } in
+ {
+ hash = "build-b";
+ pkg = pkg "b.1";
+ deps = [ node_c ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
let nodes = [ node_c; node_b ] in
Dag_executor.execute env ~np:2
~on_complete:(fun ~stats:_ ~cached:_ _node _success -> ())
@@ -140,55 +172,69 @@ let test_save_load_solution () =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "ocaml.5.2.0") OpamPackage.Set.empty
|> OpamPackage.Map.add (pkg "astring.0.8.5")
- (OpamPackage.Set.singleton (pkg "ocaml.5.2.0")) in
- let entry = Incremental_solver.Cached_solution {
- package = pkg "astring.0.8.5";
- result = { Day11_solution.Solve_result.
- packages = OpamPackage.Map.fold (fun p _ acc -> OpamPackage.Set.add p acc)
- solution OpamPackage.Set.empty;
- build_deps = solution;
- doc_deps = solution;
- examined =
- OpamPackage.Name.Set.of_list
- (List.map OpamPackage.Name.of_string [ "astring"; "ocaml"; "dune" ]);
- };
- cache_key = None;
- } in
+ (OpamPackage.Set.singleton (pkg "ocaml.5.2.0"))
+ in
+ let entry =
+ Incremental_solver.Cached_solution
+ {
+ package = pkg "astring.0.8.5";
+ result =
+ {
+ Day11_solution.Solve_result.packages =
+ OpamPackage.Map.fold
+ (fun p _ acc -> OpamPackage.Set.add p acc)
+ solution OpamPackage.Set.empty;
+ build_deps = solution;
+ doc_deps = solution;
+ examined =
+ OpamPackage.Name.Set.of_list
+ (List.map OpamPackage.Name.of_string
+ [ "astring"; "ocaml"; "dune" ]);
+ };
+ cache_key = None;
+ }
+ in
(match Incremental_solver.save path entry with
- | Ok () -> ()
- | Error (`Msg e) -> Alcotest.fail e);
+ | Ok () -> ()
+ | Error (`Msg e) -> Alcotest.fail e);
match Incremental_solver.load path with
| Error (`Msg e) -> Alcotest.fail e
| Ok (Cached_failure _) -> Alcotest.fail "expected solution"
| Ok (Cached_solution s) ->
- Alcotest.(check string) "package"
- "astring.0.8.5" (OpamPackage.to_string s.package);
- Alcotest.(check int) "solution size" 2
- (OpamPackage.Map.cardinal s.result.build_deps);
- Alcotest.(check int) "examined size" 3
- (OpamPackage.Name.Set.cardinal s.result.examined)
+ Alcotest.(check string)
+ "package" "astring.0.8.5"
+ (OpamPackage.to_string s.package);
+ Alcotest.(check int)
+ "solution size" 2
+ (OpamPackage.Map.cardinal s.result.build_deps);
+ Alcotest.(check int)
+ "examined size" 3
+ (OpamPackage.Name.Set.cardinal s.result.examined)
let test_save_load_failure () =
with_tmp_dir @@ fun dir ->
let path = Fpath.(dir / "bad.json") in
- let entry = Incremental_solver.Cached_failure {
- package = pkg "broken.1.0";
- error = "no solution";
- examined =
- OpamPackage.Name.Set.singleton
- (OpamPackage.Name.of_string "broken");
- cache_key = None;
- } in
+ let entry =
+ Incremental_solver.Cached_failure
+ {
+ package = pkg "broken.1.0";
+ error = "no solution";
+ examined =
+ OpamPackage.Name.Set.singleton (OpamPackage.Name.of_string "broken");
+ cache_key = None;
+ }
+ in
(match Incremental_solver.save path entry with
- | Ok () -> ()
- | Error (`Msg e) -> Alcotest.fail e);
+ | Ok () -> ()
+ | Error (`Msg e) -> Alcotest.fail e);
match Incremental_solver.load path with
| Error (`Msg e) -> Alcotest.fail e
| Ok (Cached_solution _) -> Alcotest.fail "expected failure"
| Ok (Cached_failure f) ->
- Alcotest.(check string) "package"
- "broken.1.0" (OpamPackage.to_string f.package);
- Alcotest.(check string) "error" "no solution" f.error
+ Alcotest.(check string)
+ "package" "broken.1.0"
+ (OpamPackage.to_string f.package);
+ Alcotest.(check string) "error" "no solution" f.error
let test_reuse_no_overlap () =
(* Examined set {astring, ocaml} doesn't overlap changed {dune} → reuse *)
@@ -197,26 +243,39 @@ let test_reuse_no_overlap () =
let cur_dir = Fpath.(dir / "cur") in
ignore (Bos.OS.Dir.create prev_dir);
ignore (Bos.OS.Dir.create cur_dir);
- let solution = OpamPackage.Map.singleton (pkg "astring.0.8.5") OpamPackage.Set.empty in
- let entry = Incremental_solver.Cached_solution {
- package = pkg "astring.0.8.5";
- result = { Day11_solution.Solve_result.
- packages = OpamPackage.Set.singleton (pkg "astring.0.8.5");
- build_deps = solution;
- doc_deps = solution;
- examined =
- OpamPackage.Name.Set.of_list
- (List.map OpamPackage.Name.of_string [ "astring"; "ocaml" ]);
- };
- cache_key = None;
- } in
- (match Incremental_solver.save Fpath.(prev_dir / "astring.0.8.5.json") entry with
- | Ok () -> () | Error (`Msg e) -> Alcotest.fail e);
- let changed = OpamPackage.Name.Set.singleton
- (OpamPackage.Name.of_string "dune") in
- let reused = Incremental_solver.reuse_solutions
- ~solutions_cache_dir:cur_dir ~previous_dir:prev_dir
- ~changed_packages:changed ~packages:["astring.0.8.5"] in
+ let solution =
+ OpamPackage.Map.singleton (pkg "astring.0.8.5") OpamPackage.Set.empty
+ in
+ let entry =
+ Incremental_solver.Cached_solution
+ {
+ package = pkg "astring.0.8.5";
+ result =
+ {
+ Day11_solution.Solve_result.packages =
+ OpamPackage.Set.singleton (pkg "astring.0.8.5");
+ build_deps = solution;
+ doc_deps = solution;
+ examined =
+ OpamPackage.Name.Set.of_list
+ (List.map OpamPackage.Name.of_string [ "astring"; "ocaml" ]);
+ };
+ cache_key = None;
+ }
+ in
+ (match
+ Incremental_solver.save Fpath.(prev_dir / "astring.0.8.5.json") entry
+ with
+ | Ok () -> ()
+ | Error (`Msg e) -> Alcotest.fail e);
+ let changed =
+ OpamPackage.Name.Set.singleton (OpamPackage.Name.of_string "dune")
+ in
+ let reused =
+ Incremental_solver.reuse_solutions ~solutions_cache_dir:cur_dir
+ ~previous_dir:prev_dir ~changed_packages:changed
+ ~packages:[ "astring.0.8.5" ]
+ in
Alcotest.(check int) "1 reused" 1 reused;
(* Verify the file was hardlinked *)
match Incremental_solver.load Fpath.(cur_dir / "astring.0.8.5.json") with
@@ -230,26 +289,39 @@ let test_reuse_with_overlap () =
let cur_dir = Fpath.(dir / "cur") in
ignore (Bos.OS.Dir.create prev_dir);
ignore (Bos.OS.Dir.create cur_dir);
- let solution = OpamPackage.Map.singleton (pkg "astring.0.8.5") OpamPackage.Set.empty in
- let entry = Incremental_solver.Cached_solution {
- package = pkg "astring.0.8.5";
- result = { Day11_solution.Solve_result.
- packages = OpamPackage.Set.singleton (pkg "astring.0.8.5");
- build_deps = solution;
- doc_deps = solution;
- examined =
- OpamPackage.Name.Set.of_list
- (List.map OpamPackage.Name.of_string [ "astring"; "ocaml" ]);
- };
- cache_key = None;
- } in
- (match Incremental_solver.save Fpath.(prev_dir / "astring.0.8.5.json") entry with
- | Ok () -> () | Error (`Msg e) -> Alcotest.fail e);
- let changed = OpamPackage.Name.Set.singleton
- (OpamPackage.Name.of_string "ocaml") in
- let reused = Incremental_solver.reuse_solutions
- ~solutions_cache_dir:cur_dir ~previous_dir:prev_dir
- ~changed_packages:changed ~packages:["astring.0.8.5"] in
+ let solution =
+ OpamPackage.Map.singleton (pkg "astring.0.8.5") OpamPackage.Set.empty
+ in
+ let entry =
+ Incremental_solver.Cached_solution
+ {
+ package = pkg "astring.0.8.5";
+ result =
+ {
+ Day11_solution.Solve_result.packages =
+ OpamPackage.Set.singleton (pkg "astring.0.8.5");
+ build_deps = solution;
+ doc_deps = solution;
+ examined =
+ OpamPackage.Name.Set.of_list
+ (List.map OpamPackage.Name.of_string [ "astring"; "ocaml" ]);
+ };
+ cache_key = None;
+ }
+ in
+ (match
+ Incremental_solver.save Fpath.(prev_dir / "astring.0.8.5.json") entry
+ with
+ | Ok () -> ()
+ | Error (`Msg e) -> Alcotest.fail e);
+ let changed =
+ OpamPackage.Name.Set.singleton (OpamPackage.Name.of_string "ocaml")
+ in
+ let reused =
+ Incremental_solver.reuse_solutions ~solutions_cache_dir:cur_dir
+ ~previous_dir:prev_dir ~changed_packages:changed
+ ~packages:[ "astring.0.8.5" ]
+ in
Alcotest.(check int) "0 reused" 0 reused
let test_find_previous_sha_dir () =
@@ -261,9 +333,7 @@ let test_find_previous_sha_dir () =
ignore (Bos.OS.Dir.create sha2);
(* sha2 is newer — should be found when current is abc123 *)
match Incremental_solver.find_previous_sha_dir dir ~current_sha:"abc123" with
- | Some p ->
- Alcotest.(check string) "found def456"
- "def456" (Fpath.basename p)
+ | Some p -> Alcotest.(check string) "found def456" "def456" (Fpath.basename p)
| None -> Alcotest.fail "expected to find previous SHA dir"
let test_find_previous_sha_dir_none () =
@@ -285,19 +355,18 @@ let test_find_previous_sha_dir_none () =
(* ── Targets tests ──────────────────────────────────────────────── *)
let test_small_universe_nonempty () =
- Alcotest.(check bool) "non-empty" true
- (List.length Targets.small_universe > 0)
+ Alcotest.(check bool) "non-empty" true (List.length Targets.small_universe > 0)
let test_small_universe_has_odoc () =
- Alcotest.(check bool) "has odoc" true
- (List.mem "odoc" Targets.small_universe)
+ Alcotest.(check bool) "has odoc" true (List.mem "odoc" Targets.small_universe)
let test_resolve_single_target () =
(* resolve with an explicit target returns exactly that *)
let dummy_packages = Day11_opam.Git_packages.empty in
let result = Targets.resolve dummy_packages (Some "astring.0.8.5") in
Alcotest.(check int) "one target" 1 (List.length result);
- Alcotest.(check string) "correct" "astring.0.8.5"
+ Alcotest.(check string)
+ "correct" "astring.0.8.5"
(OpamPackage.to_string (List.hd result))
(* Summary.record_history goes through History.append, which uses an
@@ -311,13 +380,11 @@ let () =
[
Alcotest.test_case "single universe" `Quick
test_blessing_single_universe;
- Alcotest.test_case "two universes" `Quick
- test_blessing_two_universes;
+ Alcotest.test_case "two universes" `Quick test_blessing_two_universes;
Alcotest.test_case "empty" `Quick test_blessing_empty;
Alcotest.test_case "compiler tiebreaker" `Quick
test_blessing_compiler_tiebreaker;
- Alcotest.test_case "blessed universes" `Quick
- test_blessed_universes;
+ Alcotest.test_case "blessed universes" `Quick test_blessed_universes;
] );
( "Dag_executor",
[
@@ -327,14 +394,10 @@ let () =
] );
( "Incremental_solver",
[
- Alcotest.test_case "save/load solution" `Quick
- test_save_load_solution;
- Alcotest.test_case "save/load failure" `Quick
- test_save_load_failure;
- Alcotest.test_case "reuse no overlap" `Quick
- test_reuse_no_overlap;
- Alcotest.test_case "reuse with overlap" `Quick
- test_reuse_with_overlap;
+ Alcotest.test_case "save/load solution" `Quick test_save_load_solution;
+ Alcotest.test_case "save/load failure" `Quick test_save_load_failure;
+ Alcotest.test_case "reuse no overlap" `Quick test_reuse_no_overlap;
+ Alcotest.test_case "reuse with overlap" `Quick test_reuse_with_overlap;
Alcotest.test_case "find previous SHA dir" `Quick
test_find_previous_sha_dir;
Alcotest.test_case "find previous SHA dir none" `Quick
File "day11/batch/test/test_batch_integration.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/test/test_batch_integration.ml b/_build/default/day11/batch/test/.formatted/test_batch_integration.ml
index 0a5934f..b2c8046 100644
--- a/_build/default/day11/batch/test/test_batch_integration.ml
+++ b/_build/default/day11/batch/test/.formatted/test_batch_integration.ml
@@ -12,27 +12,31 @@ open Day11_test_util.Test_util
let arch = "x86_64"
let os_distribution = "debian"
-
let pkg s = OpamPackage.of_string s
let solve_package git_packages opam_env target_str =
let target = pkg target_str in
- match Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env target with
+ match
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env target
+ with
| Ok result -> (target, result.Day11_solution.Solve_result.build_deps)
| Error (diag, _) -> Alcotest.fail ("Solve " ^ target_str ^ ": " ^ diag)
let setup_solver () =
let opam_repository = opam_repository () in
let git_packages, store, commit =
- Day11_opam.Git_packages.of_opam_repository opam_repository in
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch ~os:"linux" ~os_distribution ~os_family:"debian"
- ~os_version:"12" () in
+ Day11_opam.Git_packages.of_opam_repository opam_repository
+ in
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch ~os:"linux" ~os_distribution
+ ~os_family:"debian" ~os_version:"12" ()
+ in
(git_packages, store, commit, opam_env)
(* ── Test 1: Solver → Graph → Blessing → Dag_executor (mock builds) ── *)
-let test_full_pipeline_mock () = with_eio @@ fun ~sw:_ env ->
+let test_full_pipeline_mock () =
+ with_eio @@ fun ~sw:_ env ->
Printf.printf "Setting up solver...\n%!";
let git_packages, _store, _commit, opam_env = setup_solver () in
(* Solve two small packages to exercise blessing *)
@@ -49,15 +53,17 @@ let test_full_pipeline_mock () = with_eio @@ fun ~sw:_ env ->
Alcotest.(check int) "2 blessing maps" 2 (List.length blessing_maps);
(* Check that shared packages are blessed somewhere *)
let all_blessed =
- List.fold_left (fun acc (_, map) ->
- OpamPackage.Map.fold (fun pkg b acc ->
- if b then OpamPackage.Set.add pkg acc else acc
- ) map acc
- ) OpamPackage.Set.empty blessing_maps
+ List.fold_left
+ (fun acc (_, map) ->
+ OpamPackage.Map.fold
+ (fun pkg b acc -> if b then OpamPackage.Set.add pkg acc else acc)
+ map acc)
+ OpamPackage.Set.empty blessing_maps
in
Printf.printf " Blessed: %d packages\n%!"
(OpamPackage.Set.cardinal all_blessed);
- Alcotest.(check bool) "some blessed" true
+ Alcotest.(check bool)
+ "some blessed" true
(OpamPackage.Set.cardinal all_blessed > 0);
(* Build DAG *)
let find_opam = Day11_opam.Git_packages.find_package git_packages in
@@ -65,7 +71,8 @@ let test_full_pipeline_mock () = with_eio @@ fun ~sw:_ env ->
let base_hash = Base.hash ~image:"test" in
let nodes =
Dag.build_dag cache ~base_hash
- (List.map (fun (t, d) -> (t, d, d)) solutions) in
+ (List.map (fun (t, d) -> (t, d, d)) solutions)
+ in
Printf.printf " DAG: %d nodes\n%!" (List.length nodes);
Alcotest.(check bool) "nodes > 0" true (List.length nodes > 0);
(* Execute with mock build — all succeed *)
@@ -77,18 +84,20 @@ let test_full_pipeline_mock () = with_eio @@ fun ~sw:_ env ->
nodes
(fun _node -> true);
let completed = List.rev !completed in
- Printf.printf " Completed: %d/%d\n%!"
- (List.length completed) (List.length nodes);
- Alcotest.(check int) "all completed"
- (List.length nodes) (List.length completed);
+ Printf.printf " Completed: %d/%d\n%!" (List.length completed)
+ (List.length nodes);
+ Alcotest.(check int)
+ "all completed" (List.length nodes) (List.length completed);
(* All should succeed *)
- List.iter (fun (name, success) ->
- Alcotest.(check bool) (name ^ " success") true success
- ) completed
+ List.iter
+ (fun (name, success) ->
+ Alcotest.(check bool) (name ^ " success") true success)
+ completed
(* ── Test 2: Full pipeline with Summary ──────────────────────────── *)
-let test_pipeline_with_summary () = with_eio @@ fun ~sw:_ env ->
+let test_pipeline_with_summary () =
+ with_eio @@ fun ~sw:_ env ->
with_tmp_dir @@ fun dir ->
let packages_dir = Fpath.(dir / "packages") in
mkdir packages_dir;
@@ -104,51 +113,61 @@ let test_pipeline_with_summary () = with_eio @@ fun ~sw:_ env ->
let base_hash = Base.hash ~image:"test" in
let nodes =
Dag.build_dag cache ~base_hash
- (List.map (fun (t, d) -> (t, d, d)) solutions) in
+ (List.map (fun (t, d) -> (t, d, d)) solutions)
+ in
Printf.printf " DAG: %d nodes, executing...\n%!" (List.length nodes);
(* Build mock outcomes for summary *)
let build_outcomes = ref [] in
Dag_executor.execute env ~np:4
~on_complete:(fun ~stats:_ ~cached:_ node success ->
let blessed =
- List.exists (fun (_, map) ->
- Blessing.is_blessed map node.pkg
- ) blessing_maps
+ List.exists
+ (fun (_, map) -> Blessing.is_blessed map node.pkg)
+ blessing_maps
in
build_outcomes :=
- { Summary.pkg = node.pkg;
+ {
+ Summary.pkg = node.pkg;
build_hash = node.hash;
- success; log_file = None; blessed }
+ success;
+ log_file = None;
+ blessed;
+ }
:: !build_outcomes)
~on_cascade:(fun ~failed:_ ~failed_dep:_ -> ())
nodes
(fun _node -> true);
- let results : Summary.results = {
- builds = List.rev !build_outcomes;
- docs = [];
- targets = [ fst sol_astring ];
- } in
+ let results : Summary.results =
+ {
+ builds = List.rev !build_outcomes;
+ docs = [];
+ targets = [ fst sol_astring ];
+ }
+ in
ignore results;
(* History recording moved into [Recorder.record_build] (incremental
per-outcome). This integration test no longer round-trips history
through [Summary]; the recorder unit tests cover that side. *)
Summary.generate_status ~snapshot_dir:os_dir ~packages_dir ~run_id:"test-int";
- let status = Day11_lib.Status_index.read
- ~dir:os_dir in
+ let status = Day11_lib.Status_index.read ~dir:os_dir in
Alcotest.(check bool) "status.json written" true (status <> None)
(* ── Test 3: Solver → Dag_executor with real container builds ──── *)
let scratch_cache_dir = Fpath.v "/tmp/day11-scratch-cache"
-let test_parallel_real_builds () = with_eio @@ fun ~sw env ->
+let test_parallel_real_builds () =
+ with_eio @@ fun ~sw env ->
(* Use from-scratch cache (Base.build, switch=default) *)
- let base = match Base.load_cached ~cache_dir:scratch_cache_dir
- ~os_distribution ~os_version:"bookworm" with
+ let base =
+ match
+ Base.load_cached ~cache_dir:scratch_cache_dir ~os_distribution
+ ~os_version:"bookworm"
+ with
| Some b -> b
| None ->
- Printf.printf "Skipping: no from-scratch cache\n%!";
- Alcotest.skip ()
+ Printf.printf "Skipping: no from-scratch cache\n%!";
+ Alcotest.skip ()
in
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
Printf.printf "Setting up solver and base image...\n%!";
@@ -159,8 +178,10 @@ let test_parallel_real_builds () = with_eio @@ fun ~sw env ->
let solutions = [ sol_astring ] in
let find_opam = Day11_opam.Git_packages.find_package git_packages in
let cache = Day11_opam_build.Hash_cache.create ~find_opam () in
- let nodes = Dag.build_dag cache ~base_hash:base.hash
- (List.map (fun (t, d) -> (t, d, d)) solutions) in
+ let nodes =
+ Dag.build_dag cache ~base_hash:base.hash
+ (List.map (fun (t, d) -> (t, d, d)) solutions)
+ in
Printf.printf " DAG: %d nodes\n%!" (List.length nodes);
let completed_pkgs = ref [] in
let failed_pkgs = ref [] in
@@ -173,10 +194,8 @@ let test_parallel_real_builds () = with_eio @@ fun ~sw env ->
stats.Day11_opam_build.Dag_executor.completed stats.total stats.failed
(OpamPackage.to_string node.pkg)
(if success then "OK" else "FAIL");
- if success then
- completed_pkgs := node.pkg :: !completed_pkgs
- else
- failed_pkgs := node.pkg :: !failed_pkgs)
+ if success then completed_pkgs := node.pkg :: !completed_pkgs
+ else failed_pkgs := node.pkg :: !failed_pkgs)
~on_cascade:(fun ~failed ~failed_dep:_ ->
Printf.printf " CASCADE: %s\n%!" failed.hash)
nodes
@@ -185,13 +204,15 @@ let test_parallel_real_builds () = with_eio @@ fun ~sw env ->
| Types.Success _bl -> true
| _ -> false);
Printf.printf "\n=== Results: %d succeeded, %d failed ===\n%!"
- (List.length !completed_pkgs) (List.length !failed_pkgs);
- Alcotest.(check bool) "some succeeded" true
- (List.length !completed_pkgs > 0);
+ (List.length !completed_pkgs)
+ (List.length !failed_pkgs);
+ Alcotest.(check bool) "some succeeded" true (List.length !completed_pkgs > 0);
(* astring itself should have succeeded *)
- Alcotest.(check bool) "astring built" true
- (List.exists (fun p ->
- OpamPackage.to_string p = "astring.0.8.5") !completed_pkgs)
+ Alcotest.(check bool)
+ "astring built" true
+ (List.exists
+ (fun p -> OpamPackage.to_string p = "astring.0.8.5")
+ !completed_pkgs)
(* ── Test 4: Incremental solver reuse ────────────────────────────── *)
@@ -208,40 +229,53 @@ let test_incremental_reuse () =
(* Solve a few packages and cache them *)
let targets = [ "astring.0.8.5"; "fmt.0.9.0" ] in
Printf.printf "Solving and caching %d packages...\n%!" (List.length targets);
- List.iter (fun target_str ->
- let target = pkg target_str in
- match Day11_solver.Solve.solve
- ~packages:git_packages ~env:opam_env target with
- | Ok result ->
- let entry = Incremental_solver.Cached_solution {
- package = target; result; cache_key = None;
- } in
- (match Incremental_solver.save
- Fpath.(sha1_dir / (target_str ^ ".json")) entry with
- | Ok () -> Printf.printf " Cached %s (examined %d)\n%!"
- target_str (OpamPackage.Name.Set.cardinal result.examined)
- | Error (`Msg e) -> Alcotest.fail e)
- | Error (diag, _examined) ->
- Alcotest.fail ("Solve " ^ target_str ^ ": " ^ diag)
- ) targets;
+ List.iter
+ (fun target_str ->
+ let target = pkg target_str in
+ match
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env target
+ with
+ | Ok result -> (
+ let entry =
+ Incremental_solver.Cached_solution
+ { package = target; result; cache_key = None }
+ in
+ match
+ Incremental_solver.save
+ Fpath.(sha1_dir / (target_str ^ ".json"))
+ entry
+ with
+ | Ok () ->
+ Printf.printf " Cached %s (examined %d)\n%!" target_str
+ (OpamPackage.Name.Set.cardinal result.examined)
+ | Error (`Msg e) -> Alcotest.fail e)
+ | Error (diag, _examined) ->
+ Alcotest.fail ("Solve " ^ target_str ^ ": " ^ diag))
+ targets;
(* Simulate a new SHA with no changes — all should be reused *)
let sha2_short = "fake-new-sha1" in
let sha2_dir = Fpath.(solutions_base / sha2_short) in
mkdir sha2_dir;
let changed_empty = OpamPackage.Name.Set.empty in
- let reused = Incremental_solver.reuse_solutions
- ~solutions_cache_dir:sha2_dir ~previous_dir:sha1_dir
- ~changed_packages:changed_empty ~packages:targets in
+ let reused =
+ Incremental_solver.reuse_solutions ~solutions_cache_dir:sha2_dir
+ ~previous_dir:sha1_dir ~changed_packages:changed_empty ~packages:targets
+ in
Printf.printf " Reused (no changes): %d/%d\n%!" reused (List.length targets);
Alcotest.(check int) "all reused" (List.length targets) reused;
(* Verify reused solutions load correctly *)
- List.iter (fun target_str ->
- match Incremental_solver.load Fpath.(sha2_dir / (target_str ^ ".json")) with
- | Ok (Cached_solution s) ->
- Alcotest.(check string) (target_str ^ " roundtrip")
- target_str (OpamPackage.to_string s.package)
- | _ -> Alcotest.fail ("Failed to load reused " ^ target_str)
- ) targets;
+ List.iter
+ (fun target_str ->
+ match
+ Incremental_solver.load Fpath.(sha2_dir / (target_str ^ ".json"))
+ with
+ | Ok (Cached_solution s) ->
+ Alcotest.(check string)
+ (target_str ^ " roundtrip")
+ target_str
+ (OpamPackage.to_string s.package)
+ | _ -> Alcotest.fail ("Failed to load reused " ^ target_str))
+ targets;
(* Now simulate changes to a package that astring examines *)
let sha3_short = "fake-changed1" in
let sha3_dir = Fpath.(solutions_base / sha3_short) in
@@ -253,33 +287,37 @@ let test_incremental_reuse () =
| _ -> Alcotest.fail "load astring"
in
let examined_name =
- OpamPackage.Name.Set.choose astring_entry.result.examined in
+ OpamPackage.Name.Set.choose astring_entry.result.examined
+ in
Printf.printf " Simulating change to %s...\n%!"
(OpamPackage.Name.to_string examined_name);
let changed_one = OpamPackage.Name.Set.singleton examined_name in
- let reused2 = Incremental_solver.reuse_solutions
- ~solutions_cache_dir:sha3_dir ~previous_dir:sha1_dir
- ~changed_packages:changed_one ~packages:targets in
+ let reused2 =
+ Incremental_solver.reuse_solutions ~solutions_cache_dir:sha3_dir
+ ~previous_dir:sha1_dir ~changed_packages:changed_one ~packages:targets
+ in
Printf.printf " Reused (1 change): %d/%d\n%!" reused2 (List.length targets);
(* astring should NOT be reused since its examined set overlaps *)
- Alcotest.(check bool) "not all reused" true
- (reused2 < List.length targets);
+ Alcotest.(check bool) "not all reused" true (reused2 < List.length targets);
(* Test diff_packages between HEAD~1 and HEAD *)
Printf.printf " Testing diff_packages...\n%!";
- (try
+ try
let opam_repository = opam_repository () in
- let parent_sha = String.trim (
- Unix.open_process_in
- (Printf.sprintf "git -C %s rev-parse HEAD~1" opam_repository)
- |> In_channel.input_all) in
+ let parent_sha =
+ String.trim
+ (Unix.open_process_in
+ (Printf.sprintf "git -C %s rev-parse HEAD~1" opam_repository)
+ |> In_channel.input_all)
+ in
let parent =
- Day11_opam.Git_utils.resolve_commit_in_store store (Some parent_sha) in
- let changed_real = Day11_opam.Git_packages.diff_packages
- ~store parent commit in
+ Day11_opam.Git_utils.resolve_commit_in_store store (Some parent_sha)
+ in
+ let changed_real =
+ Day11_opam.Git_packages.diff_packages ~store parent commit
+ in
Printf.printf " Real changes (HEAD~1..HEAD): %d packages\n%!"
(List.length changed_real)
- with _ ->
- Printf.printf " (skipped: could not get parent)\n%!")
+ with _ -> Printf.printf " (skipped: could not get parent)\n%!"
(* ── Test registration ───────────────────────────────────────────── *)
@@ -288,15 +326,21 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_batch_integration"
- [ ( "Pure pipeline",
- [ Alcotest.test_case "solver→blessing→dag (mock)" `Slow
+ [
+ ( "Pure pipeline",
+ [
+ Alcotest.test_case "solver→blessing→dag (mock)" `Slow
test_full_pipeline_mock;
Alcotest.test_case "pipeline with summary" `Slow
- test_pipeline_with_summary ] );
+ test_pipeline_with_summary;
+ ] );
( "Container pipeline",
- [ Alcotest.test_case "parallel real builds" `Slow
- test_parallel_real_builds ] );
+ [
+ Alcotest.test_case "parallel real builds" `Slow
+ test_parallel_real_builds;
+ ] );
( "Incremental solver",
- [ Alcotest.test_case "reuse across SHAs" `Slow
- test_incremental_reuse ] );
+ [
+ Alcotest.test_case "reuse across SHAs" `Slow test_incremental_reuse;
+ ] );
]
File "day11/batch/test/test_cmdliner_all.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/test/test_cmdliner_all.ml b/_build/default/day11/batch/test/.formatted/test_cmdliner_all.ml
index e07666b..0aa4baa 100644
--- a/_build/default/day11/batch/test/test_cmdliner_all.ml
+++ b/_build/default/day11/batch/test/.formatted/test_cmdliner_all.ml
@@ -9,13 +9,17 @@ open Day11_test_util.Test_util
let scratch_cache_dir = Fpath.v "/tmp/day11-scratch-cache"
-let test_all_cmdliner () = with_eio @@ fun ~sw env ->
- let base = match Base.load_cached ~cache_dir:scratch_cache_dir
- ~os_distribution:"debian" ~os_version:"bookworm" with
+let test_all_cmdliner () =
+ with_eio @@ fun ~sw env ->
+ let base =
+ match
+ Base.load_cached ~cache_dir:scratch_cache_dir ~os_distribution:"debian"
+ ~os_version:"bookworm"
+ with
| Some b -> b
| None ->
- Printf.printf "No from-scratch cache — skipping\n%!";
- Alcotest.skip ()
+ Printf.printf "No from-scratch cache — skipping\n%!";
+ Alcotest.skip ()
in
let opam_repository = opam_repository () in
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
@@ -23,49 +27,59 @@ let test_all_cmdliner () = with_eio @@ fun ~sw env ->
Types.ensure_dirs benv;
Printf.printf "Setting up solver...\n%!";
let git_packages, _store, _commit =
- Day11_opam.Git_packages.of_opam_repository opam_repository in
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
+ Day11_opam.Git_packages.of_opam_repository opam_repository
+ in
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
(* Find all cmdliner versions *)
let cmdliner_versions =
Day11_opam.Git_packages.get_versions git_packages
- (OpamPackage.Name.of_string "cmdliner") in
+ (OpamPackage.Name.of_string "cmdliner")
+ in
let targets =
- OpamPackage.Version.Map.fold (fun v _ acc ->
- OpamPackage.create (OpamPackage.Name.of_string "cmdliner") v :: acc
- ) cmdliner_versions []
+ OpamPackage.Version.Map.fold
+ (fun v _ acc ->
+ OpamPackage.create (OpamPackage.Name.of_string "cmdliner") v :: acc)
+ cmdliner_versions []
|> List.rev
in
- Printf.printf "Found %d cmdliner versions: %s\n%!"
- (List.length targets)
+ Printf.printf "Found %d cmdliner versions: %s\n%!" (List.length targets)
(String.concat ", " (List.map OpamPackage.to_string targets));
(* Solve each version *)
- let solutions = List.filter_map (fun target ->
- Printf.printf " Solving %s... %!" (OpamPackage.to_string target);
- match Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- target with
- | Ok result ->
- Printf.printf "%d packages\n%!" (OpamPackage.Map.cardinal result.Day11_solution.Solve_result.build_deps);
- Some (target, result.build_deps)
- | Error (diag, _) ->
- Printf.printf "FAILED: %s\n%!" diag;
- None
- ) targets in
- Printf.printf "\n%d/%d versions solved\n%!"
- (List.length solutions) (List.length targets);
+ let solutions =
+ List.filter_map
+ (fun target ->
+ Printf.printf " Solving %s... %!" (OpamPackage.to_string target);
+ match
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env target
+ with
+ | Ok result ->
+ Printf.printf "%d packages\n%!"
+ (OpamPackage.Map.cardinal
+ result.Day11_solution.Solve_result.build_deps);
+ Some (target, result.build_deps)
+ | Error (diag, _) ->
+ Printf.printf "FAILED: %s\n%!" diag;
+ None)
+ targets
+ in
+ Printf.printf "\n%d/%d versions solved\n%!" (List.length solutions)
+ (List.length targets);
Alcotest.(check bool) "some solved" true (List.length solutions > 0);
(* Bless *)
let blessing_maps = Blessing.compute_blessings solutions in
let blessed_count =
- List.fold_left (fun acc (_, map) ->
- OpamPackage.Map.fold (fun _ b acc -> if b then acc + 1 else acc) map acc
- ) 0 blessing_maps
+ List.fold_left
+ (fun acc (_, map) ->
+ OpamPackage.Map.fold (fun _ b acc -> if b then acc + 1 else acc) map acc)
+ 0 blessing_maps
in
let total_instances =
- List.fold_left (fun acc (_, map) ->
- acc + OpamPackage.Map.cardinal map
- ) 0 blessing_maps
+ List.fold_left
+ (fun acc (_, map) -> acc + OpamPackage.Map.cardinal map)
+ 0 blessing_maps
in
Printf.printf "Blessed: %d/%d package instances across %d universes\n%!"
blessed_count total_instances (List.length solutions);
@@ -74,8 +88,10 @@ let test_all_cmdliner () = with_eio @@ fun ~sw env ->
let cache = Hash_cache.create ~find_opam () in
let nodes =
Dag.build_dag cache ~base_hash:base.hash
- (List.map (fun (t, d) -> (t, d, d)) solutions) in
- Printf.printf "DAG: %d unique build nodes (deduplicated from %d solutions)\n%!"
+ (List.map (fun (t, d) -> (t, d, d)) solutions)
+ in
+ Printf.printf
+ "DAG: %d unique build nodes (deduplicated from %d solutions)\n%!"
(List.length nodes) (List.length solutions);
(* Execute with real builds *)
let succeeded = Atomic.make 0 in
@@ -84,17 +100,12 @@ let test_all_cmdliner () = with_eio @@ fun ~sw env ->
let t0 = Unix.gettimeofday () in
Dag_executor.execute env ~np:4
~on_complete:(fun ~stats ~cached:_ node success ->
- if success then
- Atomic.incr succeeded
- else
- Atomic.incr failed;
+ if success then Atomic.incr succeeded else Atomic.incr failed;
if stats.Day11_opam_build.Dag_executor.completed mod 10 = 0 then
- Printf.printf " [%d/%d] %s: %s\n%!"
- stats.completed stats.total
+ Printf.printf " [%d/%d] %s: %s\n%!" stats.completed stats.total
(OpamPackage.to_string node.pkg)
(if success then "OK" else "FAIL"))
- ~on_cascade:(fun ~failed:_ ~failed_dep:_ ->
- Atomic.incr cascaded)
+ ~on_cascade:(fun ~failed:_ ~failed_dep:_ -> Atomic.incr cascaded)
nodes
(fun node ->
match Build_layer.build ~sw env benv ~opam_repositories:[] node () with
@@ -109,24 +120,28 @@ let test_all_cmdliner () = with_eio @@ fun ~sw env ->
Printf.printf " %d total nodes\n%!" (List.length nodes);
(* Check that cmdliner nodes exist in the DAG *)
let cmdliner_nodes =
- List.filter (fun (n : Day11_opam_layer.Build.t) ->
- String.equal "cmdliner"
- (OpamPackage.Name.to_string (OpamPackage.name n.pkg))
- ) nodes
+ List.filter
+ (fun (n : Day11_opam_layer.Build.t) ->
+ String.equal "cmdliner"
+ (OpamPackage.Name.to_string (OpamPackage.name n.pkg)))
+ nodes
in
Printf.printf " cmdliner versions in DAG: %s\n%!"
- (String.concat ", " (List.map (fun (n : Day11_opam_layer.Build.t) ->
- OpamPackage.to_string n.pkg) cmdliner_nodes));
- Alcotest.(check bool) "some cmdliner in DAG" true
+ (String.concat ", "
+ (List.map
+ (fun (n : Day11_opam_layer.Build.t) -> OpamPackage.to_string n.pkg)
+ cmdliner_nodes));
+ Alcotest.(check bool)
+ "some cmdliner in DAG" true
(List.length cmdliner_nodes > 0);
- Alcotest.(check bool) "majority succeeded" true
- (s > List.length nodes / 2)
+ Alcotest.(check bool) "majority succeeded" true (s > List.length nodes / 2)
let () =
if not (is_integration ()) then
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_cmdliner_all"
- [ ( "Cmdliner",
- [ Alcotest.test_case "build all versions" `Slow
- test_all_cmdliner ] ) ]
+ [
+ ( "Cmdliner",
+ [ Alcotest.test_case "build all versions" `Slow test_all_cmdliner ] );
+ ]
File "day11/batch/test/test_examined_diff.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/test/test_examined_diff.ml b/_build/default/day11/batch/test/.formatted/test_examined_diff.ml
index b077c47..2d21e5b 100644
--- a/_build/default/day11/batch/test/test_examined_diff.ml
+++ b/_build/default/day11/batch/test/.formatted/test_examined_diff.ml
@@ -6,68 +6,83 @@ let opam_repository =
Sys.getenv_opt "OPAM_REPOSITORY"
|> Option.value ~default:"/home/jjl25/opam-repository"
-let targets = [
- "cohttp-lwt.6.2.1";
- "dream.1.0.0~alpha8";
- "cohttp-async.6.2.1";
- "core.v0.17.1";
- "eio_main.1.2";
- "zarith.1.14";
- "cmdliner.1.3.0";
- "astring.0.8.5";
-]
+let targets =
+ [
+ "cohttp-lwt.6.2.1";
+ "dream.1.0.0~alpha8";
+ "cohttp-async.6.2.1";
+ "core.v0.17.1";
+ "eio_main.1.2";
+ "zarith.1.14";
+ "cmdliner.1.3.0";
+ "astring.0.8.5";
+ ]
-let opam_env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" ()
+let opam_env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
let () =
- if not (is_integration ()) then
- (Printf.printf "Skipping (set DAY11_INTEGRATION=true)\n"; exit 0);
+ if not (is_integration ()) then (
+ Printf.printf "Skipping (set DAY11_INTEGRATION=true)\n";
+ exit 0);
let git_packages, _, _ =
- Day11_opam.Git_packages.of_opam_repository opam_repository in
+ Day11_opam.Git_packages.of_opam_repository opam_repository
+ in
(* Solve each target and collect examined sets *)
- let examined_sets = List.filter_map (fun target_str ->
- let target = OpamPackage.of_string target_str in
- match Day11_solver.Solve.solve
- ~packages:git_packages ~env:opam_env target with
- | Ok result -> Some (target_str, result.Day11_solution.Solve_result.examined)
- | Error _ -> None
- ) targets in
+ let examined_sets =
+ List.filter_map
+ (fun target_str ->
+ let target = OpamPackage.of_string target_str in
+ match
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env target
+ with
+ | Ok result ->
+ Some (target_str, result.Day11_solution.Solve_result.examined)
+ | Error _ -> None)
+ targets
+ in
(* Find the intersection (common to all) *)
- let common = match examined_sets with
+ let common =
+ match examined_sets with
| [] -> OpamPackage.Name.Set.empty
| (_, first) :: rest ->
- List.fold_left (fun acc (_, s) ->
- OpamPackage.Name.Set.inter acc s
- ) first rest
+ List.fold_left
+ (fun acc (_, s) -> OpamPackage.Name.Set.inter acc s)
+ first rest
in
Printf.printf "Common to all: %d packages\n%!"
(OpamPackage.Name.Set.cardinal common);
(* For each target, show packages unique to it *)
- List.iter (fun (name, examined) ->
- let unique = OpamPackage.Name.Set.diff examined common in
- if not (OpamPackage.Name.Set.is_empty unique) then
- Printf.printf "\n%s: %d unique (beyond %d common):\n %s\n%!"
- name
- (OpamPackage.Name.Set.cardinal unique)
- (OpamPackage.Name.Set.cardinal common)
- (String.concat ", "
- (List.map OpamPackage.Name.to_string
- (OpamPackage.Name.Set.elements unique)))
- ) examined_sets;
+ List.iter
+ (fun (name, examined) ->
+ let unique = OpamPackage.Name.Set.diff examined common in
+ if not (OpamPackage.Name.Set.is_empty unique) then
+ Printf.printf "\n%s: %d unique (beyond %d common):\n %s\n%!" name
+ (OpamPackage.Name.Set.cardinal unique)
+ (OpamPackage.Name.Set.cardinal common)
+ (String.concat ", "
+ (List.map OpamPackage.Name.to_string
+ (OpamPackage.Name.Set.elements unique))))
+ examined_sets;
(* Find packages examined by exactly some but not all *)
- let all_examined = List.fold_left (fun acc (_, s) ->
- OpamPackage.Name.Set.union acc s
- ) OpamPackage.Name.Set.empty examined_sets in
+ let all_examined =
+ List.fold_left
+ (fun acc (_, s) -> OpamPackage.Name.Set.union acc s)
+ OpamPackage.Name.Set.empty examined_sets
+ in
let partial = OpamPackage.Name.Set.diff all_examined common in
Printf.printf "\nPartially examined (%d packages):\n%!"
(OpamPackage.Name.Set.cardinal partial);
- OpamPackage.Name.Set.iter (fun name ->
- let targets_with = List.filter (fun (_, s) ->
- OpamPackage.Name.Set.mem name s
- ) examined_sets in
- Printf.printf " %s: %d/%d targets\n%!"
- (OpamPackage.Name.to_string name)
- (List.length targets_with) (List.length examined_sets)
- ) partial
+ OpamPackage.Name.Set.iter
+ (fun name ->
+ let targets_with =
+ List.filter
+ (fun (_, s) -> OpamPackage.Name.Set.mem name s)
+ examined_sets
+ in
+ Printf.printf " %s: %d/%d targets\n%!"
+ (OpamPackage.Name.to_string name)
+ (List.length targets_with)
+ (List.length examined_sets))
+ partial
File "day11/batch/test/test_incremental.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/test/test_incremental.ml b/_build/default/day11/batch/test/.formatted/test_incremental.ml
index 0b5e726..2bb1df8 100644
--- a/_build/default/day11/batch/test/test_incremental.ml
+++ b/_build/default/day11/batch/test/.formatted/test_incremental.ml
@@ -20,13 +20,10 @@ open Day11_test_util.Test_util
(* Commits to test across *)
let before_leaf = "cd9fdba763a1cf1ceaa1286427354a6237c1bfe0"
let after_leaf = "2bf2bf6ea0c8867eede5e26c1c591999dd5a9ee1"
-
let before_dune = "7d22a58614c38be74d79ae6ef2b64994ca4ffef0"
let after_dune = "001b427da21d4d746e124eaaffab7b4134813f6d"
-
let before_lwt = "2bf2bf6ea0c8867eede5e26c1c591999dd5a9ee1"
let after_lwt = "7d22a58614c38be74d79ae6ef2b64994ca4ffef0"
-
let before_miou = "f9f7db30fd6e805d48b947df138d463a5433f4d1"
let after_miou = "38e3b080865ec919fdc7292e31dedcb8580ec6ea"
@@ -37,65 +34,70 @@ let after_uring = "6a73dfdaa325c567c26206b9d38a2bc788fc6be8"
(* hxd: examined by dream only (1/8) → expect 7/8 reused *)
let before_hxd = "9e3a17040e4a64f2381eed061ca12fd2fde434c2"
let after_hxd = "6fdb134ad2f7372f6b3121fc5d536ec57ebe07ba"
-
let before_compiler = "809faa59ae6d7ced1d9cd52d11740accdb6b5e83"
let after_compiler = "d10e5a9919bb3cca75e8ad64d90d869bd5b237f0"
(* Packages to solve — diverse ecosystems *)
-let target_strs = [
- (* lwt ecosystem *)
- "cohttp-lwt.6.2.1";
- "dream.1.0.0~alpha8";
- (* async ecosystem *)
- "cohttp-async.6.2.1";
- "core.v0.17.1";
- (* eio / standalone *)
- "eio_main.1.2";
- "zarith.1.14";
- (* simple *)
- "cmdliner.1.3.0";
- "astring.0.8.5";
-]
-
-let opam_env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" ()
+let target_strs =
+ [
+ (* lwt ecosystem *)
+ "cohttp-lwt.6.2.1";
+ "dream.1.0.0~alpha8";
+ (* async ecosystem *)
+ "cohttp-async.6.2.1";
+ "core.v0.17.1";
+ (* eio / standalone *)
+ "eio_main.1.2";
+ "zarith.1.14";
+ (* simple *)
+ "cmdliner.1.3.0";
+ "astring.0.8.5";
+ ]
+
+let opam_env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
let load_packages_at_commit store commit_sha =
- let hash = Day11_opam.Git_utils.resolve_commit_in_store
- store (Some commit_sha) in
+ let hash =
+ Day11_opam.Git_utils.resolve_commit_in_store store (Some commit_sha)
+ in
Day11_opam.Git_packages.of_commit store hash
let solve_and_cache ~git_packages ~cache_dir targets =
let solved = ref 0 in
let failed = ref 0 in
- List.iter (fun target_str ->
- let target = OpamPackage.of_string target_str in
- let cache_file = Fpath.(cache_dir / (target_str ^ ".json")) in
- match Day11_solver.Solve.solve
- ~packages:git_packages ~env:opam_env target with
- | Ok result ->
- let entry = Incremental_solver.Cached_solution {
- package = target; result; cache_key = None;
- } in
- Printf.printf " %s: %d deps, %d examined\n%!"
- target_str (OpamPackage.Map.cardinal result.Day11_solution.Solve_result.build_deps)
- (OpamPackage.Name.Set.cardinal result.examined);
- (match Incremental_solver.save cache_file entry with
- | Ok () -> incr solved
- | Error (`Msg e) ->
- Printf.printf " Save error %s: %s\n%!" target_str e;
- incr failed)
- | Error (_diag, _examined) ->
- incr failed
- ) targets;
+ List.iter
+ (fun target_str ->
+ let target = OpamPackage.of_string target_str in
+ let cache_file = Fpath.(cache_dir / (target_str ^ ".json")) in
+ match
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env target
+ with
+ | Ok result -> (
+ let entry =
+ Incremental_solver.Cached_solution
+ { package = target; result; cache_key = None }
+ in
+ Printf.printf " %s: %d deps, %d examined\n%!" target_str
+ (OpamPackage.Map.cardinal
+ result.Day11_solution.Solve_result.build_deps)
+ (OpamPackage.Name.Set.cardinal result.examined);
+ match Incremental_solver.save cache_file entry with
+ | Ok () -> incr solved
+ | Error (`Msg e) ->
+ Printf.printf " Save error %s: %s\n%!" target_str e;
+ incr failed)
+ | Error (_diag, _examined) -> incr failed)
+ targets;
(!solved, !failed)
let fresh_solve ~git_packages target_str =
let target = OpamPackage.of_string target_str in
Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env target
-let solutions_equal (s1 : Day11_solution.Solve_result.t) (s2 : Day11_solution.Solve_result.t) =
+let solutions_equal (s1 : Day11_solution.Solve_result.t)
+ (s2 : Day11_solution.Solve_result.t) =
OpamPackage.Map.equal OpamPackage.Set.equal s1.build_deps s2.build_deps
let test_scenario ~name ~before_sha ~after_sha () =
@@ -103,137 +105,157 @@ let test_scenario ~name ~before_sha ~after_sha () =
let opam_repository = opam_repository () in
Printf.printf "\n=== %s ===\n%!" name;
let store, _head =
- Day11_opam.Git_utils.get_git_repo_store_and_hash opam_repository in
+ Day11_opam.Git_utils.get_git_repo_store_and_hash opam_repository
+ in
(* Step 1: Solve at "before" commit *)
let before_dir = Fpath.(dir / "before") in
mkdir before_dir;
Printf.printf " Loading packages at %s...\n%!" before_sha;
let before_packages = load_packages_at_commit store before_sha in
Printf.printf " Solving %d targets...\n%!" (List.length target_strs);
- let solved, failed = solve_and_cache
- ~git_packages:before_packages ~cache_dir:before_dir target_strs in
+ let solved, failed =
+ solve_and_cache ~git_packages:before_packages ~cache_dir:before_dir
+ target_strs
+ in
Printf.printf " Before: %d solved, %d failed\n%!" solved failed;
Alcotest.(check bool) "some solved" true (solved > 0);
(* Step 2: Compute changed packages *)
- let before_hash = Day11_opam.Git_utils.resolve_commit_in_store
- store (Some before_sha) in
- let after_hash = Day11_opam.Git_utils.resolve_commit_in_store
- store (Some after_sha) in
- let changed_names = Day11_opam.Git_packages.diff_packages
- ~store before_hash after_hash in
- let changed_set = List.fold_left (fun s n ->
- OpamPackage.Name.Set.add n s
- ) OpamPackage.Name.Set.empty changed_names in
+ let before_hash =
+ Day11_opam.Git_utils.resolve_commit_in_store store (Some before_sha)
+ in
+ let after_hash =
+ Day11_opam.Git_utils.resolve_commit_in_store store (Some after_sha)
+ in
+ let changed_names =
+ Day11_opam.Git_packages.diff_packages ~store before_hash after_hash
+ in
+ let changed_set =
+ List.fold_left
+ (fun s n -> OpamPackage.Name.Set.add n s)
+ OpamPackage.Name.Set.empty changed_names
+ in
Printf.printf " Changed packages: %d (%s)\n%!"
(List.length changed_names)
(String.concat ", "
(List.map OpamPackage.Name.to_string
(List.filteri (fun i _ -> i < 5) changed_names)
- @ (if List.length changed_names > 5 then ["..."] else [])));
+ @ if List.length changed_names > 5 then [ "..." ] else []));
(* Step 3: Incremental reuse *)
let after_dir = Fpath.(dir / "after") in
mkdir after_dir;
- let reused = Incremental_solver.reuse_solutions
- ~solutions_cache_dir:after_dir ~previous_dir:before_dir
- ~changed_packages:changed_set ~packages:target_strs in
+ let reused =
+ Incremental_solver.reuse_solutions ~solutions_cache_dir:after_dir
+ ~previous_dir:before_dir ~changed_packages:changed_set
+ ~packages:target_strs
+ in
Printf.printf " Reused: %d/%d\n%!" reused (List.length target_strs);
(* Step 4: Re-solve invalidated packages at "after" commit *)
let after_packages = load_packages_at_commit store after_sha in
let re_solved = ref 0 in
- List.iter (fun target_str ->
- let cache_file = Fpath.(after_dir / (target_str ^ ".json")) in
- if not (Sys.file_exists (Fpath.to_string cache_file)) then begin
- Printf.printf " Re-solving %s...\n%!" target_str;
- let target = OpamPackage.of_string target_str in
- match Day11_solver.Solve.solve
- ~packages:after_packages ~env:opam_env target with
- | Ok result ->
- let entry = Incremental_solver.Cached_solution {
- package = target; result; cache_key = None;
- } in
- ignore (Incremental_solver.save cache_file entry);
- incr re_solved
- | Error _ -> incr re_solved
- end
- ) target_strs;
+ List.iter
+ (fun target_str ->
+ let cache_file = Fpath.(after_dir / (target_str ^ ".json")) in
+ if not (Sys.file_exists (Fpath.to_string cache_file)) then (
+ Printf.printf " Re-solving %s...\n%!" target_str;
+ let target = OpamPackage.of_string target_str in
+ match
+ Day11_solver.Solve.solve ~packages:after_packages ~env:opam_env target
+ with
+ | Ok result ->
+ let entry =
+ Incremental_solver.Cached_solution
+ { package = target; result; cache_key = None }
+ in
+ ignore (Incremental_solver.save cache_file entry);
+ incr re_solved
+ | Error _ -> incr re_solved))
+ target_strs;
Printf.printf " Re-solved: %d\n%!" !re_solved;
- Alcotest.(check int) "all accounted for"
- (List.length target_strs) (reused + !re_solved);
+ Alcotest.(check int)
+ "all accounted for" (List.length target_strs) (reused + !re_solved);
(* Step 5: Verify reused solutions match fresh solve *)
Printf.printf " Verifying reused solutions...\n%!";
let mismatches = ref 0 in
- List.iter (fun target_str ->
- let cache_file = Fpath.(after_dir / (target_str ^ ".json")) in
- match Incremental_solver.load cache_file with
- | Ok (Cached_solution cached) ->
- (match fresh_solve ~git_packages:after_packages target_str with
- | Ok fresh_result ->
- if not (solutions_equal cached.result fresh_result) then begin
- Printf.printf " MISMATCH: %s\n%!" target_str;
- incr mismatches
- end
- | Error _ -> ())
- | _ -> ()
- ) target_strs;
+ List.iter
+ (fun target_str ->
+ let cache_file = Fpath.(after_dir / (target_str ^ ".json")) in
+ match Incremental_solver.load cache_file with
+ | Ok (Cached_solution cached) -> (
+ match fresh_solve ~git_packages:after_packages target_str with
+ | Ok fresh_result ->
+ if not (solutions_equal cached.result fresh_result) then (
+ Printf.printf " MISMATCH: %s\n%!" target_str;
+ incr mismatches)
+ | Error _ -> ())
+ | _ -> ())
+ target_strs;
Printf.printf " Mismatches: %d\n%!" !mismatches;
Alcotest.(check int) "no mismatches" 0 !mismatches;
(* Return stats for overall reporting *)
(List.length changed_names, reused)
let test_leaf_package () =
- let changed, reused = test_scenario
- ~name:"Leaf package (rfsm.2.3)"
- ~before_sha:before_leaf ~after_sha:after_leaf () in
+ let changed, reused =
+ test_scenario ~name:"Leaf package (rfsm.2.3)" ~before_sha:before_leaf
+ ~after_sha:after_leaf ()
+ in
Printf.printf " → %d changes, %d/%d reused\n%!" changed reused
(List.length target_strs);
(* rfsm is obscure enough not to be in the examined set *)
- Alcotest.(check bool) "most reused" true
+ Alcotest.(check bool)
+ "most reused" true
(reused >= List.length target_strs - 1)
let test_dune_release () =
- let changed, reused = test_scenario
- ~name:"Ecosystem package (dune 3.21.0)"
- ~before_sha:before_dune ~after_sha:after_dune () in
+ let changed, reused =
+ test_scenario ~name:"Ecosystem package (dune 3.21.0)"
+ ~before_sha:before_dune ~after_sha:after_dune ()
+ in
Printf.printf " → %d changes, %d reused\n%!" changed reused
let test_uring_release () =
- let changed, reused = test_scenario
- ~name:"Eio-only package (uring 2.7.0)"
- ~before_sha:before_uring ~after_sha:after_uring () in
- Printf.printf " → %d changes, %d/%d reused\n%!"
- changed reused (List.length target_strs);
+ let changed, reused =
+ test_scenario ~name:"Eio-only package (uring 2.7.0)"
+ ~before_sha:before_uring ~after_sha:after_uring ()
+ in
+ Printf.printf " → %d changes, %d/%d reused\n%!" changed reused
+ (List.length target_strs);
(* uring only examined by eio_main — reuse all that solved *)
Alcotest.(check bool) "most reused" true (reused >= 5)
let test_hxd_release () =
- let changed, reused = test_scenario
- ~name:"Dream-only package (hxd 0.4.0)"
- ~before_sha:before_hxd ~after_sha:after_hxd () in
- Printf.printf " → %d changes, %d/%d reused\n%!"
- changed reused (List.length target_strs);
+ let changed, reused =
+ test_scenario ~name:"Dream-only package (hxd 0.4.0)" ~before_sha:before_hxd
+ ~after_sha:after_hxd ()
+ in
+ Printf.printf " → %d changes, %d/%d reused\n%!" changed reused
+ (List.length target_strs);
(* hxd only examined by dream *)
Alcotest.(check bool) "most reused" true (reused >= 7)
let test_lwt_release () =
- let changed, reused = test_scenario
- ~name:"Mid-range package (lwt 6.0.0)"
- ~before_sha:before_lwt ~after_sha:after_lwt () in
- Printf.printf " → %d changes, %d/%d reused\n%!"
- changed reused (List.length target_strs)
+ let changed, reused =
+ test_scenario ~name:"Mid-range package (lwt 6.0.0)" ~before_sha:before_lwt
+ ~after_sha:after_lwt ()
+ in
+ Printf.printf " → %d changes, %d/%d reused\n%!" changed reused
+ (List.length target_strs)
let test_miou_release () =
- let changed, reused = test_scenario
- ~name:"Niche package (miou 0.5.2)"
- ~before_sha:before_miou ~after_sha:after_miou () in
- Printf.printf " → %d changes, %d/%d reused\n%!"
- changed reused (List.length target_strs)
+ let changed, reused =
+ test_scenario ~name:"Niche package (miou 0.5.2)" ~before_sha:before_miou
+ ~after_sha:after_miou ()
+ in
+ Printf.printf " → %d changes, %d/%d reused\n%!" changed reused
+ (List.length target_strs)
let test_compiler_release () =
- let changed, reused = test_scenario
- ~name:"Compiler release (OCaml 5.4.1)"
- ~before_sha:before_compiler ~after_sha:after_compiler () in
- Printf.printf " → %d changes, %d reused (expect few/none reused)\n%!"
- changed reused;
+ let changed, reused =
+ test_scenario ~name:"Compiler release (OCaml 5.4.1)"
+ ~before_sha:before_compiler ~after_sha:after_compiler ()
+ in
+ Printf.printf " → %d changes, %d reused (expect few/none reused)\n%!" changed
+ reused;
(* Compiler changes touch ocaml/ocaml-base-compiler which the solver
examines for every package — expect no reuse *)
Alcotest.(check bool) "few reused" true (reused <= 1)
@@ -243,12 +265,15 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_incremental"
- [ ( "Incremental solver",
- [ Alcotest.test_case "leaf package" `Slow test_leaf_package;
+ [
+ ( "Incremental solver",
+ [
+ Alcotest.test_case "leaf package" `Slow test_leaf_package;
Alcotest.test_case "niche (miou)" `Slow test_miou_release;
Alcotest.test_case "eio-only (uring)" `Slow test_uring_release;
Alcotest.test_case "dream-only (hxd)" `Slow test_hxd_release;
Alcotest.test_case "lwt (via dune)" `Slow test_lwt_release;
Alcotest.test_case "dune release" `Slow test_dune_release;
- Alcotest.test_case "compiler release" `Slow
- test_compiler_release ] ) ]
+ Alcotest.test_case "compiler release" `Slow test_compiler_release;
+ ] );
+ ]
File "day11/benchmark/benchmark.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/benchmark/benchmark.ml b/_build/default/day11/benchmark/.formatted/benchmark.ml
index 52a5813..6ec0216 100644
--- a/_build/default/day11/benchmark/benchmark.ml
+++ b/_build/default/day11/benchmark/.formatted/benchmark.ml
@@ -17,97 +17,162 @@ let () =
(* 1. Solver setup *)
let git_packages, repos_with_shas =
time "Load opam-repository (git)" (fun () ->
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ]) in
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ])
+ in
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
(* 2. Single solve *)
let _sol_astring =
time "Solve astring.0.8.5" (fun () ->
- Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- (OpamPackage.of_string "astring.0.8.5")) in
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
+ (OpamPackage.of_string "astring.0.8.5"))
+ in
let _sol_odoc =
time "Solve odoc.3.1.0" (fun () ->
- Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- (OpamPackage.of_string "odoc.3.1.0")) in
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
+ (OpamPackage.of_string "odoc.3.1.0"))
+ in
let _sol_base =
time "Solve base.v0.17.3" (fun () ->
- Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- (OpamPackage.of_string "base.v0.17.3")) in
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
+ (OpamPackage.of_string "base.v0.17.3"))
+ in
(* 3. Solve 50 packages *)
- let packages_50 = [
- "astring.0.8.5"; "fmt.0.9.0"; "bos.0.2.1"; "logs.0.7.0";
- "cmdliner.1.3.0"; "yojson.2.2.2"; "ptime.1.2.0"; "uutf.1.0.3";
- "re.1.14.0"; "cstruct.6.2.0"; "lwt.6.0.0"; "eio.1.3";
- "ppxlib.0.37.0"; "menhir.20260209"; "sedlex.3.7";
- "odoc.3.1.0"; "base.v0.17.3"; "core.v0.17.1";
- "zarith.1.14"; "num.1.6"; "ocamlgraph.2.2.0";
- "js_of_ocaml.6.3.2"; "brr.0.0.8"; "tyxml.4.6.0";
- "jsonm.1.0.2"; "sexplib0.v0.17.0"; "parsexp.v0.17.0";
- "csexp.1.5.2"; "base64.3.5.2"; "bigstringaf.0.10.0";
- "cmarkit.0.4.0"; "fpath.0.7.3"; "rresult.0.7.0";
- "result.1.5"; "seq.base"; "topkg.1.1.1"; "ocamlbuild.0.16.1";
- "ocamlfind.1.9.8"; "cppo.1.8.0"; "gen.1.1"; "mtime.2.1.0";
- "progress.0.5.0"; "terminal.0.5.0"; "checkseum.0.5.2";
- "decompress.1.5.3"; "optint.0.3.0"; "hmap.0.8.1";
- "psq.0.2.1"; "angstrom.0.16.1"; "domain-local-await.1.0.1"
- ] in
+ let packages_50 =
+ [
+ "astring.0.8.5";
+ "fmt.0.9.0";
+ "bos.0.2.1";
+ "logs.0.7.0";
+ "cmdliner.1.3.0";
+ "yojson.2.2.2";
+ "ptime.1.2.0";
+ "uutf.1.0.3";
+ "re.1.14.0";
+ "cstruct.6.2.0";
+ "lwt.6.0.0";
+ "eio.1.3";
+ "ppxlib.0.37.0";
+ "menhir.20260209";
+ "sedlex.3.7";
+ "odoc.3.1.0";
+ "base.v0.17.3";
+ "core.v0.17.1";
+ "zarith.1.14";
+ "num.1.6";
+ "ocamlgraph.2.2.0";
+ "js_of_ocaml.6.3.2";
+ "brr.0.0.8";
+ "tyxml.4.6.0";
+ "jsonm.1.0.2";
+ "sexplib0.v0.17.0";
+ "parsexp.v0.17.0";
+ "csexp.1.5.2";
+ "base64.3.5.2";
+ "bigstringaf.0.10.0";
+ "cmarkit.0.4.0";
+ "fpath.0.7.3";
+ "rresult.0.7.0";
+ "result.1.5";
+ "seq.base";
+ "topkg.1.1.1";
+ "ocamlbuild.0.16.1";
+ "ocamlfind.1.9.8";
+ "cppo.1.8.0";
+ "gen.1.1";
+ "mtime.2.1.0";
+ "progress.0.5.0";
+ "terminal.0.5.0";
+ "checkseum.0.5.2";
+ "decompress.1.5.3";
+ "optint.0.3.0";
+ "hmap.0.8.1";
+ "psq.0.2.1";
+ "angstrom.0.16.1";
+ "domain-local-await.1.0.1";
+ ]
+ in
let solutions =
- time (Printf.sprintf "Solve %d packages" (List.length packages_50)) (fun () ->
- List.filter_map (fun pkg_str ->
- match Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- (OpamPackage.of_string pkg_str) with
- | Ok result -> Some (OpamPackage.of_string pkg_str, result.Day11_solution.Solve_result.build_deps)
- | Error _ -> None
- ) packages_50) in
- Printf.printf " → %d/%d solved\n%!" (List.length solutions) (List.length packages_50);
+ time
+ (Printf.sprintf "Solve %d packages" (List.length packages_50))
+ (fun () ->
+ List.filter_map
+ (fun pkg_str ->
+ match
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
+ (OpamPackage.of_string pkg_str)
+ with
+ | Ok result ->
+ Some
+ ( OpamPackage.of_string pkg_str,
+ result.Day11_solution.Solve_result.build_deps )
+ | Error _ -> None)
+ packages_50)
+ in
+ Printf.printf " → %d/%d solved\n%!" (List.length solutions)
+ (List.length packages_50);
(* 4. DAG construction *)
let find_opam = Day11_opam.Git_packages.find_package git_packages in
let cache = Day11_opam_build.Hash_cache.create ~find_opam () in
let nodes =
time "Build DAG (50 solutions)" (fun () ->
- Day11_opam_build.Dag.build_dag cache ~base_hash:"benchmark"
- (List.map (fun (t, d) -> (t, d, d)) solutions)) in
+ Day11_opam_build.Dag.build_dag cache ~base_hash:"benchmark"
+ (List.map (fun (t, d) -> (t, d, d)) solutions))
+ in
Printf.printf " → %d unique nodes\n%!" (List.length nodes);
(* 5. Blessing *)
let _blessing_maps =
time "Compute blessings (50 solutions)" (fun () ->
- Day11_batch.Blessing.compute_blessings solutions) in
+ Day11_batch.Blessing.compute_blessings solutions)
+ in
(* 6. Build with warm cache (if available) *)
Eio_main.run @@ fun env ->
Eio.Switch.run @@ fun sw ->
let env = (env :> Eio_unix.Stdenv.base) in
let scratch_cache = Fpath.v "/tmp/day11-scratch-cache" in
- (match Day11_opam_build.Base.load_cached ~cache_dir:scratch_cache
- ~os_distribution:"debian" ~os_version:"bookworm" with
+ (match
+ Day11_opam_bild.Base.load_cached ~cache_dir:scratch_cache
+ ~os_distribution:"debian" ~os_version:"bookworm"
+ with
| None ->
- Printf.printf "\nNo cached base image — skipping build benchmarks\n%!"
+ Printf.printf "\nNo cached base image — skipping build benchmarks\n%!"
| Some base ->
- let os_dir = Fpath.(scratch_cache / "linux-x86_64") in
- let benv = Day11_opam_build.Types.make_build_env ~base ~os_dir
- ~uid:1000 ~gid:1000 () in
- Day11_opam_build.Types.ensure_dirs benv;
- (* Warm cache: build astring (should be instant) *)
- let astring_hash = Day11_opam_build.Hash_cache.layer_hash cache
- ~base_hash:base.hash [ OpamPackage.of_string "astring.0.8.5" ] in
- let astring_node : Day11_opam_layer.Build.t =
- { hash = astring_hash;
- pkg = OpamPackage.of_string "astring.0.8.5";
- deps = []; universe = Day11_solution.Universe.dummy } in
- ignore (time "Build astring (cache hit)" (fun () ->
- Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[] astring_node ()));
- (* Warm cache: build odoc-driver tool *)
- ignore (time "Tools.build_tool odoc-driver (cache hit)" (fun () ->
- Day11_opam_build.Tools.build_tool ~sw env benv
- ~packages:git_packages ~repos:repos_with_shas
- (OpamPackage.of_string "odoc-driver.3.1.0")));
- );
+ let os_dir = Fpath.(scratch_cache / "linux-x86_64") in
+ let benv =
+ Day11_opam_build.Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000
+ ()
+ in
+ Day11_opam_build.Types.ensure_dirs benv;
+ (* Warm cache: build astring (should be instant) *)
+ let astring_hash =
+ Day11_opam_build.Hash_cache.layer_hash cache ~base_hash:base.hash
+ [ OpamPackage.of_string "astring.0.8.5" ]
+ in
+ let astring_node : Day11_opam_layer.Build.t =
+ {
+ hash = astring_hash;
+ pkg = OpamPackage.of_string "astring.0.8.5";
+ deps = [];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ ignore
+ (time "Build astring (cache hit)" (fun () ->
+ Day11_opam_build.Build_layer.build ~sw env benv
+ ~opam_repositories:[] astring_node ()));
+ (* Warm cache: build odoc-driver tool *)
+ ignore
+ (time "Tools.build_tool odoc-driver (cache hit)" (fun () ->
+ Day11_opam_build.Tools.build_tool ~sw env benv
+ ~packages:git_packages ~repos:repos_with_shas
+ (OpamPackage.of_string "odoc-driver.3.1.0"))));
Printf.printf "\nDone.\n%!"
File "day11/benchmark/benchmark_builds.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/benchmark/benchmark_builds.ml b/_build/default/day11/benchmark/.formatted/benchmark_builds.ml
index a565c09..b89ca1a 100644
--- a/_build/default/day11/benchmark/benchmark_builds.ml
+++ b/_build/default/day11/benchmark/.formatted/benchmark_builds.ml
@@ -20,88 +20,127 @@ let time name f =
let () =
Bos.OS.Dir.set_default_tmp (Fpath.v (Filename.get_temp_dir_name ()));
Printf.printf "=== Layer build benchmark ===\n\n";
- Eio_main.run @@ fun env -> Eio.Switch.run @@ fun sw ->
+ Eio_main.run @@ fun env ->
+ Eio.Switch.run @@ fun sw ->
let env = (env :> Eio_unix.Stdenv.base) in
- let base = match Day11_opam_build.Base.load_cached ~cache_dir:scratch_cache
- ~os_distribution:"debian" ~os_version:"bookworm" with
+ let base =
+ match
+ Day11_opam_build.Base.load_cached ~cache_dir:scratch_cache
+ ~os_distribution:"debian" ~os_version:"bookworm"
+ with
| Some b -> b
- | None -> Printf.printf "No cached base — exiting\n%!"; exit 1
+ | None ->
+ Printf.printf "No cached base — exiting\n%!";
+ exit 1
in
let os_dir = Fpath.(scratch_cache / "linux-x86_64") in
- let benv = Day11_opam_build.Types.make_build_env ~base ~os_dir
- ~uid:1000 ~gid:1000 () in
+ let benv =
+ Day11_opam_build.Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 ()
+ in
Day11_opam_build.Types.ensure_dirs benv;
let git_packages, _store, _commit =
- Day11_opam.Git_packages.of_opam_repository opam_repository in
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
+ Day11_opam.Git_packages.of_opam_repository opam_repository
+ in
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
let find_opam = Day11_opam.Git_packages.find_package git_packages in
let cache = Day11_opam_build.Hash_cache.create ~find_opam () in
(* Build packages that should exist in the compiler layer already.
These are small packages that build quickly. *)
- let test_packages = [
- "astring.0.8.5";
- "fmt.0.9.0";
- "logs.0.7.0";
- "fpath.0.7.3";
- "rresult.0.7.0";
- "bos.0.2.1";
- "cmdliner.1.3.0";
- "topkg.1.1.1";
- "ptime.1.2.0";
- "uutf.1.0.3";
- "yojson.2.2.2";
- "re.1.14.0";
- ] in
+ let test_packages =
+ [
+ "astring.0.8.5";
+ "fmt.0.9.0";
+ "logs.0.7.0";
+ "fpath.0.7.3";
+ "rresult.0.7.0";
+ "bos.0.2.1";
+ "cmdliner.1.3.0";
+ "topkg.1.1.1";
+ "ptime.1.2.0";
+ "uutf.1.0.3";
+ "yojson.2.2.2";
+ "re.1.14.0";
+ ]
+ in
(* First solve them all to get proper DAG *)
Printf.printf "Solving...\n%!";
- let solutions = List.filter_map (fun pkg_str ->
- match Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- (OpamPackage.of_string pkg_str) with
- | Ok result -> Some (OpamPackage.of_string pkg_str, result.Day11_solution.Solve_result.build_deps)
- | Error _ -> Printf.printf " FAILED: %s\n%!" pkg_str; None
- ) test_packages in
+ let solutions =
+ List.filter_map
+ (fun pkg_str ->
+ match
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
+ (OpamPackage.of_string pkg_str)
+ with
+ | Ok result ->
+ Some
+ ( OpamPackage.of_string pkg_str,
+ result.Day11_solution.Solve_result.build_deps )
+ | Error _ ->
+ Printf.printf " FAILED: %s\n%!" pkg_str;
+ None)
+ test_packages
+ in
Printf.printf " %d solved\n\n" (List.length solutions);
(* Build the DAG *)
let nodes =
Day11_opam_build.Dag.build_dag cache ~base_hash:base.hash
- (List.map (fun (t, d) -> (t, d, d)) solutions) in
+ (List.map (fun (t, d) -> (t, d, d)) solutions)
+ in
Printf.printf "DAG: %d nodes\n\n" (List.length nodes);
(* First pass: ensure everything is cached (warm up) *)
Printf.printf "--- Warm-up (build all, cache fills) ---\n%!";
- let _ = time "Build all (warm-up)" (fun () ->
- Day11_opam_build.Dag_executor.execute env ~np:4
- ~on_complete:(fun ~stats:_ ~cached:_ _ _ -> ())
- ~on_cascade:(fun ~failed:_ ~failed_dep:_ -> ())
- nodes
- (fun node ->
- match Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[] node () with
- | Day11_opam_build.Types.Success _ -> true
- | _ -> false)) in
+ let _ =
+ time "Build all (warm-up)" (fun () ->
+ Day11_opam_build.Dag_executor.execute env ~np:4
+ ~on_complete:(fun ~stats:_ ~cached:_ _ _ -> ())
+ ~on_cascade:(fun ~failed:_ ~failed_dep:_ -> ())
+ nodes
+ (fun node ->
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv
+ ~opam_repositories:[] node ()
+ with
+ | Day11_opam_build.Types.Success _ -> true
+ | _ -> false))
+ in
(* Second pass: time cache hits *)
Printf.printf "\n--- Cache hit timing ---\n%!";
- List.iter (fun pkg_str ->
- let pkg = OpamPackage.of_string pkg_str in
- match List.find_opt (fun (n : Day11_opam_layer.Build.t) ->
- OpamPackage.equal n.pkg pkg) nodes with
- | Some node ->
- ignore (time (Printf.sprintf "Build %s (cache hit)" pkg_str) (fun () ->
- Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[] node ()))
- | None -> ()
- ) test_packages;
+ List.iter
+ (fun pkg_str ->
+ let pkg = OpamPackage.of_string pkg_str in
+ match
+ List.find_opt
+ (fun (n : Day11_opam_layer.Build.t) -> OpamPackage.equal n.pkg pkg)
+ nodes
+ with
+ | Some node ->
+ ignore
+ (time (Printf.sprintf "Build %s (cache hit)" pkg_str) (fun () ->
+ Day11_opam_build.Build_layer.build ~sw env benv
+ ~opam_repositories:[] node ()))
+ | None -> ())
+ test_packages;
(* Third pass: clear individual layers and time cold rebuilds *)
Printf.printf "\n--- Cold rebuild timing ---\n%!";
- List.iter (fun pkg_str ->
- let pkg = OpamPackage.of_string pkg_str in
- match List.find_opt (fun (n : Day11_opam_layer.Build.t) ->
- OpamPackage.equal n.pkg pkg) nodes with
- | Some node ->
- let layer_dir = Day11_opam_layer.Build.dir ~os_dir node in
- (* Delete just this layer to force rebuild *)
- ignore (Day11_sys.Sudo.rm_rf ~sw env layer_dir);
- ignore (time (Printf.sprintf "Build %s (cold)" pkg_str) (fun () ->
- Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[] node ()))
- | None -> ()
- ) test_packages;
+ List.iter
+ (fun pkg_str ->
+ let pkg = OpamPackage.of_string pkg_str in
+ match
+ List.find_opt
+ (fun (n : Day11_opam_layer.Build.t) -> OpamPackage.equal n.pkg pkg)
+ nodes
+ with
+ | Some node ->
+ let layer_dir = Day11_opam_layer.Build.dir ~os_dir node in
+ (* Delete just this layer to force rebuild *)
+ ignore (Day11_sys.Sudo.rm_rf ~sw env layer_dir);
+ ignore
+ (time (Printf.sprintf "Build %s (cold)" pkg_str) (fun () ->
+ Day11_opam_build.Build_layer.build ~sw env benv
+ ~opam_repositories:[] node ()))
+ | None -> ())
+ test_packages;
Printf.printf "\nDone.\n%!"
File "day11/benchmark/benchmark_day10.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/benchmark/benchmark_day10.ml b/_build/default/day11/benchmark/.formatted/benchmark_day10.ml
index 0da1080..b52577a 100644
--- a/_build/default/day11/benchmark/benchmark_day10.ml
+++ b/_build/default/day11/benchmark/.formatted/benchmark_day10.ml
@@ -20,23 +20,28 @@ let () =
(* Eager load: read all packages upfront (like day10 does with readdir) *)
let git_packages, _store, _commit =
time "Load opam-repository (git eager)" (fun () ->
- Day11_opam.Git_packages.of_opam_repository opam_repository) in
+ Day11_opam.Git_packages.of_opam_repository opam_repository)
+ in
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
(* The key difference: day10 uses filesystem readdir for each solve,
day11 uses git objects. Both use opam-0install underneath.
The solver itself is the same — the difference is package loading. *)
-
- let _ = time "Solve astring.0.8.5 (2nd run)" (fun () ->
- Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- (OpamPackage.of_string "astring.0.8.5")) in
-
- let _ = time "Solve astring.0.8.5 (3rd run)" (fun () ->
- Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- (OpamPackage.of_string "astring.0.8.5")) in
+ let _ =
+ time "Solve astring.0.8.5 (2nd run)" (fun () ->
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
+ (OpamPackage.of_string "astring.0.8.5"))
+ in
+
+ let _ =
+ time "Solve astring.0.8.5 (3rd run)" (fun () ->
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
+ (OpamPackage.of_string "astring.0.8.5"))
+ in
Printf.printf "\n(day10 uses the same opam-0install solver;\n";
Printf.printf " the difference is filesystem vs git package loading)\n";
File "day11/benchmark/benchmark_docs.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/benchmark/benchmark_docs.ml b/_build/default/day11/benchmark/.formatted/benchmark_docs.ml
index 1423dca..b436f88 100644
--- a/_build/default/day11/benchmark/benchmark_docs.ml
+++ b/_build/default/day11/benchmark/.formatted/benchmark_docs.ml
@@ -18,102 +18,161 @@ let () =
Logs.set_reporter (Logs_fmt.reporter ());
Logs.set_level (Some Logs.Info);
Printf.printf "=== Doc generation benchmark ===\n\n";
- Eio_main.run @@ fun env -> Eio.Switch.run @@ fun sw ->
+ Eio_main.run @@ fun env ->
+ Eio.Switch.run @@ fun sw ->
let env = (env :> Eio_unix.Stdenv.base) in
- let base = match Day11_opam_build.Base.load_cached ~cache_dir:scratch_cache
- ~os_distribution:"debian" ~os_version:"bookworm" with
+ let base =
+ match
+ Day11_opam_build.Base.load_cached ~cache_dir:scratch_cache
+ ~os_distribution:"debian" ~os_version:"bookworm"
+ with
| Some b -> b
- | None -> Printf.printf "No cache\n%!"; exit 1
+ | None ->
+ Printf.printf "No cache\n%!";
+ exit 1
in
let os_dir = Fpath.(scratch_cache / "linux-x86_64") in
- let benv = Day11_opam_build.Types.make_build_env ~base ~os_dir
- ~uid:1000 ~gid:1000 () in
+ let benv =
+ Day11_opam_build.Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 ()
+ in
Day11_opam_build.Types.ensure_dirs benv;
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
let find_opam = Day11_opam.Git_packages.find_package git_packages in
let cache = Day11_opam_build.Hash_cache.create ~find_opam () in
(* Build odoc-driver tools *)
- let odoc_tool = time "Build odoc-driver tools (cache)" (fun () ->
- Day11_opam_build.Tools.build_tool ~sw env benv
- ~packages:git_packages ~repos:repos_with_shas
- (OpamPackage.of_string "odoc-driver.3.1.0")
- |> Result.get_ok) in
+ let odoc_tool =
+ time "Build odoc-driver tools (cache)" (fun () ->
+ Day11_opam_build.Tools.build_tool ~sw env benv ~packages:git_packages
+ ~repos:repos_with_shas
+ (OpamPackage.of_string "odoc-driver.3.1.0")
+ |> Result.get_ok)
+ in
let tool_mounts, odoc_bin, odoc_md_bin =
- Day11_doc.Tool_binaries.doc_tool_mounts odoc_tool in
+ Day11_doc.Tool_binaries.doc_tool_mounts odoc_tool
+ in
let voodoo_bin = "/home/opam/doc-tools/bin/odoc_driver_voodoo" in
(* Solve astring properly *)
let astring_pkg = OpamPackage.of_string "astring.0.8.5" in
- let astring_result = time "Solve astring" (fun () ->
- Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- astring_pkg |> Result.get_ok) in
- let astring_solution = astring_result.Day11_solution.Solve_result.build_deps in
+ let astring_result =
+ time "Solve astring" (fun () ->
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
+ astring_pkg
+ |> Result.get_ok)
+ in
+ let astring_solution =
+ astring_result.Day11_solution.Solve_result.build_deps
+ in
(* Build astring with real deps *)
- let astring_nodes = Day11_opam_build.Dag.build_dag cache ~base_hash:base.hash
- [ (astring_pkg, astring_solution, astring_solution) ] in
- let astring_build = time "Build astring + deps (cache)" (fun () ->
- Day11_opam_build.Dag_executor.execute env ~np:4
- ~on_complete:(fun ~stats:_ ~cached:_ _ _ -> ())
- ~on_cascade:(fun ~failed:_ ~failed_dep:_ -> ())
- astring_nodes
- (fun node ->
- match Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[] node () with
- | Day11_opam_build.Types.Success _ -> true | _ -> false);
- List.find (fun (n : Day11_opam_layer.Build.t) ->
- OpamPackage.equal n.pkg astring_pkg) astring_nodes) in
+ let astring_nodes =
+ Day11_opam_build.Dag.build_dag cache ~base_hash:base.hash
+ [ (astring_pkg, astring_solution, astring_solution) ]
+ in
+ let astring_build =
+ time "Build astring + deps (cache)" (fun () ->
+ Day11_opam_build.Dag_executor.execute env ~np:4
+ ~on_complete:(fun ~stats:_ ~cached:_ _ _ -> ())
+ ~on_cascade:(fun ~failed:_ ~failed_dep:_ -> ())
+ astring_nodes
+ (fun node ->
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv
+ ~opam_repositories:[] node ()
+ with
+ | Day11_opam_build.Types.Success _ -> true
+ | _ -> false);
+ List.find
+ (fun (n : Day11_opam_layer.Build.t) ->
+ OpamPackage.equal n.pkg astring_pkg)
+ astring_nodes)
+ in
let pkg_dir = Day11_opam_layer.Build.dir ~os_dir astring_build in
- Printf.printf " astring: %d real deps\n%!"
- (List.length astring_build.deps);
+ Printf.printf " astring: %d real deps\n%!" (List.length astring_build.deps);
(* Prep *)
- let installed_libs = Day11_opam_layer.Installed_files.scan_libs ~layer_dir:pkg_dir in
- let installed_docs = Day11_opam_layer.Installed_files.scan_docs ~layer_dir:pkg_dir in
- let universe = Day11_doc.Command.compute_universe_hash
- (List.map (fun (b : Day11_opam_layer.Build.t) -> b.hash)
- astring_nodes) in
+ let installed_libs =
+ Day11_opam_layer.Installed_files.scan_libs ~layer_dir:pkg_dir
+ in
+ let installed_docs =
+ Day11_opam_layer.Installed_files.scan_docs ~layer_dir:pkg_dir
+ in
+ let universe =
+ Day11_doc.Command.compute_universe_hash
+ (List.map (fun (b : Day11_opam_layer.Build.t) -> b.hash) astring_nodes)
+ in
Printf.printf "\n--- Single-phase (--actions all) ---\n%!";
(* Delete existing doc layer *)
- let doc_hash = Day11_layer.Hash.of_strings
- [ "doc-all"; astring_build.hash; odoc_tool.hash; universe ] in
- let doc_dir = Day11_layer.Layer.dir
- (Day11_layer.Layer.of_hash ~os_dir doc_hash) in
+ let doc_hash =
+ Day11_layer.Hash.of_strings
+ [ "doc-all"; astring_build.hash; odoc_tool.hash; universe ]
+ in
+ let doc_dir =
+ Day11_layer.Layer.dir (Day11_layer.Layer.of_hash ~os_dir doc_hash)
+ in
ignore (Day11_sys.Sudo.rm_rf ~sw env doc_dir);
let prep_dir = Bos.OS.Dir.tmp "day11_bench_%s" |> Result.get_ok in
- ignore (Day11_doc.Prep.create_with_mounts ~source_layer_dir:pkg_dir
- ~dest_layer_dir:prep_dir ~universe ~pkg:astring_pkg
- ~installed_libs ~installed_docs);
- let prep_mount = Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
- "/home/opam/prep" in
+ ignore
+ (Day11_doc.Prep.create_with_mounts ~source_layer_dir:pkg_dir
+ ~dest_layer_dir:prep_dir ~universe ~pkg:astring_pkg ~installed_libs
+ ~installed_docs);
+ let prep_mount =
+ Day11_container.Mount.bind_ro
+ ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
+ "/home/opam/prep"
+ in
let all_mounts = prep_mount :: tool_mounts in
- let cmd = Printf.sprintf
- "eval $(opam env) && %s %s \
- --odoc-dir /home/opam/odoc-out \
- --html-dir /home/opam/html \
- --actions all -j $(nproc) -v --blessed \
- --odoc %s --odoc-md %s"
- voodoo_bin "astring" odoc_bin odoc_md_bin in
+ let cmd =
+ Printf.sprintf
+ "eval $(opam env) && %s %s --odoc-dir /home/opam/odoc-out --html-dir \
+ /home/opam/html --actions all -j $(nproc) -v --blessed --odoc %s \
+ --odoc-md %s"
+ voodoo_bin "astring" odoc_bin odoc_md_bin
+ in
let doc_node : Day11_opam_layer.Build.t =
- { hash = doc_hash; pkg = astring_pkg;
- deps = astring_build.deps @ [ astring_build ]; universe = Day11_solution.Universe.dummy } in
- let html_count = time "Doc gen astring (cold, single phase)" (fun () ->
- match Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:all_mounts
- doc_node ~strategy:{ cmd; cleanup = fun ~sw:_ _ _ -> () } () with
- | Day11_opam_build.Types.Success bl ->
- let dd = Day11_opam_layer.Build.dir ~os_dir bl in
- let find_run = Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "find" % Fpath.to_string Fpath.(dd / "fs")
- % "-name" % "*.html" % "-type" % "f") None in
- List.length (String.split_on_char '\n' (String.trim find_run.output)
- |> List.filter (fun s -> s <> ""))
- | _ -> 0) in
+ {
+ hash = doc_hash;
+ pkg = astring_pkg;
+ deps = astring_build.deps @ [ astring_build ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ let html_count =
+ time "Doc gen astring (cold, single phase)" (fun () ->
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[]
+ ~mounts:all_mounts doc_node
+ ~strategy:{ cmd; cleanup = (fun ~sw:_ _ _ -> ()) }
+ ()
+ with
+ | Day11_opam_build.Types.Success bl ->
+ let dd = Day11_opam_layer.Build.dir ~os_dir bl in
+ let find_run =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(
+ v "find"
+ % Fpath.to_string Fpath.(dd / "fs")
+ % "-name"
+ % "*.html"
+ % "-type"
+ % "f")
+ None
+ in
+ List.length
+ (String.split_on_char '\n' (String.trim find_run.output)
+ |> List.filter (fun s -> s <> ""))
+ | _ -> 0)
+ in
Printf.printf " → %d HTML files\n%!" html_count;
(* Cache hit *)
- ignore (time "Doc gen astring (cache hit)" (fun () ->
- Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[] ~mounts:all_mounts
- doc_node ~strategy:{ cmd; cleanup = fun ~sw:_ _ _ -> () } ()));
+ ignore
+ (time "Doc gen astring (cache hit)" (fun () ->
+ Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[]
+ ~mounts:all_mounts doc_node
+ ~strategy:{ cmd; cleanup = (fun ~sw:_ _ _ -> ()) }
+ ()));
ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir);
Printf.printf "\nDone.\n%!"
File "day11/benchmark/trial_run.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/benchmark/trial_run.ml b/_build/default/day11/benchmark/.formatted/trial_run.ml
index 37253c5..4e5fca6 100644
--- a/_build/default/day11/benchmark/trial_run.ml
+++ b/_build/default/day11/benchmark/.formatted/trial_run.ml
@@ -6,13 +6,13 @@
[--ocaml-version PKG] [--since DATE] [--until DATE]
[--np N] [--packages FILE | PKG1 PKG2 ...] *)
-let opam_repository = ref (
- try Sys.getenv "OPAM_REPOSITORY"
- with Not_found -> "/home/jjl25/opam-repository")
+let opam_repository =
+ ref
+ (try Sys.getenv "OPAM_REPOSITORY"
+ with Not_found -> "/home/jjl25/opam-repository")
-let scratch_cache = ref (
- try Sys.getenv "CACHE_DIR"
- with Not_found -> "/tmp/day11-trial")
+let scratch_cache =
+ ref (try Sys.getenv "CACHE_DIR" with Not_found -> "/tmp/day11-trial")
let ocaml_version_str = ref ""
let since = ref "2026-02-01"
@@ -21,33 +21,82 @@ let np = ref 4
let packages_file = ref ""
let extra_packages = ref []
-let default_packages = [
- "astring"; "fmt"; "fpath"; "rresult"; "bos"; "logs"; "cmdliner";
- "ptime"; "uutf"; "result"; "mtime"; "hmap"; "psq"; "cstruct";
- "bigstringaf"; "angstrom"; "domain-local-await"; "optint"; "topkg";
- "re"; "yojson"; "jsonm"; "ppxlib"; "sexplib0"; "base64"; "csexp";
- "lwt"; "eio"; "tyxml"; "brr"; "decompress"; "checkseum"; "cmarkit";
- "progress"; "terminal"; "js_of_ocaml"; "js_of_ocaml-compiler";
- "ocamlgraph"; "odoc"; "odoc-parser"; "sqlite3"; "syndic"; "ipaddr";
- "dns"; "cohttp"; "tls"; "mirage-crypto"; "zarith"; "num";
-]
+let default_packages =
+ [
+ "astring";
+ "fmt";
+ "fpath";
+ "rresult";
+ "bos";
+ "logs";
+ "cmdliner";
+ "ptime";
+ "uutf";
+ "result";
+ "mtime";
+ "hmap";
+ "psq";
+ "cstruct";
+ "bigstringaf";
+ "angstrom";
+ "domain-local-await";
+ "optint";
+ "topkg";
+ "re";
+ "yojson";
+ "jsonm";
+ "ppxlib";
+ "sexplib0";
+ "base64";
+ "csexp";
+ "lwt";
+ "eio";
+ "tyxml";
+ "brr";
+ "decompress";
+ "checkseum";
+ "cmarkit";
+ "progress";
+ "terminal";
+ "js_of_ocaml";
+ "js_of_ocaml-compiler";
+ "ocamlgraph";
+ "odoc";
+ "odoc-parser";
+ "sqlite3";
+ "syndic";
+ "ipaddr";
+ "dns";
+ "cohttp";
+ "tls";
+ "mirage-crypto";
+ "zarith";
+ "num";
+ ]
-let spec = [
- "--repo", Arg.Set_string opam_repository,
- "PATH opam-repository path (or OPAM_REPOSITORY env)";
- "--cache-dir", Arg.Set_string scratch_cache,
- "PATH cache directory (or CACHE_DIR env)";
- "--ocaml-version", Arg.Set_string ocaml_version_str,
- "PKG compiler version (e.g. ocaml-base-compiler.5.2.1 or ocaml-variants.5.2.0+ox)";
- "--since", Arg.Set_string since,
- "DATE start date for commits (default: 2026-02-01)";
- "--until", Arg.Set_string until,
- "DATE end date for commits (default: 2026-03-08)";
- "--np", Arg.Set_int np,
- "N number of parallel solver workers (default: 4)";
- "--packages", Arg.Set_string packages_file,
- "FILE file with one package name per line";
-]
+let spec =
+ [
+ ( "--repo",
+ Arg.Set_string opam_repository,
+ "PATH opam-repository path (or OPAM_REPOSITORY env)" );
+ ( "--cache-dir",
+ Arg.Set_string scratch_cache,
+ "PATH cache directory (or CACHE_DIR env)" );
+ ( "--ocaml-version",
+ Arg.Set_string ocaml_version_str,
+ "PKG compiler version (e.g. ocaml-base-compiler.5.2.1 or \
+ ocaml-variants.5.2.0+ox)" );
+ ( "--since",
+ Arg.Set_string since,
+ "DATE start date for commits (default: 2026-02-01)" );
+ ( "--until",
+ Arg.Set_string until,
+ "DATE end date for commits (default: 2026-03-08)" );
+ ("--np", Arg.Set_int np, "N number of parallel solver workers (default: 4)");
+ ( "--packages",
+ Arg.Set_string packages_file,
+ "FILE file with one package name per line" );
+ ]
let time name f =
let t0 = Unix.gettimeofday () in
@@ -57,78 +106,96 @@ let time name f =
result
let find_latest_version git_packages name =
- let versions = Day11_opam.Git_packages.get_versions git_packages
- (OpamPackage.Name.of_string name) in
+ let versions =
+ Day11_opam.Git_packages.get_versions git_packages
+ (OpamPackage.Name.of_string name)
+ in
let non_avoided =
- OpamPackage.Version.Map.filter (fun _v opam ->
- not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam)
- ) versions in
- let versions = if OpamPackage.Version.Map.is_empty non_avoided
- then versions else non_avoided in
+ OpamPackage.Version.Map.filter
+ (fun _v opam -> not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam))
+ versions
+ in
+ let versions =
+ if OpamPackage.Version.Map.is_empty non_avoided then versions
+ else non_avoided
+ in
match OpamPackage.Version.Map.max_binding_opt versions with
- | Some (v, _) ->
- Some (OpamPackage.create (OpamPackage.Name.of_string name) v)
+ | Some (v, _) -> Some (OpamPackage.create (OpamPackage.Name.of_string name) v)
| None -> None
let load_packages_from_file path =
let ic = open_in path in
let pkgs = ref [] in
- (try while true do
- let line = String.trim (input_line ic) in
- if line <> "" && not (String.starts_with ~prefix:"#" line) then
- pkgs := line :: !pkgs
- done with End_of_file -> ());
+ (try
+ while true do
+ let line = String.trim (input_line ic) in
+ if line <> "" && not (String.starts_with ~prefix:"#" line) then
+ pkgs := line :: !pkgs
+ done
+ with End_of_file -> ());
close_in ic;
List.rev !pkgs
let () =
- Arg.parse spec (fun s -> extra_packages := s :: !extra_packages)
+ Arg.parse spec
+ (fun s -> extra_packages := s :: !extra_packages)
"trial_run: simulate watching opam-repository";
let opam_repository = !opam_repository in
let scratch_cache = Fpath.v !scratch_cache in
let ocaml_version =
if !ocaml_version_str = "" then None
- else Some (OpamPackage.of_string !ocaml_version_str) in
+ else Some (OpamPackage.of_string !ocaml_version_str)
+ in
let package_names =
if !packages_file <> "" then load_packages_from_file !packages_file
else if !extra_packages <> [] then List.rev !extra_packages
- else default_packages in
+ else default_packages
+ in
let np = !np in
Bos.OS.Dir.set_default_tmp (Fpath.v (Filename.get_temp_dir_name ()));
Printf.printf "=== Trial run: %d packages across opam-repo commits ===\n"
(List.length package_names);
Printf.printf " repo: %s\n" opam_repository;
(match ocaml_version with
- | Some v -> Printf.printf " compiler: %s\n" (OpamPackage.to_string v)
- | None -> Printf.printf " compiler: latest ocaml-base-compiler >= 4.08\n");
+ | Some v -> Printf.printf " compiler: %s\n" (OpamPackage.to_string v)
+ | None -> Printf.printf " compiler: latest ocaml-base-compiler >= 4.08\n");
Printf.printf " range: %s to %s\n\n%!" !since !until;
- Eio_main.run @@ fun env -> Eio.Switch.run @@ fun sw ->
+ Eio_main.run @@ fun env ->
+ Eio.Switch.run @@ fun sw ->
let env = (env :> Eio_unix.Stdenv.base) in
(* Setup base image *)
- let base = match Day11_opam_build.Base.load_cached ~cache_dir:scratch_cache
- ~os_distribution:"debian" ~os_version:"bookworm" with
+ let base =
+ match
+ Day11_opam_build.Base.load_cached ~cache_dir:scratch_cache
+ ~os_distribution:"debian" ~os_version:"bookworm"
+ with
| Some b -> b
| None ->
- Printf.printf "Building base image...\n%!";
- Day11_opam_build.Base.build ~sw env ~cache_dir:scratch_cache
- ~os_distribution:"debian" ~os_version:"bookworm" ~arch:"x86_64"
- ~uid:(Unix.getuid ()) ~gid:(Unix.getgid ()) ()
- |> Result.get_ok
+ Printf.printf "Building base image...\n%!";
+ Day11_opam_build.Base.build ~sw env ~cache_dir:scratch_cache
+ ~os_distribution:"debian" ~os_version:"bookworm" ~arch:"x86_64"
+ ~uid:(Unix.getuid ()) ~gid:(Unix.getgid ()) ()
+ |> Result.get_ok
in
let os_dir = Fpath.(scratch_cache / "linux-x86_64") in
let benv = Day11_opam_build.Types.make_build_env ~base ~os_dir () in
Day11_opam_build.Types.ensure_dirs benv;
(* Get the store for loading packages at different commits *)
let store, head_commit =
- Day11_opam.Git_utils.get_git_repo_store_and_hash opam_repository in
+ Day11_opam.Git_utils.get_git_repo_store_and_hash opam_repository
+ in
let all_commits =
- let ic = Unix.open_process_in
- (Printf.sprintf "git -C %s log --format=%%H --since='%s' --until='%s'"
- opam_repository !since !until) in
+ let ic =
+ Unix.open_process_in
+ (Printf.sprintf "git -C %s log --format=%%H --since='%s' --until='%s'"
+ opam_repository !since !until)
+ in
let commits = ref [] in
- (try while true do
- commits := (input_line ic) :: !commits
- done with End_of_file -> ());
+ (try
+ while true do
+ commits := input_line ic :: !commits
+ done
+ with End_of_file -> ());
ignore (Unix.close_process_in ic);
List.rev !commits
in
@@ -143,125 +210,173 @@ let () =
let prev_solutions_dir = ref None in
let prev_changed = ref OpamPackage.Name.Set.empty in
(* Process each commit *)
- List.iteri (fun i commit_sha ->
- let short = String.sub commit_sha 0 12 in
- if (i + 1) mod 50 = 0 || i = 0 then
- Printf.printf "── Commit %d/%d: %s ──\n%!" (i + 1) (List.length sampled) short;
- let commit_hash =
- Day11_opam.Git_utils.resolve_commit_in_store store (Some commit_sha) in
- (* Load packages lazily *)
- let git_packages =
- Day11_opam.Git_packages.of_commit store commit_hash in
- (* Find latest versions *)
- let targets = List.filter_map (fun name ->
- find_latest_version git_packages name
- ) package_names in
- if (i + 1) mod 50 = 0 || i = 0 then
- Printf.printf " targets: %d/%d found\n%!" (List.length targets) (List.length package_names);
- (* Compute changed packages from previous commit *)
- let solutions_dir = Fpath.(scratch_cache / "solutions" / short) in
- Bos.OS.Dir.create ~path:true solutions_dir |> ignore;
- let changed, reused =
- match !prev_solutions_dir with
- | None -> (OpamPackage.Name.Set.empty, 0)
- | Some prev_dir ->
- let changed =
- if i > 0 then
- let prev_sha = List.nth sampled (i - 1) in
- let prev_hash = Day11_opam.Git_utils.resolve_commit_in_store
- store (Some prev_sha) in
- let changed_names = Day11_opam.Git_packages.diff_packages
- ~store prev_hash commit_hash in
- List.fold_left (fun s n -> OpamPackage.Name.Set.add n s)
- OpamPackage.Name.Set.empty changed_names
- else OpamPackage.Name.Set.empty
- in
- let target_strs = List.map OpamPackage.to_string targets in
- let reused = Day11_batch.Incremental_solver.reuse_solutions
- ~solutions_cache_dir:solutions_dir ~previous_dir:prev_dir
- ~changed_packages:changed ~packages:target_strs in
- (changed, reused)
- in
- let n_changed = OpamPackage.Name.Set.cardinal changed in
- if n_changed > 0 || reused < List.length targets then
- Printf.printf " [%d/%d] changed: %d, reused: %d, need solve: %d\n%!"
- (i + 1) (List.length sampled) n_changed reused
- (List.length targets - reused);
- prev_changed := changed;
- total_reused := !total_reused + reused;
- (* Solve remaining targets *)
- let need_solve = List.filter (fun target ->
- let cache_file = Fpath.(solutions_dir / (OpamPackage.to_string target ^ ".json")) in
- not (Sys.file_exists (Fpath.to_string cache_file))
- ) targets in
- let new_solutions = time (Printf.sprintf "solve %d packages" (List.length need_solve)) (fun () ->
- let results = Day11_solver_pool.Solver_pool.solve_many ~sw env
- ?ocaml_version ~np
- ~repos:[(opam_repository, commit_sha)] need_solve in
- List.filter_map (fun (target, result) ->
- match result with
- | Ok result ->
- let entry = Day11_batch.Incremental_solver.Cached_solution {
- package = target; result; cache_key = None } in
- ignore (Day11_batch.Incremental_solver.save
- Fpath.(solutions_dir / (OpamPackage.to_string target ^ ".json")) entry);
- Some (target, result.Day11_solution.Solve_result.build_deps)
- | Error (msg, _) ->
- Printf.printf " SOLVE FAIL: %s: %s\n%!"
- (OpamPackage.to_string target)
- (String.sub msg 0 (min 80 (String.length msg)));
- None
- ) results) in
- total_solves := !total_solves + List.length need_solve;
- (* Load all solutions (reused + new) *)
- let all_solutions = List.filter_map (fun target ->
- let cache_file = Fpath.(solutions_dir / (OpamPackage.to_string target ^ ".json")) in
- match Day11_batch.Incremental_solver.load cache_file with
- | Ok (Cached_solution { result; _ }) -> Some (target, result.build_deps)
- | _ -> None
- ) targets in
- ignore new_solutions;
- if List.length need_solve > 0 then
- Printf.printf " solutions: %d total (%d new)\n%!"
- (List.length all_solutions) (List.length new_solutions);
- (* Build DAG *)
- let find_opam = Day11_opam.Git_packages.find_package git_packages in
- let cache = Day11_opam_build.Hash_cache.create ~find_opam () in
- let nodes = Day11_opam_build.Dag.build_dag cache ~base_hash:base.hash
- (List.map (fun (t, d) -> (t, d, d)) all_solutions) in
- if List.length need_solve > 0 then
- Printf.printf " DAG: %d nodes\n%!" (List.length nodes);
- (* Build *)
- let built = ref 0 in
- let cached = ref 0 in
- let failed = ref 0 in
- time (Printf.sprintf "build %d nodes" (List.length nodes)) (fun () ->
- Day11_opam_build.Dag_executor.execute env ~np:4
- ~on_complete:(fun ~stats:_ ~cached:_ node success ->
- if success then begin
- let dir = Day11_opam_layer.Build.dir ~os_dir node in
- let layer_json = Fpath.(dir / "layer.json") in
- let is_cached = match Bos.OS.File.read layer_json with
- | Ok _ -> true | Error _ -> false in
- if is_cached then incr cached
- else incr built
- end else incr failed)
- ~on_cascade:(fun ~failed:_ ~failed_dep:_ -> incr failed)
- nodes
- (fun node ->
- match Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[] node () with
- | Day11_opam_build.Types.Success _ -> true
- | _ -> false));
- total_builds := !total_builds + !built;
- total_cache_hits := !total_cache_hits + !cached;
- if !built > 0 || !failed > 0 then
- Printf.printf " built: %d new, %d cached, %d failed\n%!"
- !built !cached !failed;
- prev_solutions_dir := Some solutions_dir
- ) sampled;
+ List.iteri
+ (fun i commit_sha ->
+ let short = String.sub commit_sha 0 12 in
+ if (i + 1) mod 50 = 0 || i = 0 then
+ Printf.printf "── Commit %d/%d: %s ──\n%!" (i + 1) (List.length sampled)
+ short;
+ let commit_hash =
+ Day11_opam.Git_utils.resolve_commit_in_store store (Some commit_sha)
+ in
+ (* Load packages lazily *)
+ let git_packages = Day11_opam.Git_packages.of_commit store commit_hash in
+ (* Find latest versions *)
+ let targets =
+ List.filter_map
+ (fun name -> find_latest_version git_packages name)
+ package_names
+ in
+ if (i + 1) mod 50 = 0 || i = 0 then
+ Printf.printf " targets: %d/%d found\n%!" (List.length targets)
+ (List.length package_names);
+ (* Compute changed packages from previous commit *)
+ let solutions_dir = Fpath.(scratch_cache / "solutions" / short) in
+ Bos.OS.Dir.create ~path:true solutions_dir |> ignore;
+ let changed, reused =
+ match !prev_solutions_dir with
+ | None -> (OpamPackage.Name.Set.empty, 0)
+ | Some prev_dir ->
+ let changed =
+ if i > 0 then
+ let prev_sha = List.nth sampled (i - 1) in
+ let prev_hash =
+ Day11_opam.Git_utils.resolve_commit_in_store store
+ (Some prev_sha)
+ in
+ let changed_names =
+ Day11_opam.Git_packages.diff_packages ~store prev_hash
+ commit_hash
+ in
+ List.fold_left
+ (fun s n -> OpamPackage.Name.Set.add n s)
+ OpamPackage.Name.Set.empty changed_names
+ else OpamPackage.Name.Set.empty
+ in
+ let target_strs = List.map OpamPackage.to_string targets in
+ let reused =
+ Day11_batch.Incremental_solver.reuse_solutions
+ ~solutions_cache_dir:solutions_dir ~previous_dir:prev_dir
+ ~changed_packages:changed ~packages:target_strs
+ in
+ (changed, reused)
+ in
+ let n_changed = OpamPackage.Name.Set.cardinal changed in
+ if n_changed > 0 || reused < List.length targets then
+ Printf.printf " [%d/%d] changed: %d, reused: %d, need solve: %d\n%!"
+ (i + 1) (List.length sampled) n_changed reused
+ (List.length targets - reused);
+ prev_changed := changed;
+ total_reused := !total_reused + reused;
+ (* Solve remaining targets *)
+ let need_solve =
+ List.filter
+ (fun target ->
+ let cache_file =
+ Fpath.(solutions_dir / (OpamPackage.to_string target ^ ".json"))
+ in
+ not (Sys.file_exists (Fpath.to_string cache_file)))
+ targets
+ in
+ let new_solutions =
+ time
+ (Printf.sprintf "solve %d packages" (List.length need_solve))
+ (fun () ->
+ let results =
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ?ocaml_version
+ ~np
+ ~repos:[ (opam_repository, commit_sha) ]
+ need_solve
+ in
+ List.filter_map
+ (fun (target, result) ->
+ match result with
+ | Ok result ->
+ let entry =
+ Day11_batch.Incremental_solver.Cached_solution
+ { package = target; result; cache_key = None }
+ in
+ ignore
+ (Day11_batch.Incremental_solver.save
+ Fpath.(
+ solutions_dir
+ / (OpamPackage.to_string target ^ ".json"))
+ entry);
+ Some (target, result.Day11_solution.Solve_result.build_deps)
+ | Error (msg, _) ->
+ Printf.printf " SOLVE FAIL: %s: %s\n%!"
+ (OpamPackage.to_string target)
+ (String.sub msg 0 (min 80 (String.length msg)));
+ None)
+ results)
+ in
+ total_solves := !total_solves + List.length need_solve;
+ (* Load all solutions (reused + new) *)
+ let all_solutions =
+ List.filter_map
+ (fun target ->
+ let cache_file =
+ Fpath.(solutions_dir / (OpamPackage.to_string target ^ ".json"))
+ in
+ match Day11_batch.Incremental_solver.load cache_file with
+ | Ok (Cached_solution { result; _ }) ->
+ Some (target, result.build_deps)
+ | _ -> None)
+ targets
+ in
+ ignore new_solutions;
+ if List.length need_solve > 0 then
+ Printf.printf " solutions: %d total (%d new)\n%!"
+ (List.length all_solutions)
+ (List.length new_solutions);
+ (* Build DAG *)
+ let find_opam = Day11_opam.Git_packages.find_package git_packages in
+ let cache = Day11_opam_build.Hash_cache.create ~find_opam () in
+ let nodes =
+ Day11_opam_build.Dag.build_dag cache ~base_hash:base.hash
+ (List.map (fun (t, d) -> (t, d, d)) all_solutions)
+ in
+ if List.length need_solve > 0 then
+ Printf.printf " DAG: %d nodes\n%!" (List.length nodes);
+ (* Build *)
+ let built = ref 0 in
+ let cached = ref 0 in
+ let failed = ref 0 in
+ time
+ (Printf.sprintf "build %d nodes" (List.length nodes))
+ (fun () ->
+ Day11_opam_build.Dag_executor.execute env ~np:4
+ ~on_complete:(fun ~stats:_ ~cached:_ node success ->
+ if success then
+ let dir = Day11_opam_layer.Build.dir ~os_dir node in
+ let layer_json = Fpath.(dir / "layer.json") in
+ let is_cached =
+ match Bos.OS.File.read layer_json with
+ | Ok _ -> true
+ | Error _ -> false
+ in
+ if is_cached then incr cached else incr built
+ else incr failed)
+ ~on_cascade:(fun ~failed:_ ~failed_dep:_ -> incr failed)
+ nodes
+ (fun node ->
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv
+ ~opam_repositories:[] node ()
+ with
+ | Day11_opam_build.Types.Success _ -> true
+ | _ -> false));
+ total_builds := !total_builds + !built;
+ total_cache_hits := !total_cache_hits + !cached;
+ if !built > 0 || !failed > 0 then
+ Printf.printf " built: %d new, %d cached, %d failed\n%!" !built !cached
+ !failed;
+ prev_solutions_dir := Some solutions_dir)
+ sampled;
ignore (head_commit, prev_changed);
Printf.printf "=== Summary ===\n";
Printf.printf " Commits processed: %d\n" (List.length sampled);
Printf.printf " Total solves: %d (reused: %d)\n" !total_solves !total_reused;
- Printf.printf " Total builds: %d (cache hits: %d)\n" !total_builds !total_cache_hits;
+ Printf.printf " Total builds: %d (cache hits: %d)\n" !total_builds
+ !total_cache_hits;
Printf.printf "Done.\n%!"
File "day11/container/test/test_build_package.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/container/test/test_build_package.ml b/_build/default/day11/container/test/.formatted/test_build_package.ml
index 35afdfb..6e65c0e 100644
--- a/_build/default/day11/container/test/test_build_package.ml
+++ b/_build/default/day11/container/test/.formatted/test_build_package.ml
@@ -12,19 +12,18 @@ let base_image = "ocaml/opam:debian-ocaml-5.2"
let ensure_base ~sw env ~cache_dir =
let base_dir = Fpath.(cache_dir / "base") in
let marker = Fpath.(base_dir / "fs" / "usr" / "bin" / "opam") in
- if Bos.OS.File.exists marker |> Result.get_ok then begin
+ if Bos.OS.File.exists marker |> Result.get_ok then (
Printf.printf "Base layer cached at %s\n%!" (Fpath.to_string base_dir);
- base_dir
- end else begin
+ base_dir)
+ else (
Printf.printf "Importing %s...\n%!" base_image;
Day11_layer.Import.from_docker ~sw env ~image:base_image ~layer_dir:base_dir
|> ok_or_fail "import base";
Printf.printf "Base layer imported to %s\n%!" (Fpath.to_string base_dir);
- base_dir
- end
+ base_dir)
-(** Build a package by running opam install inside a container on top
- of the given layers. Returns the upper dir (new layer fs). *)
+(** Build a package by running opam install inside a container on top of the
+ given layers. Returns the upper dir (new layer fs). *)
let build_package ~sw env ~cache_dir ~base_dir ~dep_layers ~pkg =
let hash =
Day11_layer.Hash.layer_hash
@@ -35,10 +34,10 @@ let build_package ~sw env ~cache_dir ~base_dir ~dep_layers ~pkg =
let layer_dir = Fpath.(cache_dir / ("build-" ^ String.sub hash 0 12)) in
let layer_json = Fpath.(layer_dir / "layer.json") in
(* Check cache *)
- if Bos.OS.File.exists layer_json |> Result.get_ok then begin
+ if Bos.OS.File.exists layer_json |> Result.get_ok then (
Printf.printf "Cache hit for %s (%s)\n%!" pkg (Fpath.to_string layer_dir);
- layer_dir
- end else begin
+ layer_dir)
+ else (
Printf.printf "Building %s...\n%!" pkg;
let temp_dir = Bos.OS.Dir.tmp "day11_build_%s" |> Result.get_ok in
let lower = Fpath.(temp_dir / "lower") in
@@ -47,36 +46,39 @@ let build_package ~sw env ~cache_dir ~base_dir ~dep_layers ~pkg =
let merged = Fpath.(temp_dir / "merged") in
List.iter mkdir [ lower; upper; work; merged ];
(* Stack base + dependency layers into lower *)
- Day11_layer.Stack.merge ~sw env
- ~layer_dirs:(base_dir :: dep_layers) ~target:lower
+ Day11_layer.Stack.merge ~sw env ~layer_dirs:(base_dir :: dep_layers)
+ ~target:lower
|> ok_or_fail "stack";
(* Mount overlay *)
- Day11_container.Overlay.mount ~sw env
- ~lower:[ lower ] ~upper ~work ~target:merged
+ Day11_container.Overlay.mount ~sw env ~lower:[ lower ] ~upper ~work
+ ~target:merged
|> ok_or_fail "overlay mount";
(* Figure out uid/gid from the base image's opam user *)
let uid = 1000 and gid = 1000 in
(* Generate OCI spec — run opam install with network for fetching *)
let spec =
- Day11_container.Oci_spec.make
- ~cwd:"/home/opam"
- ~hostname:"builder"
- ~env:[
- ("PATH", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin");
- ("HOME", "/home/opam");
- ("OPAMYES", "1");
- ("OPAMCONFIRMLEVEL", "unsafe-yes");
- ("OPAMERRLOGLEN", "0");
- ("OPAMPRECISETRACKING", "1");
- ]
+ Day11_container.Oci_spec.make ~cwd:"/home/opam" ~hostname:"builder"
+ ~env:
+ [
+ ( "PATH",
+ "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" );
+ ("HOME", "/home/opam");
+ ("OPAMYES", "1");
+ ("OPAMCONFIRMLEVEL", "unsafe-yes");
+ ("OPAMERRLOGLEN", "0");
+ ("OPAMPRECISETRACKING", "1");
+ ]
~network:true
- ~argv:[ "/usr/bin/env"; "bash"; "-c";
- Printf.sprintf "opam install -y %s" pkg ]
- ~uid ~gid
- ()
+ ~argv:
+ [
+ "/usr/bin/env";
+ "bash";
+ "-c";
+ Printf.sprintf "opam install -y %s" pkg;
+ ]
+ ~uid ~gid ()
in
- Day11_container.Oci_spec.write
- ~root:(Fpath.to_string merged) temp_dir spec
+ Day11_container.Oci_spec.write ~root:(Fpath.to_string merged) temp_dir spec
|> ok_or_fail "write spec";
let container_id =
Printf.sprintf "day11-build-%s-%d" pkg (Unix.getpid ())
@@ -95,54 +97,61 @@ let build_package ~sw env ~cache_dir ~base_dir ~dep_layers ~pkg =
| `Signaled n -> 128 + n
in
Printf.printf "Build %s: exit %d (%.1fs)\n%!" pkg exit_code run.time;
- if exit_code <> 0 then begin
+ if exit_code <> 0 then (
Printf.printf "STDOUT:\n%s\nSTDERR:\n%s\n" run.output run.errors;
Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
- Alcotest.fail (Printf.sprintf "%s build failed (exit %d)" pkg exit_code)
- end;
+ Alcotest.fail (Printf.sprintf "%s build failed (exit %d)" pkg exit_code));
(* Move upper dir to layer_dir/fs *)
mkdir layer_dir;
- let r = Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "mv" % Fpath.to_string upper
- % Fpath.to_string Fpath.(layer_dir / "fs")) in
+ let r =
+ Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "mv"
+ % Fpath.to_string upper
+ % Fpath.to_string Fpath.(layer_dir / "fs"))
+ in
(match r with Ok _ -> () | Error (`Msg e) -> Alcotest.fail e);
(* Write layer.json *)
- let meta : Day11_layer.Meta.t = {
- exit_status = exit_code;
- parent_hashes = [];
- uid = 1000; gid = 1000;
- base_hash = Day11_layer.Hash.base_hash ~image:base_image;
- disk_usage = 0;
- timing = Day11_layer.Meta.empty_timing;
- created_at = "";
- failed_dep = None;
- } in
- Day11_layer.Meta.save env
- Fpath.(layer_dir / "layer.json") meta
+ let meta : Day11_layer.Meta.t =
+ {
+ exit_status = exit_code;
+ parent_hashes = [];
+ uid = 1000;
+ gid = 1000;
+ base_hash = Day11_layer.Hash.base_hash ~image:base_image;
+ disk_usage = 0;
+ timing = Day11_layer.Meta.empty_timing;
+ created_at = "";
+ failed_dep = None;
+ }
+ in
+ Day11_layer.Meta.save env Fpath.(layer_dir / "layer.json") meta
|> ok_or_fail "save layer meta";
(* Write build.json sidecar *)
- let bm : Day11_opam_layer.Build_meta.t = {
- package = pkg;
- deps = [];
- stack = [];
- installed_libs = [];
- installed_docs = [];
- patches = [];
- base_image = "";
- cmd = "";
- universe = "";
- } in
+ let bm : Day11_opam_layer.Build_meta.t =
+ {
+ package = pkg;
+ deps = [];
+ stack = [];
+ installed_libs = [];
+ installed_docs = [];
+ patches = [];
+ base_image = "";
+ cmd = "";
+ universe = "";
+ }
+ in
Day11_opam_layer.Build_meta.save layer_dir bm
|> ok_or_fail "save build meta";
(* Clean up temp dir *)
Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
Printf.printf "Layer for %s at %s\n%!" pkg (Fpath.to_string layer_dir);
- layer_dir
- end
+ layer_dir)
(* ── Tests ───────────────────────────────────────────────────────── *)
-let test_build_astring () = with_eio @@ fun ~sw env ->
+let test_build_astring () =
+ with_eio @@ fun ~sw env ->
let cache_dir = Fpath.v "/tmp/day11-integration-cache" in
mkdir cache_dir;
let base_dir = ensure_base ~sw env ~cache_dir in
@@ -154,39 +163,54 @@ let test_build_astring () = with_eio @@ fun ~sw env ->
differ from our uid. Use sudo to list files for verification. *)
let ls_run =
Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "sudo" % "find"
- % Fpath.to_string Fpath.(astring_layer / "fs" / "home" / "opam"
- / ".opam" / "5.2" / "lib" / "astring")
- % "-type" % "f" % "-name" % "*.cmi")
+ Bos.Cmd.(
+ v "sudo"
+ % "find"
+ % Fpath.to_string
+ Fpath.(
+ astring_layer
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / "5.2"
+ / "lib"
+ / "astring")
+ % "-type"
+ % "f"
+ % "-name"
+ % "*.cmi")
None
in
let cmi_files = String.trim ls_run.output in
Printf.printf "astring .cmi files:\n%s\n%!" cmi_files;
- Alcotest.(check bool) "has astring .cmi files"
- true (String.length cmi_files > 0);
+ Alcotest.(check bool)
+ "has astring .cmi files" true
+ (String.length cmi_files > 0);
(* Also verify scan_libs works when we can read the files
(fix permissions for non-sudo scanning) *)
- let _ = Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "chmod" % "-R" % "a+rX"
- % Fpath.to_string Fpath.(astring_layer / "fs")) in
- let installed = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:astring_layer in
- Printf.printf "Installed lib files after chmod: %d\n%!" (List.length installed);
- List.iter (fun f -> Printf.printf " %s\n%!" f)
+ let _ =
+ Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "chmod" % "-R" % "a+rX" % Fpath.to_string Fpath.(astring_layer / "fs"))
+ in
+ let installed =
+ Day11_opam_layer.Installed_files.scan_libs ~layer_dir:astring_layer
+ in
+ Printf.printf "Installed lib files after chmod: %d\n%!"
+ (List.length installed);
+ List.iter
+ (fun f -> Printf.printf " %s\n%!" f)
(List.filteri (fun i _ -> i < 10) installed);
- Alcotest.(check bool) "scan_libs finds astring"
- true (List.exists (fun f ->
- Astring.String.is_prefix ~affix:"astring" f) installed)
+ Alcotest.(check bool)
+ "scan_libs finds astring" true
+ (List.exists
+ (fun f -> Astring.String.is_prefix ~affix:"astring" f)
+ installed)
let () =
if not (is_integration ()) then
- Printf.printf
- "Skipping build tests (set DAY11_INTEGRATION=true to run)\n"
+ Printf.printf "Skipping build tests (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_build_package"
- [
- ( "Build",
- [
- Alcotest.test_case "astring" `Slow test_build_astring;
- ] );
- ]
+ [ ("Build", [ Alcotest.test_case "astring" `Slow test_build_astring ]) ]
File "day11/container/test/test_container.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/container/test/test_container.ml b/_build/default/day11/container/test/.formatted/test_container.ml
index ceb2347..b46c9be 100644
--- a/_build/default/day11/container/test/test_container.ml
+++ b/_build/default/day11/container/test/.formatted/test_container.ml
@@ -10,65 +10,57 @@ open Day11_test_util.Test_util
(* ── Helpers ─────────────────────────────────────────────────────── *)
let is_ok msg r = ok_or_fail msg r |> ignore
-
-let json_member key json =
- Yojson.Safe.Util.member key json
-
-let json_to_string json =
- Yojson.Safe.Util.to_string json
-
-let json_to_bool json =
- Yojson.Safe.Util.to_bool json
-
-let json_to_int json =
- Yojson.Safe.Util.to_int json
-
-let json_to_list json =
- Yojson.Safe.Util.to_list json
+let json_member key json = Yojson.Safe.Util.member key json
+let json_to_string json = Yojson.Safe.Util.to_string json
+let json_to_bool json = Yojson.Safe.Util.to_bool json
+let json_to_int json = Yojson.Safe.Util.to_int json
+let json_to_list json = Yojson.Safe.Util.to_list json
(* ── Mount tests ─────────────────────────────────────────────────── *)
let test_mount_to_json () =
let m : Mount.t =
- { ty = "bind"; src = "/host/path"; dst = "/container/path";
- options = [ "ro"; "rbind" ] }
+ {
+ ty = "bind";
+ src = "/host/path";
+ dst = "/container/path";
+ options = [ "ro"; "rbind" ];
+ }
in
let json = Mount.to_json m in
- Alcotest.(check string) "destination"
- "/container/path" (json |> json_member "destination" |> json_to_string);
- Alcotest.(check string) "type"
- "bind" (json |> json_member "type" |> json_to_string);
- Alcotest.(check string) "source"
- "/host/path" (json |> json_member "source" |> json_to_string);
- let opts = json |> json_member "options" |> json_to_list
- |> List.map json_to_string in
+ Alcotest.(check string)
+ "destination" "/container/path"
+ (json |> json_member "destination" |> json_to_string);
+ Alcotest.(check string)
+ "type" "bind"
+ (json |> json_member "type" |> json_to_string);
+ Alcotest.(check string)
+ "source" "/host/path"
+ (json |> json_member "source" |> json_to_string);
+ let opts =
+ json |> json_member "options" |> json_to_list |> List.map json_to_string
+ in
Alcotest.(check (list string)) "options" [ "ro"; "rbind" ] opts
let test_mount_bind_ro () =
let m = Mount.bind_ro ~src:"/host" "/container" in
Alcotest.(check string) "ty" "bind" m.ty;
- Alcotest.(check bool) "has ro"
- true (List.mem "ro" m.options)
+ Alcotest.(check bool) "has ro" true (List.mem "ro" m.options)
let test_mount_bind_rw () =
let m = Mount.bind_rw ~src:"/host" "/container" in
Alcotest.(check string) "ty" "bind" m.ty;
- Alcotest.(check bool) "no ro"
- false (List.mem "ro" m.options);
- Alcotest.(check bool) "has rw"
- true (List.mem "rw" m.options)
+ Alcotest.(check bool) "no ro" false (List.mem "ro" m.options);
+ Alcotest.(check bool) "has rw" true (List.mem "rw" m.options)
(* ── Oci_spec tests ──────────────────────────────────────────────── *)
let make_basic_spec ?(network = false) () =
- Oci_spec.make
- ~cwd:"/home/opam"
- ~hostname:"builder"
+ Oci_spec.make ~cwd:"/home/opam" ~hostname:"builder"
~env:[ ("PATH", "/usr/bin"); ("HOME", "/home/opam") ]
~network
~argv:[ "sh"; "-c"; "echo hello" ]
- ~uid:1000 ~gid:1000
- ()
+ ~uid:1000 ~gid:1000 ()
(* Helper to convert a spec to the JSON form used by the older tests
that inspected the JSON directly. *)
@@ -77,146 +69,153 @@ let spec_to_json spec = Oci_spec.to_yojson ~root:"/rootfs" spec
let test_oci_spec_basic () =
let spec = spec_to_json (make_basic_spec ()) in
(* Check ociVersion *)
- Alcotest.(check bool) "has ociVersion"
- true (json_member "ociVersion" spec <> `Null);
+ Alcotest.(check bool)
+ "has ociVersion" true
+ (json_member "ociVersion" spec <> `Null);
(* Check process *)
let process = json_member "process" spec in
- Alcotest.(check bool) "terminal false"
- false (process |> json_member "terminal" |> json_to_bool);
+ Alcotest.(check bool)
+ "terminal false" false
+ (process |> json_member "terminal" |> json_to_bool);
let user = json_member "user" process in
Alcotest.(check int) "uid" 1000 (user |> json_member "uid" |> json_to_int);
Alcotest.(check int) "gid" 1000 (user |> json_member "gid" |> json_to_int);
(* Check argv *)
- let args = process |> json_member "args" |> json_to_list
- |> List.map json_to_string in
- Alcotest.(check (list string)) "argv"
- [ "sh"; "-c"; "echo hello" ] args;
+ let args =
+ process |> json_member "args" |> json_to_list |> List.map json_to_string
+ in
+ Alcotest.(check (list string)) "argv" [ "sh"; "-c"; "echo hello" ] args;
(* Check root *)
let root = json_member "root" spec in
- Alcotest.(check string) "root path"
- "/rootfs" (root |> json_member "path" |> json_to_string);
+ Alcotest.(check string)
+ "root path" "/rootfs"
+ (root |> json_member "path" |> json_to_string);
(* Check hostname *)
- Alcotest.(check string) "hostname"
- "builder" (spec |> json_member "hostname" |> json_to_string)
+ Alcotest.(check string)
+ "hostname" "builder"
+ (spec |> json_member "hostname" |> json_to_string)
let test_oci_spec_env () =
let spec = spec_to_json (make_basic_spec ()) in
let process = json_member "process" spec in
- let env = process |> json_member "env" |> json_to_list
- |> List.map json_to_string in
- Alcotest.(check bool) "has PATH"
- true (List.mem "PATH=/usr/bin" env);
- Alcotest.(check bool) "has HOME"
- true (List.mem "HOME=/home/opam" env)
+ let env =
+ process |> json_member "env" |> json_to_list |> List.map json_to_string
+ in
+ Alcotest.(check bool) "has PATH" true (List.mem "PATH=/usr/bin" env);
+ Alcotest.(check bool) "has HOME" true (List.mem "HOME=/home/opam" env)
let test_oci_spec_seccomp () =
let spec = spec_to_json (make_basic_spec ()) in
let linux = json_member "linux" spec in
let seccomp = json_member "seccomp" linux in
- Alcotest.(check string) "default action"
- "SCMP_ACT_ALLOW"
+ Alcotest.(check string)
+ "default action" "SCMP_ACT_ALLOW"
(seccomp |> json_member "defaultAction" |> json_to_string);
(* Check that fsync is intercepted *)
let syscalls = seccomp |> json_member "syscalls" |> json_to_list in
- Alcotest.(check bool) "has syscall rules"
- true (List.length syscalls > 0);
+ Alcotest.(check bool) "has syscall rules" true (List.length syscalls > 0);
let rule = List.hd syscalls in
- let names = rule |> json_member "names" |> json_to_list
- |> List.map json_to_string in
- Alcotest.(check bool) "has fsync"
- true (List.mem "fsync" names);
- Alcotest.(check string) "action"
- "SCMP_ACT_ERRNO"
+ let names =
+ rule |> json_member "names" |> json_to_list |> List.map json_to_string
+ in
+ Alcotest.(check bool) "has fsync" true (List.mem "fsync" names);
+ Alcotest.(check string)
+ "action" "SCMP_ACT_ERRNO"
(rule |> json_member "action" |> json_to_string)
let test_oci_spec_network_disabled () =
let spec = spec_to_json (make_basic_spec ~network:false ()) in
let linux = json_member "linux" spec in
let namespaces = linux |> json_member "namespaces" |> json_to_list in
- let ns_types = List.map (fun ns ->
- ns |> json_member "type" |> json_to_string) namespaces in
- Alcotest.(check bool) "has network ns"
- true (List.mem "network" ns_types);
+ let ns_types =
+ List.map (fun ns -> ns |> json_member "type" |> json_to_string) namespaces
+ in
+ Alcotest.(check bool) "has network ns" true (List.mem "network" ns_types);
(* No resolv.conf mount *)
let mounts = spec |> json_member "mounts" |> json_to_list in
- let mount_dsts = List.map (fun m ->
- m |> json_member "destination" |> json_to_string) mounts in
- Alcotest.(check bool) "no resolv.conf"
- false (List.mem "/etc/resolv.conf" mount_dsts)
+ let mount_dsts =
+ List.map (fun m -> m |> json_member "destination" |> json_to_string) mounts
+ in
+ Alcotest.(check bool)
+ "no resolv.conf" false
+ (List.mem "/etc/resolv.conf" mount_dsts)
let test_oci_spec_network_enabled () =
let spec = spec_to_json (make_basic_spec ~network:true ()) in
let linux = json_member "linux" spec in
let namespaces = linux |> json_member "namespaces" |> json_to_list in
- let ns_types = List.map (fun ns ->
- ns |> json_member "type" |> json_to_string) namespaces in
+ let ns_types =
+ List.map (fun ns -> ns |> json_member "type" |> json_to_string) namespaces
+ in
(* No network namespace when networking enabled *)
- Alcotest.(check bool) "no network ns"
- false (List.mem "network" ns_types);
+ Alcotest.(check bool) "no network ns" false (List.mem "network" ns_types);
(* Has resolv.conf bind mount *)
let mounts = spec |> json_member "mounts" |> json_to_list in
- let mount_dsts = List.map (fun m ->
- m |> json_member "destination" |> json_to_string) mounts in
- Alcotest.(check bool) "has resolv.conf"
- true (List.mem "/etc/resolv.conf" mount_dsts)
+ let mount_dsts =
+ List.map (fun m -> m |> json_member "destination" |> json_to_string) mounts
+ in
+ Alcotest.(check bool)
+ "has resolv.conf" true
+ (List.mem "/etc/resolv.conf" mount_dsts)
let test_oci_spec_with_mounts () =
let user_mount = Mount.bind_ro ~src:"/host/repo" "/opam-repo" in
- let spec = spec_to_json (
- Oci_spec.make
- ~hostname:"test" ~mounts:[ user_mount ]
- ~argv:[ "true" ]
- ~uid:0 ~gid:0
- ())
+ let spec =
+ spec_to_json
+ (Oci_spec.make ~hostname:"test" ~mounts:[ user_mount ] ~argv:[ "true" ]
+ ~uid:0 ~gid:0 ())
in
let mounts = spec |> json_member "mounts" |> json_to_list in
- let mount_dsts = List.map (fun m ->
- m |> json_member "destination" |> json_to_string) mounts in
+ let mount_dsts =
+ List.map (fun m -> m |> json_member "destination" |> json_to_string) mounts
+ in
(* User mount should be first *)
- Alcotest.(check bool) "has user mount"
- true (List.mem "/opam-repo" mount_dsts);
+ Alcotest.(check bool) "has user mount" true (List.mem "/opam-repo" mount_dsts);
(* System mounts should follow *)
- Alcotest.(check bool) "has /proc"
- true (List.mem "/proc" mount_dsts)
+ Alcotest.(check bool) "has /proc" true (List.mem "/proc" mount_dsts)
let test_oci_spec_capabilities () =
let spec = spec_to_json (make_basic_spec ()) in
let process = json_member "process" spec in
let caps = json_member "capabilities" process in
- let bounding = caps |> json_member "bounding" |> json_to_list
- |> List.map json_to_string in
- Alcotest.(check bool) "has CAP_CHOWN"
- true (List.mem "CAP_CHOWN" bounding);
- Alcotest.(check bool) "has CAP_SYS_CHROOT"
- true (List.mem "CAP_SYS_CHROOT" bounding)
+ let bounding =
+ caps |> json_member "bounding" |> json_to_list |> List.map json_to_string
+ in
+ Alcotest.(check bool) "has CAP_CHOWN" true (List.mem "CAP_CHOWN" bounding);
+ Alcotest.(check bool)
+ "has CAP_SYS_CHROOT" true
+ (List.mem "CAP_SYS_CHROOT" bounding)
let test_oci_spec_terminal () =
- let spec = spec_to_json (
- Oci_spec.make
- ~terminal:true ~hostname:"debug" ~network:true
- ~argv:[ "/bin/bash" ]
- ~uid:1000 ~gid:1000
- ())
+ let spec =
+ spec_to_json
+ (Oci_spec.make ~terminal:true ~hostname:"debug" ~network:true
+ ~argv:[ "/bin/bash" ] ~uid:1000 ~gid:1000 ())
in
let process = json_member "process" spec in
- Alcotest.(check bool) "terminal true"
- true (process |> json_member "terminal" |> json_to_bool)
+ Alcotest.(check bool)
+ "terminal true" true
+ (process |> json_member "terminal" |> json_to_bool)
(* ── Oci_spec.write tests ────────────────────────────────────────── *)
-let test_write_spec () = with_tmp_dir @@ fun dir ->
+let test_write_spec () =
+ with_tmp_dir @@ fun dir ->
let spec = make_basic_spec () in
Oci_spec.write ~root:"/rootfs" dir spec |> is_ok "write";
let config_path = Fpath.(dir / "config.json") in
- Alcotest.(check bool) "config.json exists"
- true (Bos.OS.File.exists config_path |> Result.get_ok);
+ Alcotest.(check bool)
+ "config.json exists" true
+ (Bos.OS.File.exists config_path |> Result.get_ok);
(* Verify it's valid JSON *)
let content = Bos.OS.File.read config_path |> Result.get_ok in
let parsed = Yojson.Safe.from_string content in
- Alcotest.(check bool) "valid JSON"
- true (json_member "ociVersion" parsed <> `Null)
+ Alcotest.(check bool)
+ "valid JSON" true
+ (json_member "ociVersion" parsed <> `Null)
-let test_write_template () = with_tmp_dir @@ fun dir ->
+let test_write_template () =
+ with_tmp_dir @@ fun dir ->
let spec = make_basic_spec () in
let path = Fpath.(dir / "config.json") in
Oci_spec.write_template path spec |> is_ok "write_template";
@@ -224,8 +223,8 @@ let test_write_template () = with_tmp_dir @@ fun dir ->
let parsed = Yojson.Safe.from_string content in
let root = json_member "root" parsed in
let path_field = json_member "path" root in
- Alcotest.(check string) "rootfs is placeholder"
- Oci_spec.placeholder_root
+ Alcotest.(check string)
+ "rootfs is placeholder" Oci_spec.placeholder_root
(match path_field with `String s -> s | _ -> "")
(* Instantiating a template must reproduce exactly what a direct
@@ -236,14 +235,14 @@ let test_instantiate_template () =
let spec = make_basic_spec () in
let templated = Oci_spec.to_yojson ~root:Oci_spec.placeholder_root spec in
let instantiated =
- Oci_spec.instantiate_template ~root:"/run/rootfs" templated
- |> Result.get_ok in
+ Oci_spec.instantiate_template ~root:"/run/rootfs" templated |> Result.get_ok
+ in
let direct = Oci_spec.to_yojson ~root:"/run/rootfs" spec in
- Alcotest.(check bool) "instantiated template equals direct to_yojson"
- true (instantiated = direct);
- let root_path =
- json_member "root" instantiated |> json_member "path" in
- Alcotest.(check string) "root substituted" "/run/rootfs"
+ Alcotest.(check bool)
+ "instantiated template equals direct to_yojson" true (instantiated = direct);
+ let root_path = json_member "root" instantiated |> json_member "path" in
+ Alcotest.(check string)
+ "root substituted" "/run/rootfs"
(match root_path with `String s -> s | _ -> "")
let test_instantiate_template_rejects_non_template () =
@@ -251,23 +250,27 @@ let test_instantiate_template_rejects_non_template () =
(* An already-instantiated spec (real root, not the placeholder)
must be rejected rather than silently mangled. *)
let concrete = Oci_spec.to_yojson ~root:"/real/rootfs" spec in
- Alcotest.(check bool) "non-template rejected"
- true (Result.is_error (Oci_spec.instantiate_template ~root:"/x" concrete))
+ Alcotest.(check bool)
+ "non-template rejected" true
+ (Result.is_error (Oci_spec.instantiate_template ~root:"/x" concrete))
-let test_instantiate_template_file () = with_tmp_dir @@ fun dir ->
+let test_instantiate_template_file () =
+ with_tmp_dir @@ fun dir ->
let spec = make_basic_spec () in
let template = Fpath.(dir / "template.json") in
Oci_spec.write_template template spec |> is_ok "write_template";
let bundle = Fpath.(dir / "bundle") in
Bos.OS.Dir.create ~path:true bundle |> Result.get_ok |> ignore;
- Oci_spec.instantiate_template_file
- ~template ~root:"/run/rootfs" ~bundle_dir:bundle
+ Oci_spec.instantiate_template_file ~template ~root:"/run/rootfs"
+ ~bundle_dir:bundle
|> is_ok "instantiate_template_file";
- let content = Bos.OS.File.read Fpath.(bundle / "config.json")
- |> Result.get_ok in
+ let content =
+ Bos.OS.File.read Fpath.(bundle / "config.json") |> Result.get_ok
+ in
let parsed = Yojson.Safe.from_string content in
let root_path = json_member "root" parsed |> json_member "path" in
- Alcotest.(check string) "bundle root substituted" "/run/rootfs"
+ Alcotest.(check string)
+ "bundle root substituted" "/run/rootfs"
(match root_path with `String s -> s | _ -> "")
(* ── Test registration ───────────────────────────────────────────── *)
@@ -290,17 +293,15 @@ let () =
test_oci_spec_network_disabled;
Alcotest.test_case "network enabled" `Quick
test_oci_spec_network_enabled;
- Alcotest.test_case "with mounts" `Quick
- test_oci_spec_with_mounts;
- Alcotest.test_case "capabilities" `Quick
- test_oci_spec_capabilities;
+ Alcotest.test_case "with mounts" `Quick test_oci_spec_with_mounts;
+ Alcotest.test_case "capabilities" `Quick test_oci_spec_capabilities;
Alcotest.test_case "terminal" `Quick test_oci_spec_terminal;
Alcotest.test_case "write" `Quick test_write_spec;
Alcotest.test_case "write_template" `Quick test_write_template;
Alcotest.test_case "instantiate_template" `Quick
test_instantiate_template;
- Alcotest.test_case "instantiate_template rejects non-template"
- `Quick test_instantiate_template_rejects_non_template;
+ Alcotest.test_case "instantiate_template rejects non-template" `Quick
+ test_instantiate_template_rejects_non_template;
Alcotest.test_case "instantiate_template_file" `Quick
test_instantiate_template_file;
] );
File "day11/container/test/test_integration.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/container/test/test_integration.ml b/_build/default/day11/container/test/.formatted/test_integration.ml
index 85a31ac..f8fa906 100644
--- a/_build/default/day11/container/test/test_integration.ml
+++ b/_build/default/day11/container/test/.formatted/test_integration.ml
@@ -8,26 +8,28 @@ open Day11_test_util.Test_util
let with_tmp_dir f =
let dir = Bos.OS.Dir.tmp "day11_integ_%s" |> Result.get_ok in
- Fun.protect ~finally:(fun () ->
- (* sudo rm because the container may create root-owned files *)
- Eio_main.run @@ fun env ->
- Eio.Switch.run @@ fun sw ->
- ignore (Day11_sys.Sudo.rm_rf ~sw
- (env :> Eio_unix.Stdenv.base) dir))
+ Fun.protect
+ ~finally:(fun () ->
+ (* sudo rm because the container may create root-owned files *)
+ Eio_main.run @@ fun env ->
+ Eio.Switch.run @@ fun sw ->
+ ignore (Day11_sys.Sudo.rm_rf ~sw (env :> Eio_unix.Stdenv.base) dir))
(fun () -> f dir)
(** Create a minimal rootfs with busybox *)
let create_rootfs rootfs =
let busybox = "/usr/bin/busybox" in
- if not (Sys.file_exists busybox) then
- Alcotest.fail "busybox not found";
+ if not (Sys.file_exists busybox) then Alcotest.fail "busybox not found";
(* Minimal directory structure *)
- List.iter (fun d -> mkdir Fpath.(rootfs / d))
+ List.iter
+ (fun d -> mkdir Fpath.(rootfs / d))
[ "bin"; "proc"; "tmp"; "dev"; "sys"; "etc" ];
(* Copy busybox and create sh symlink *)
let bb_dst = Fpath.(rootfs / "bin" / "busybox") in
- Bos.OS.File.read (Fpath.v busybox) |> Result.get_ok
- |> Bos.OS.File.write bb_dst |> Result.get_ok;
+ Bos.OS.File.read (Fpath.v busybox)
+ |> Result.get_ok
+ |> Bos.OS.File.write bb_dst
+ |> Result.get_ok;
Unix.chmod (Fpath.to_string bb_dst) 0o755;
Unix.symlink "busybox" (Fpath.to_string Fpath.(rootfs / "bin" / "sh"));
Unix.symlink "busybox" (Fpath.to_string Fpath.(rootfs / "bin" / "echo"));
@@ -36,18 +38,17 @@ let create_rootfs rootfs =
(* ── Tests ───────────────────────────────────────────────────────── *)
-let test_runc_echo () = with_eio @@ fun ~sw env ->
+let test_runc_echo () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
let rootfs = Fpath.(dir / "rootfs") in
create_rootfs rootfs;
(* Generate OCI spec *)
let spec =
- Oci_spec.make
- ~hostname:"test"
+ Oci_spec.make ~hostname:"test"
~env:[ ("PATH", "/bin") ]
~argv:[ "/bin/echo"; "hello from container" ]
- ~uid:0 ~gid:0
- ()
+ ~uid:0 ~gid:0 ()
in
Oci_spec.write ~root:(Fpath.to_string rootfs) dir spec
|> ok_or_fail "write_spec";
@@ -56,17 +57,17 @@ let test_runc_echo () = with_eio @@ fun ~sw env ->
(* Clean up any stale container *)
ignore (Runc.delete ~sw env container_id);
let run =
- Runc.run ~sw env ~bundle:dir ~container_id
- |> ok_or_fail "runc run"
+ Runc.run ~sw env ~bundle:dir ~container_id |> ok_or_fail "runc run"
in
ignore (Runc.delete ~sw env container_id);
- Alcotest.(check bool) "exit 0"
- true (run.Day11_sys.Run.status = `Exited 0);
- Alcotest.(check bool) "output contains hello"
- true (String.trim run.output = "hello from container"
- || String.trim run.errors = "hello from container")
+ Alcotest.(check bool) "exit 0" true (run.Day11_sys.Run.status = `Exited 0);
+ Alcotest.(check bool)
+ "output contains hello" true
+ (String.trim run.output = "hello from container"
+ || String.trim run.errors = "hello from container")
-let test_overlay_and_runc () = with_eio @@ fun ~sw env ->
+let test_overlay_and_runc () =
+ with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
(* Create a base rootfs as "layer 0" *)
let base_layer = Fpath.(dir / "base") in
@@ -79,15 +80,16 @@ let test_overlay_and_runc () = with_eio @@ fun ~sw env ->
(* Stack layers into lower dir *)
let lower = Fpath.(dir / "lower") in
mkdir lower;
- Day11_layer.Stack.merge ~sw env ~layer_dirs:[ base_layer; layer1 ] ~target:lower
+ Day11_layer.Stack.merge ~sw env ~layer_dirs:[ base_layer; layer1 ]
+ ~target:lower
|> ok_or_fail "stack";
(* Verify stacking worked *)
- Alcotest.(check bool) "busybox in lower"
- true (Bos.OS.File.exists Fpath.(lower / "bin" / "busybox")
- |> Result.get_ok);
- Alcotest.(check bool) "greeting in lower"
- true (Bos.OS.File.exists Fpath.(lower / "etc" / "greeting")
- |> Result.get_ok);
+ Alcotest.(check bool)
+ "busybox in lower" true
+ (Bos.OS.File.exists Fpath.(lower / "bin" / "busybox") |> Result.get_ok);
+ Alcotest.(check bool)
+ "greeting in lower" true
+ (Bos.OS.File.exists Fpath.(lower / "etc" / "greeting") |> Result.get_ok);
(* Set up overlay *)
let upper = Fpath.(dir / "upper") in
let work = Fpath.(dir / "work") in
@@ -97,49 +99,47 @@ let test_overlay_and_runc () = with_eio @@ fun ~sw env ->
|> ok_or_fail "overlay mount";
(* Generate OCI spec using the overlay as rootfs *)
let spec =
- Oci_spec.make
- ~hostname:"test"
+ Oci_spec.make ~hostname:"test"
~env:[ ("PATH", "/bin") ]
~argv:[ "/bin/cat"; "/etc/greeting" ]
- ~uid:0 ~gid:0
- ()
+ ~uid:0 ~gid:0 ()
in
Oci_spec.write ~root:(Fpath.to_string merged) dir spec
|> ok_or_fail "write_spec";
let container_id = "day11-overlay-" ^ string_of_int (Unix.getpid ()) in
ignore (Runc.delete ~sw env container_id);
let run =
- Runc.run ~sw env ~bundle:dir ~container_id
- |> ok_or_fail "runc run"
+ Runc.run ~sw env ~bundle:dir ~container_id |> ok_or_fail "runc run"
in
(* Cleanup *)
ignore (Runc.delete ~sw env container_id);
ignore (Overlay.umount ~sw env merged);
- Alcotest.(check bool) "exit 0"
- true (run.Day11_sys.Run.status = `Exited 0);
- Alcotest.(check bool) "reads layer1 content"
- true (String.trim run.output = "hello from layer1"
- || String.trim run.errors = "hello from layer1")
+ Alcotest.(check bool) "exit 0" true (run.Day11_sys.Run.status = `Exited 0);
+ Alcotest.(check bool)
+ "reads layer1 content" true
+ (String.trim run.output = "hello from layer1"
+ || String.trim run.errors = "hello from layer1")
(* ── Hybrid lowerdir plan ─────────────────────────────────────────── *)
-(** Create [n] fake "dep" layer dirs. Each one has [fs/data/<i>.txt]
- with content ["payload-<i>"], so we can verify the merged view
- contains data from every layer. The base layer provides /bin/cat
- and a /data directory we can append into. *)
+(** Create [n] fake "dep" layer dirs. Each one has [fs/data/<i>.txt] with
+ content ["payload-<i>"], so we can verify the merged view contains data from
+ every layer. The base layer provides /bin/cat and a /data directory we can
+ append into. *)
let make_dep_layers parent_dir n =
List.init n (fun i ->
- let layer_dir = Fpath.(parent_dir / Printf.sprintf "dep-%03d" i) in
- let fs = Fpath.(layer_dir / "fs") in
- let data = Fpath.(fs / "data") in
- mkdir data;
- write_file Fpath.(data / Printf.sprintf "%03d.txt" i)
- (Printf.sprintf "payload-%d" i);
- layer_dir)
+ let layer_dir = Fpath.(parent_dir / Printf.sprintf "dep-%03d" i) in
+ let fs = Fpath.(layer_dir / "fs") in
+ let data = Fpath.(fs / "data") in
+ mkdir data;
+ write_file
+ Fpath.(data / Printf.sprintf "%03d.txt" i)
+ (Printf.sprintf "payload-%d" i);
+ layer_dir)
-(** End-to-end test for [Stack.plan_lowerdir]: create [n_layers] fake
- dep layers, plan, optionally merge, mount overlay, and verify
- every dep's file is visible inside the container. *)
+(** End-to-end test for [Stack.plan_lowerdir]: create [n_layers] fake dep
+ layers, plan, optionally merge, mount overlay, and verify every dep's file
+ is visible inside the container. *)
let run_hybrid_plan_test ~n_layers ~budget () =
with_eio @@ fun ~sw env ->
with_tmp_dir @@ fun dir ->
@@ -147,7 +147,8 @@ let run_hybrid_plan_test ~n_layers ~budget () =
let base_layer = Fpath.(dir / "base") in
let base_fs = Fpath.(base_layer / "fs") in
create_rootfs base_fs;
- mkdir Fpath.(base_fs / "data"); (* placeholder so /data exists *)
+ mkdir Fpath.(base_fs / "data");
+ (* placeholder so /data exists *)
(* N dep layers, each adding /data/<i>.txt *)
let deps_parent = Fpath.(dir / "deps") in
mkdir deps_parent;
@@ -158,30 +159,29 @@ let run_hybrid_plan_test ~n_layers ~budget () =
let merged = Fpath.(dir / "merged") in
let merged_lower = Fpath.(dir / "lower") in
List.iter mkdir [ upper; work; merged ];
- let entry_cost d =
- String.length (Fpath.to_string Fpath.(d / "fs")) + 1
- in
+ let entry_cost d = String.length (Fpath.to_string Fpath.(d / "fs")) + 1 in
let fixed_overhead =
String.length "lowerdir="
+ String.length (Fpath.to_string base_fs)
- + String.length ",upperdir=" + String.length (Fpath.to_string upper)
- + String.length ",workdir=" + String.length (Fpath.to_string work)
- in
- let merged_overhead =
- String.length (Fpath.to_string merged_lower) + 1
+ + String.length ",upperdir="
+ + String.length (Fpath.to_string upper)
+ + String.length ",workdir="
+ + String.length (Fpath.to_string work)
in
+ let merged_overhead = String.length (Fpath.to_string merged_lower) + 1 in
let available = budget - fixed_overhead in
- let separate, to_merge = Day11_layer.Stack.plan_lowerdir
- ~available ~merged_overhead ~entry_cost dep_layers
+ let separate, to_merge =
+ Day11_layer.Stack.plan_lowerdir ~available ~merged_overhead ~entry_cost
+ dep_layers
in
- Alcotest.(check int) "all layers accounted for"
- n_layers (List.length separate + List.length to_merge);
+ Alcotest.(check int)
+ "all layers accounted for" n_layers
+ (List.length separate + List.length to_merge);
(* If anything to merge, do the cp-merge *)
- if to_merge <> [] then begin
+ if to_merge <> [] then (
mkdir merged_lower;
Day11_layer.Stack.merge ~sw env ~layer_dirs:to_merge ~target:merged_lower
- |> ok_or_fail "stack.merge"
- end;
+ |> ok_or_fail "stack.merge");
(* Build the overlay lower list: separate dep fs/ dirs + (merged
lower if any) + base. This must be the same construction
run_in_layers.ml uses. *)
@@ -195,44 +195,45 @@ let run_hybrid_plan_test ~n_layers ~budget () =
let options =
Printf.sprintf "lowerdir=%s,upperdir=%s,workdir=%s"
(String.concat ":" (List.map Fpath.to_string lower_dirs))
- (Fpath.to_string upper)
- (Fpath.to_string work)
+ (Fpath.to_string upper) (Fpath.to_string work)
in
Alcotest.(check bool)
(Printf.sprintf "options string %d bytes ≤ budget %d"
(String.length options) budget)
- true (String.length options <= budget);
+ true
+ (String.length options <= budget);
(* Mount the overlay *)
Overlay.mount ~sw env ~lower:lower_dirs ~upper ~work ~target:merged
|> ok_or_fail "overlay mount";
- Fun.protect ~finally:(fun () ->
- ignore (Overlay.umount ~sw env merged))
+ Fun.protect
+ ~finally:(fun () -> ignore (Overlay.umount ~sw env merged))
(fun () ->
(* Run a container that lists /data and verifies every file is
present. We use shell to count files and check their content. *)
let script =
Printf.sprintf
- "n=$(ls /data | wc -l); echo \"count=$n\"; \
- for i in $(ls /data); do cat /data/$i; echo; done"
+ "n=$(ls /data | wc -l); echo \"count=$n\"; for i in $(ls /data); do \
+ cat /data/$i; echo; done"
in
let spec =
- Oci_spec.make
- ~hostname:"test"
+ Oci_spec.make ~hostname:"test"
~env:[ ("PATH", "/bin") ]
~argv:[ "/bin/sh"; "-c"; script ]
- ~uid:0 ~gid:0
- ()
+ ~uid:0 ~gid:0 ()
in
Oci_spec.write ~root:(Fpath.to_string merged) dir spec
|> ok_or_fail "write_spec";
let container_id =
- Printf.sprintf "day11-hybrid-%d-%d" n_layers (Unix.getpid ()) in
+ Printf.sprintf "day11-hybrid-%d-%d" n_layers (Unix.getpid ())
+ in
ignore (Runc.delete ~sw env container_id);
- let run = Runc.run ~sw env ~bundle:dir ~container_id
- |> ok_or_fail "runc run" in
+ let run =
+ Runc.run ~sw env ~bundle:dir ~container_id |> ok_or_fail "runc run"
+ in
ignore (Runc.delete ~sw env container_id);
- Alcotest.(check bool) "container exit 0"
- true (run.Day11_sys.Run.status = `Exited 0);
+ Alcotest.(check bool)
+ "container exit 0" true
+ (run.Day11_sys.Run.status = `Exited 0);
let out = run.output ^ run.errors in
(* Check the file count *)
let expected_count_line = Printf.sprintf "count=%d" n_layers in
@@ -251,22 +252,22 @@ let run_hybrid_plan_test ~n_layers ~budget () =
List.exists (fun l -> String.trim l = expected) lines)
done)
-(** Multi-lower path: small layer count, generous budget. Should
- keep every layer separate and never invoke Stack.merge. *)
+(** Multi-lower path: small layer count, generous budget. Should keep every
+ layer separate and never invoke Stack.merge. *)
let test_hybrid_pure_multi_lower () =
run_hybrid_plan_test ~n_layers:30 ~budget:4000 ()
-(** Forced split: many layers, tight budget. Plan must split into
- separate + merged buckets, and the assembled mount must still
- show every dep's content. *)
+(** Forced split: many layers, tight budget. Plan must split into separate +
+ merged buckets, and the assembled mount must still show every dep's content.
+*)
let test_hybrid_forced_split () =
(* 60 layers with realistic-ish (long) path components inside the
temp dir. With a deliberately small budget, the plan is forced
to merge most of them. *)
run_hybrid_plan_test ~n_layers:60 ~budget:1500 ()
-(** Realistic 4K test: enough layers that pure multi-lower would
- overflow PAGE_SIZE. Without the split, the mount would fail. *)
+(** Realistic 4K test: enough layers that pure multi-lower would overflow
+ PAGE_SIZE. Without the split, the mount would fail. *)
let test_hybrid_real_4k_overflow () =
(* The temp dirs in this test have long paths under /tmp, and
each "dep-NNN" entry costs around 60 bytes. With ~70+ deps,
@@ -283,8 +284,7 @@ let () =
( "Container",
[
Alcotest.test_case "runc echo" `Slow test_runc_echo;
- Alcotest.test_case "overlay + runc" `Slow
- test_overlay_and_runc;
+ Alcotest.test_case "overlay + runc" `Slow test_overlay_and_runc;
] );
( "Hybrid lowerdir plan",
[
@@ -292,7 +292,6 @@ let () =
test_hybrid_pure_multi_lower;
Alcotest.test_case "forced split (small budget)" `Slow
test_hybrid_forced_split;
- Alcotest.test_case "4K boundary" `Slow
- test_hybrid_real_4k_overflow;
+ Alcotest.test_case "4K boundary" `Slow test_hybrid_real_4k_overflow;
] );
]
File "day11/solver/test/test_doc_deps.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/test/test_doc_deps.ml b/_build/default/day11/solver/test/.formatted/test_doc_deps.ml
index ad67f5d..2500db3 100644
--- a/_build/default/day11/solver/test/test_doc_deps.ml
+++ b/_build/default/day11/solver/test/.formatted/test_doc_deps.ml
@@ -6,93 +6,111 @@
Both should solve to include the same set of packages. *)
let () =
- let opam_repo = match Sys.getenv_opt "OPAM_REPOSITORY" with
+ let opam_repo =
+ match Sys.getenv_opt "OPAM_REPOSITORY" with
| Some p -> p
| None ->
- let home = Sys.getenv "HOME" in
- Filename.concat (Filename.concat home "ocaml") "opam-repository"
+ let home = Sys.getenv "HOME" in
+ Filename.concat (Filename.concat home "ocaml") "opam-repository"
in
Printf.printf "Using opam-repository: %s\n%!" opam_repo;
let git_packages, _ =
- Day11_opam.Git_packages.of_repositories [ (opam_repo, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repo, None) ]
+ in
Bos.OS.Dir.set_default_tmp (Fpath.v (Filename.get_temp_dir_name ()));
- let env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
+ let env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
(* Read both test opam files *)
let read_opam path =
- OpamFile.OPAM.read (OpamFile.make (OpamFilename.raw path)) in
+ OpamFile.OPAM.read (OpamFile.make (OpamFilename.raw path))
+ in
let opam_old = read_opam "/tmp/test-doc-deps/a-old.opam" in
let opam_new = read_opam "/tmp/test-doc-deps/b-new.opam" in
- let ocaml_version = Some (OpamPackage.of_string "ocaml-base-compiler.5.4.1") in
+ let ocaml_version =
+ Some (OpamPackage.of_string "ocaml-base-compiler.5.4.1")
+ in
(* Create pins for each test package *)
let make_pins name opam =
OpamPackage.Name.Map.singleton
(OpamPackage.Name.of_string name)
- (OpamPackage.Version.of_string "1.0", opam) in
+ (OpamPackage.Version.of_string "1.0", opam)
+ in
(* Solve test-old (x-extra-doc-deps) *)
let target_old = OpamPackage.of_string "test-old.1.0" in
- let result_old = Day11_solver.Solve.solve
- ~packages:git_packages ~env ~pins:(make_pins "test-old" opam_old)
- ?ocaml_version target_old in
+ let result_old =
+ Day11_solver.Solve.solve ~packages:git_packages ~env
+ ~pins:(make_pins "test-old" opam_old)
+ ?ocaml_version target_old
+ in
(* Solve test-new ({with-doc & post}) *)
let target_new = OpamPackage.of_string "test-new.1.0" in
- let result_new = Day11_solver.Solve.solve
- ~packages:git_packages ~env ~pins:(make_pins "test-new" opam_new)
- ?ocaml_version target_new in
+ let result_new =
+ Day11_solver.Solve.solve ~packages:git_packages ~env
+ ~pins:(make_pins "test-new" opam_new)
+ ?ocaml_version target_new
+ in
let pkg_names solution =
- OpamPackage.Map.fold (fun pkg _ acc ->
- OpamPackage.Name.Set.add (OpamPackage.name pkg) acc
- ) solution OpamPackage.Name.Set.empty in
+ OpamPackage.Map.fold
+ (fun pkg _ acc -> OpamPackage.Name.Set.add (OpamPackage.name pkg) acc)
+ solution OpamPackage.Name.Set.empty
+ in
- match result_old, result_new with
+ match (result_old, result_new) with
| Error (msg, _), _ ->
- Printf.printf "FAIL: test-old solve failed: %s\n%!" msg;
- exit 1
+ Printf.printf "FAIL: test-old solve failed: %s\n%!" msg;
+ exit 1
| _, Error (msg, _) ->
- Printf.printf "FAIL: test-new solve failed: %s\n%!" msg;
- exit 1
+ Printf.printf "FAIL: test-new solve failed: %s\n%!" msg;
+ exit 1
| Ok result_old, Ok result_new ->
- let sol_old = result_old.Day11_solution.Solve_result.build_deps in
- let sol_new = result_new.Day11_solution.Solve_result.build_deps in
- let names_old = pkg_names sol_old in
- let names_new = pkg_names sol_new in
- Printf.printf "test-old solution: %d packages\n%!"
- (OpamPackage.Map.cardinal sol_old);
- Printf.printf "test-new solution: %d packages\n%!"
- (OpamPackage.Map.cardinal sol_new);
+ let sol_old = result_old.Day11_solution.Solve_result.build_deps in
+ let sol_new = result_new.Day11_solution.Solve_result.build_deps in
+ let names_old = pkg_names sol_old in
+ let names_new = pkg_names sol_new in
+ Printf.printf "test-old solution: %d packages\n%!"
+ (OpamPackage.Map.cardinal sol_old);
+ Printf.printf "test-new solution: %d packages\n%!"
+ (OpamPackage.Map.cardinal sol_new);
- (* Remove the test package itself from each set *)
- let names_old = OpamPackage.Name.Set.remove
- (OpamPackage.Name.of_string "test-old") names_old in
- let names_new = OpamPackage.Name.Set.remove
- (OpamPackage.Name.of_string "test-new") names_new in
+ (* Remove the test package itself from each set *)
+ let names_old =
+ OpamPackage.Name.Set.remove
+ (OpamPackage.Name.of_string "test-old")
+ names_old
+ in
+ let names_new =
+ OpamPackage.Name.Set.remove
+ (OpamPackage.Name.of_string "test-new")
+ names_new
+ in
- let only_old = OpamPackage.Name.Set.diff names_old names_new in
- let only_new = OpamPackage.Name.Set.diff names_new names_old in
+ let only_old = OpamPackage.Name.Set.diff names_old names_new in
+ let only_new = OpamPackage.Name.Set.diff names_new names_old in
- if OpamPackage.Name.Set.is_empty only_old &&
- OpamPackage.Name.Set.is_empty only_new then
- Printf.printf "PASS: both solve to the same packages\n%!"
- else begin
- if not (OpamPackage.Name.Set.is_empty only_old) then begin
- Printf.printf "Only in old: ";
- OpamPackage.Name.Set.iter (fun n ->
- Printf.printf "%s " (OpamPackage.Name.to_string n)) only_old;
- Printf.printf "\n%!"
- end;
- if not (OpamPackage.Name.Set.is_empty only_new) then begin
- Printf.printf "Only in new: ";
- OpamPackage.Name.Set.iter (fun n ->
- Printf.printf "%s " (OpamPackage.Name.to_string n)) only_new;
- Printf.printf "\n%!"
- end;
- Printf.printf "FAIL: solutions differ\n%!";
- exit 1
- end
+ if
+ OpamPackage.Name.Set.is_empty only_old
+ && OpamPackage.Name.Set.is_empty only_new
+ then Printf.printf "PASS: both solve to the same packages\n%!"
+ else (
+ if not (OpamPackage.Name.Set.is_empty only_old) then (
+ Printf.printf "Only in old: ";
+ OpamPackage.Name.Set.iter
+ (fun n -> Printf.printf "%s " (OpamPackage.Name.to_string n))
+ only_old;
+ Printf.printf "\n%!");
+ if not (OpamPackage.Name.Set.is_empty only_new) then (
+ Printf.printf "Only in new: ";
+ OpamPackage.Name.Set.iter
+ (fun n -> Printf.printf "%s " (OpamPackage.Name.to_string n))
+ only_new;
+ Printf.printf "\n%!");
+ Printf.printf "FAIL: solutions differ\n%!";
+ exit 1)
File "day11/solver/test/test_solver.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver/test/test_solver.ml b/_build/default/day11/solver/test/.formatted/test_solver.ml
index b46c2b4..ea32ef3 100644
--- a/_build/default/day11/solver/test/test_solver.ml
+++ b/_build/default/day11/solver/test/.formatted/test_solver.ml
@@ -6,7 +6,6 @@ open Day11_test_util.Test_util
(* ── Helpers ─────────────────────────────────────────────────────── *)
let is_ok msg r = ok_or_fail msg r |> ignore
-
let pkg s = OpamPackage.of_string s
let _make_solution () =
@@ -19,85 +18,99 @@ let _make_solution () =
(* ── Opam_env tests ──────────────────────────────────────────────── *)
let test_std_env () =
- let env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
- Alcotest.(check (option string)) "arch"
- (Some "x86_64")
+ let env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
+ Alcotest.(check (option string))
+ "arch" (Some "x86_64")
(env "arch" |> Option.map (function OpamTypes.S s -> s | _ -> "?"));
- Alcotest.(check (option string)) "os"
- (Some "linux")
+ Alcotest.(check (option string))
+ "os" (Some "linux")
(env "os" |> Option.map (function OpamTypes.S s -> s | _ -> "?"))
let test_std_env_ocaml_native () =
- let env = Day11_opam.Opam_env.std_env
- ~ocaml_native:false
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
- Alcotest.(check (option string)) "ocaml:native"
- (Some "false")
- (env "ocaml:native" |> Option.map (function
- OpamTypes.B b -> string_of_bool b | _ -> "?"))
+ let env =
+ Day11_opam.Opam_env.std_env ~ocaml_native:false ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
+ Alcotest.(check (option string))
+ "ocaml:native" (Some "false")
+ (env "ocaml:native"
+ |> Option.map (function OpamTypes.B b -> string_of_bool b | _ -> "?"))
let test_std_env_unknown () =
- let env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
- Alcotest.(check bool) "unknown returns None"
- true (Option.is_none (env "foobar"))
+ let env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
+ Alcotest.(check bool)
+ "unknown returns None" true
+ (Option.is_none (env "foobar"))
(* ── Dot_solution tests ──────────────────────────────────────────── *)
let test_dot_to_string () =
let s = _make_solution () in
let dot = Dot_solution.to_string s in
- Alcotest.(check bool) "starts with digraph"
- true (Astring.String.is_prefix ~affix:"digraph" dot);
- Alcotest.(check bool) "contains a.1"
- true (Astring.String.is_infix ~affix:"a.1" dot)
+ Alcotest.(check bool)
+ "starts with digraph" true
+ (Astring.String.is_prefix ~affix:"digraph" dot);
+ Alcotest.(check bool)
+ "contains a.1" true
+ (Astring.String.is_infix ~affix:"a.1" dot)
-let test_dot_save () = with_tmp_dir @@ fun dir ->
+let test_dot_save () =
+ with_tmp_dir @@ fun dir ->
let path = Fpath.(dir / "graph.dot") in
Dot_solution.save path (_make_solution ()) |> is_ok "save";
- Alcotest.(check bool) "file exists"
- true (Bos.OS.File.exists path |> Result.get_ok)
+ Alcotest.(check bool)
+ "file exists" true
+ (Bos.OS.File.exists path |> Result.get_ok)
(* ── Solve tests (needs opam-repository git repo) ────────────────── *)
let test_solve_astring () =
let opam_repo = opam_repository () in
let packages, _store, _commit =
- Day11_opam.Git_packages.of_opam_repository opam_repo in
- let env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
- let result = Solve.solve ~packages ~env
- (pkg "astring.0.8.5") in
- match result with
- | Ok result ->
- let names = OpamPackage.Map.keys result.Day11_solution.Solve_result.build_deps
- |> List.map OpamPackage.to_string in
- Alcotest.(check bool) "has astring"
- true (List.exists (fun n ->
- Astring.String.is_prefix ~affix:"astring" n) names);
- Alcotest.(check bool) "has compiler"
- true (List.exists (fun n ->
- Astring.String.is_prefix ~affix:"ocaml-base-compiler" n
- || Astring.String.is_prefix ~affix:"ocaml-compiler" n) names)
- | Error (diag, _) ->
- Alcotest.fail (Printf.sprintf "Solve failed: %s" diag)
+ Day11_opam.Git_packages.of_opam_repository opam_repo
+ in
+ let env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
+ let result = Solve.solve ~packages ~env (pkg "astring.0.8.5") in
+ match result with
+ | Ok result ->
+ let names =
+ OpamPackage.Map.keys result.Day11_solution.Solve_result.build_deps
+ |> List.map OpamPackage.to_string
+ in
+ Alcotest.(check bool)
+ "has astring" true
+ (List.exists
+ (fun n -> Astring.String.is_prefix ~affix:"astring" n)
+ names);
+ Alcotest.(check bool)
+ "has compiler" true
+ (List.exists
+ (fun n ->
+ Astring.String.is_prefix ~affix:"ocaml-base-compiler" n
+ || Astring.String.is_prefix ~affix:"ocaml-compiler" n)
+ names)
+ | Error (diag, _) -> Alcotest.fail (Printf.sprintf "Solve failed: %s" diag)
let test_solve_nnexistent () =
let opam_repo = opam_repository () in
let packages, _store, _commit =
- Day11_opam.Git_packages.of_opam_repository opam_repo in
- let env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
- let result = Solve.solve ~packages ~env
- (pkg "nonexistent-pkg-xyz.1.0") in
- Alcotest.(check bool) "no solution"
- true (Result.is_error result)
+ Day11_opam.Git_packages.of_opam_repository opam_repo
+ in
+ let env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
+ let result = Solve.solve ~packages ~env (pkg "nonexistent-pkg-xyz.1.0") in
+ Alcotest.(check bool) "no solution" true (Result.is_error result)
(* ── Two-graph doc deps tests ────────────────────────────────────── *)
@@ -113,30 +126,37 @@ let test_solve_nonexistent () =
let test_odig_odoc_needs_separate_link () =
let opam_repo = opam_repository () in
let packages, _store, _commit =
- Day11_opam.Git_packages.of_opam_repository opam_repo in
- let env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
+ Day11_opam.Git_packages.of_opam_repository opam_repo
+ in
+ let env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
let target = pkg "odig.0.0.9" in
let result = Solve.solve ~packages ~env target in
match result with
- | Error (diag, _) ->
- Alcotest.fail (Printf.sprintf "Solve failed: %s" diag)
- | Ok result ->
- (* odoc should be in the solution *)
- let odoc_pkg = OpamPackage.Map.fold (fun p _ acc ->
- if OpamPackage.Name.to_string (OpamPackage.name p) = "odoc"
- then Some p else acc
- ) result.Day11_solution.Solve_result.build_deps None in
- (match odoc_pkg with
- | None -> Alcotest.fail "odoc not in solution for odig"
- | Some odoc ->
- let separate = Day11_doc.Doc_deps.needs_separate_link result odoc in
- Alcotest.(check bool) "odoc needs separate link" true separate;
- (* odig itself should NOT need separate link
+ | Error (diag, _) -> Alcotest.fail (Printf.sprintf "Solve failed: %s" diag)
+ | Ok result -> (
+ (* odoc should be in the solution *)
+ let odoc_pkg =
+ OpamPackage.Map.fold
+ (fun p _ acc ->
+ if OpamPackage.Name.to_string (OpamPackage.name p) = "odoc" then
+ Some p
+ else acc)
+ result.Day11_solution.Solve_result.build_deps None
+ in
+ match odoc_pkg with
+ | None -> Alcotest.fail "odoc not in solution for odig"
+ | Some odoc ->
+ let separate = Day11_doc.Doc_deps.needs_separate_link result odoc in
+ Alcotest.(check bool) "odoc needs separate link" true separate;
+ (* odig itself should NOT need separate link
(it has no x-extra-doc-deps or {post} deps) *)
- let odig_separate = Day11_doc.Doc_deps.needs_separate_link result target in
- Alcotest.(check bool) "odig single phase" false odig_separate)
+ let odig_separate =
+ Day11_doc.Doc_deps.needs_separate_link result target
+ in
+ Alcotest.(check bool) "odig single phase" false odig_separate)
(* doc_deps should be a superset of the build_deps for packages with
x-extra-doc-deps, and identical deps for packages without.
@@ -144,54 +164,73 @@ let test_odig_odoc_needs_separate_link () =
let test_doc_deps_superset () =
let opam_repo = opam_repository () in
let packages, _store, _commit =
- Day11_opam.Git_packages.of_opam_repository opam_repo in
- let env = Day11_opam.Opam_env.std_env
- ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
- ~os_family:"debian" ~os_version:"12" () in
+ Day11_opam.Git_packages.of_opam_repository opam_repo
+ in
+ let env =
+ Day11_opam.Opam_env.std_env ~arch:"x86_64" ~os:"linux"
+ ~os_distribution:"debian" ~os_family:"debian" ~os_version:"12" ()
+ in
let target = pkg "odig.0.0.9" in
let result = Solve.solve ~packages ~env target in
match result with
- | Error (diag, _) ->
- Alcotest.fail (Printf.sprintf "Solve failed: %s" diag)
- | Ok result ->
- let compile_deps = result.Day11_solution.Solve_result.build_deps in
- let link_deps = result.doc_deps in
- (* Same set of packages in both graphs *)
- let compile_pkgs = OpamPackage.Map.fold (fun p _ acc ->
- OpamPackage.Set.add p acc) compile_deps OpamPackage.Set.empty in
- let link_pkgs = OpamPackage.Map.fold (fun p _ acc ->
- OpamPackage.Set.add p acc) link_deps OpamPackage.Set.empty in
- Alcotest.(check bool) "same package set"
- true (OpamPackage.Set.equal compile_pkgs link_pkgs);
- (* For each package, link deps should be a superset of compile deps *)
- OpamPackage.Map.iter (fun p compile_set ->
- let link_set = OpamPackage.Map.find p link_deps in
- let missing = OpamPackage.Set.diff compile_set link_set in
- if not (OpamPackage.Set.is_empty missing) then
- Alcotest.fail (Printf.sprintf "%s: compile dep %s not in link deps"
- (OpamPackage.to_string p)
- (OpamPackage.to_string (OpamPackage.Set.choose missing)))
- ) compile_deps;
- (* odoc specifically should have extra link deps from x-extra-doc-deps *)
- let odoc_pkg = OpamPackage.Map.fold (fun p _ acc ->
- if OpamPackage.Name.to_string (OpamPackage.name p) = "odoc"
- then Some p else acc
- ) compile_deps None in
- (match odoc_pkg with
- | None -> Alcotest.fail "odoc not in solution"
- | Some odoc ->
- let compile_set = OpamPackage.Map.find odoc compile_deps in
- let link_set = OpamPackage.Map.find odoc link_deps in
- let extra = OpamPackage.Set.diff link_set compile_set in
- let extra_names = OpamPackage.Set.fold (fun p acc ->
- OpamPackage.Name.to_string (OpamPackage.name p) :: acc
- ) extra [] in
- Alcotest.(check bool) "odoc has extra link deps"
- true (List.length extra_names > 0);
- (* odig is in x-extra-doc-deps and not a regular dep of odoc,
+ | Error (diag, _) -> Alcotest.fail (Printf.sprintf "Solve failed: %s" diag)
+ | Ok result -> (
+ let compile_deps = result.Day11_solution.Solve_result.build_deps in
+ let link_deps = result.doc_deps in
+ (* Same set of packages in both graphs *)
+ let compile_pkgs =
+ OpamPackage.Map.fold
+ (fun p _ acc -> OpamPackage.Set.add p acc)
+ compile_deps OpamPackage.Set.empty
+ in
+ let link_pkgs =
+ OpamPackage.Map.fold
+ (fun p _ acc -> OpamPackage.Set.add p acc)
+ link_deps OpamPackage.Set.empty
+ in
+ Alcotest.(check bool)
+ "same package set" true
+ (OpamPackage.Set.equal compile_pkgs link_pkgs);
+ (* For each package, link deps should be a superset of compile deps *)
+ OpamPackage.Map.iter
+ (fun p compile_set ->
+ let link_set = OpamPackage.Map.find p link_deps in
+ let missing = OpamPackage.Set.diff compile_set link_set in
+ if not (OpamPackage.Set.is_empty missing) then
+ Alcotest.fail
+ (Printf.sprintf "%s: compile dep %s not in link deps"
+ (OpamPackage.to_string p)
+ (OpamPackage.to_string (OpamPackage.Set.choose missing))))
+ compile_deps;
+ (* odoc specifically should have extra link deps from x-extra-doc-deps *)
+ let odoc_pkg =
+ OpamPackage.Map.fold
+ (fun p _ acc ->
+ if OpamPackage.Name.to_string (OpamPackage.name p) = "odoc" then
+ Some p
+ else acc)
+ compile_deps None
+ in
+ match odoc_pkg with
+ | None -> Alcotest.fail "odoc not in solution"
+ | Some odoc ->
+ let compile_set = OpamPackage.Map.find odoc compile_deps in
+ let link_set = OpamPackage.Map.find odoc link_deps in
+ let extra = OpamPackage.Set.diff link_set compile_set in
+ let extra_names =
+ OpamPackage.Set.fold
+ (fun p acc ->
+ OpamPackage.Name.to_string (OpamPackage.name p) :: acc)
+ extra []
+ in
+ Alcotest.(check bool)
+ "odoc has extra link deps" true
+ (List.length extra_names > 0);
+ (* odig is in x-extra-doc-deps and not a regular dep of odoc,
so it should appear as an extra link dep *)
- Alcotest.(check bool) "extra includes odig"
- true (List.mem "odig" extra_names))
+ Alcotest.(check bool)
+ "extra includes odig" true
+ (List.mem "odig" extra_names))
(* ── Test registration ───────────────────────────────────────────── *)
@@ -209,13 +248,12 @@ let () =
Alcotest.test_case "to_string" `Quick test_dot_to_string;
Alcotest.test_case "save" `Quick test_dot_save;
] );
-( "Solve",
+ ( "Solve",
[
Alcotest.test_case "solve astring" `Slow test_solve_astring;
Alcotest.test_case "solve nonexistent" `Slow test_solve_nonexistent;
Alcotest.test_case "odig: odoc needs separate link" `Slow
test_odig_odoc_needs_separate_link;
- Alcotest.test_case "doc_deps superset" `Slow
- test_doc_deps_superset;
+ Alcotest.test_case "doc_deps superset" `Slow test_doc_deps_superset;
] );
]
File "day11/solver_pool/test/test_driver_solve.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver_pool/test/test_driver_solve.ml b/_build/default/day11/solver_pool/test/.formatted/test_driver_solve.ml
index 0da9c62..b56b81f 100644
--- a/_build/default/day11/solver_pool/test/test_driver_solve.ml
+++ b/_build/default/day11/solver_pool/test/.formatted/test_driver_solve.ml
@@ -1,41 +1,39 @@
(** Standalone repro for the oxcaml profile's driver tool solve.
- Exits 0 on a successful solve, 1 otherwise. Designed to iterate on
- overlay / local-repo / solver tweaks without re-running the whole
- ocaml-docs-ci pipeline — point it at the same three repositories
- the profile uses and ask it to solve [odoc-driver.3.2.0+ox] pinned
- to [ocaml-variants.5.2.0+ox].
+ Exits 0 on a successful solve, 1 otherwise. Designed to iterate on overlay /
+ local-repo / solver tweaks without re-running the whole ocaml-docs-ci
+ pipeline — point it at the same three repositories the profile uses and ask
+ it to solve [odoc-driver.3.2.0+ox] pinned to [ocaml-variants.5.2.0+ox].
- Run via:
- dune exec day11/solver_pool/test/test_driver_solve.exe
+ Run via: dune exec day11/solver_pool/test/test_driver_solve.exe
- Expected success on the current local-repo state:
- odoc-driver.3.2.0+ox OK (N packages in solution)
-*)
+ Expected success on the current local-repo state: odoc-driver.3.2.0+ox OK (N
+ packages in solution) *)
let all_repos =
- [ "/home/jjl25/ocaml/opam-repository";
+ [
+ "/home/jjl25/ocaml/opam-repository";
"/home/jjl25/oxcaml/opam-repository";
- "/home/jjl25/local/opam-repository" ]
+ "/home/jjl25/local/opam-repository";
+ ]
let ocaml_only = [ "/home/jjl25/ocaml/opam-repository" ]
-
let target = OpamPackage.of_string "odoc-driver.3.1.0"
let ocaml_version = OpamPackage.of_string "ocaml-base-compiler.5.4.1"
let extra_targets = []
-
let _ = ocaml_only
let resolve_head repos =
- List.map (fun path ->
- let sha =
- let cmd = Bos.Cmd.(v "git" % "-C" % path % "rev-parse" % "HEAD") in
- match Bos.OS.Cmd.(run_out cmd |> out_string) with
- | Ok (s, (_, `Exited 0)) -> String.trim s
- | _ -> "HEAD"
- in
- (path, sha)
- ) repos
+ List.map
+ (fun path ->
+ let sha =
+ let cmd = Bos.Cmd.(v "git" % "-C" % path % "rev-parse" % "HEAD") in
+ match Bos.OS.Cmd.(run_out cmd |> out_string) with
+ | Ok (s, (_, `Exited 0)) -> String.trim s
+ | _ -> "HEAD"
+ in
+ (path, sha))
+ repos
let solve_with ~sw env ~label repos =
Printf.printf "\n=== %s ===\n" label;
@@ -44,20 +42,25 @@ let solve_with ~sw env ~label repos =
(OpamPackage.to_string target)
(OpamPackage.to_string ocaml_version);
let results =
- Day11_solver_pool.Solver_pool.solve_many ~sw env
- ~ocaml_version ~extra_targets
- ~np:1 ~repos [ target ]
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ~ocaml_version
+ ~extra_targets ~np:1 ~repos [ target ]
in
match List.assoc_opt target results with
- | None -> Printf.printf "no result returned\n"; None
- | Some (Error (msg, _)) -> Printf.printf "FAILED\n%s\n" msg; None
+ | None ->
+ Printf.printf "no result returned\n";
+ None
+ | Some (Error (msg, _)) ->
+ Printf.printf "FAILED\n%s\n" msg;
+ None
| Some (Ok result) ->
- let pkgs = result.Day11_solution.Solve_result.build_deps
- |> OpamPackage.Map.keys
- |> List.map OpamPackage.to_string
- |> List.sort String.compare in
- Printf.printf "OK — %d packages\n" (List.length pkgs);
- Some pkgs
+ let pkgs =
+ result.Day11_solution.Solve_result.build_deps
+ |> OpamPackage.Map.keys
+ |> List.map OpamPackage.to_string
+ |> List.sort String.compare
+ in
+ Printf.printf "OK — %d packages\n" (List.length pkgs);
+ Some pkgs
module S = Set.Make (String)
@@ -66,19 +69,18 @@ let () =
Eio.Switch.run @@ fun sw ->
let a = solve_with ~sw env ~label:"ocaml-only" (resolve_head ocaml_only) in
let b = solve_with ~sw env ~label:"all-3-repos" (resolve_head all_repos) in
- match a, b with
+ match (a, b) with
| Some a, Some b ->
- let sa = S.of_list a and sb = S.of_list b in
- let only_a = S.diff sa sb and only_b = S.diff sb sa in
- let common = S.inter sa sb in
- Printf.printf "\n=== diff ===\ncommon: %d\nocaml-only only: %d\nall-3 only: %d\n"
- (S.cardinal common) (S.cardinal only_a) (S.cardinal only_b);
- if not (S.is_empty only_a) then begin
- Printf.printf "\npackages picked only in ocaml-only (NOT in all-3):\n";
- S.iter (Printf.printf " %s\n") only_a
- end;
- if not (S.is_empty only_b) then begin
- Printf.printf "\npackages picked only in all-3 (NOT in ocaml-only):\n";
- S.iter (Printf.printf " %s\n") only_b
- end
+ let sa = S.of_list a and sb = S.of_list b in
+ let only_a = S.diff sa sb and only_b = S.diff sb sa in
+ let common = S.inter sa sb in
+ Printf.printf
+ "\n=== diff ===\ncommon: %d\nocaml-only only: %d\nall-3 only: %d\n"
+ (S.cardinal common) (S.cardinal only_a) (S.cardinal only_b);
+ if not (S.is_empty only_a) then (
+ Printf.printf "\npackages picked only in ocaml-only (NOT in all-3):\n";
+ S.iter (Printf.printf " %s\n") only_a);
+ if not (S.is_empty only_b) then (
+ Printf.printf "\npackages picked only in all-3 (NOT in ocaml-only):\n";
+ S.iter (Printf.printf " %s\n") only_b)
| _ -> Printf.printf "\ncouldn't compare (one or both solves failed)\n"
File "day11/solver_pool/test/test_ox_variants.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver_pool/test/test_ox_variants.ml b/_build/default/day11/solver_pool/test/.formatted/test_ox_variants.ml
index d8c32f1..d0d13b4 100644
--- a/_build/default/day11/solver_pool/test/test_ox_variants.ml
+++ b/_build/default/day11/solver_pool/test/.formatted/test_ox_variants.ml
@@ -1,46 +1,50 @@
-(** Empirically test whether each [+ox] variant the solver picks for a
- mainline driver solve actually compiles under the mainline compiler.
+(** Empirically test whether each [+ox] variant the solver picks for a mainline
+ driver solve actually compiles under the mainline compiler.
For each candidate, attempt a tool build pinned to
[ocaml-base-compiler.5.4.1]. Report OK / FAILED per package.
- Run via:
- dune exec day11/solver_pool/test/test_ox_variants.exe
-*)
+ Run via: dune exec day11/solver_pool/test/test_ox_variants.exe *)
(* Inconclusive candidates from the first pass — their own build step
never ran because a broken [+ox] dep failed earlier in the chain.
Retry with the 4 confirmed-broken [+ox] variants pinned to their
mainline versions, so the chain actually reaches each candidate's
own compile step. *)
-let candidates = [
- "eio.1.3+ox";
- "eio_linux.1.3+ox";
- "eio_main.1.3+ox";
- "eio_posix.1.3+ox";
- "uutf.1.0.4+ox";
-]
+let candidates =
+ [
+ "eio.1.3+ox";
+ "eio_linux.1.3+ox";
+ "eio_main.1.3+ox";
+ "eio_posix.1.3+ox";
+ "uutf.1.0.4+ox";
+ ]
(* Pin the 5 confirmed-oxcaml-only deps to their mainline equivalents. *)
-let constraints = List.map OpamPackage.of_string [
- "ocaml-compiler-libs.v0.17.0";
- "ocamlbuild.0.16.1";
- "ocamlfind.1.9.8";
- "re.1.14.0";
- "topkg.1.1.1";
-]
+let constraints =
+ List.map OpamPackage.of_string
+ [
+ "ocaml-compiler-libs.v0.17.0";
+ "ocamlbuild.0.16.1";
+ "ocamlfind.1.9.8";
+ "re.1.14.0";
+ "topkg.1.1.1";
+ ]
let mainline = OpamPackage.of_string "ocaml-base-compiler.5.4.1"
-
let profile_name = "oxcaml"
let () =
let profile_dir = Day11_batch.Profile.default_dir () in
let profile =
- match Day11_batch.Profile.load
- ~dir:Fpath.(profile_dir / "profiles")
- ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Profile.load: %s\n" e; exit 1
+ match
+ Day11_batch.Profile.load
+ ~dir:Fpath.(profile_dir / "profiles")
+ ~name:profile_name
+ with
+ | Error (`Msg e) ->
+ Printf.eprintf "Profile.load: %s\n" e;
+ exit 1
| Ok p -> p
in
let cache_dir = Fpath.(profile_dir / "cache") in
@@ -51,35 +55,39 @@ let () =
let ctx =
match Day11_batch.Profile_ctx.ensure_base ~sw env ctx with
| Ok c -> c
- | Error (`Msg e) -> Printf.eprintf "ensure_base: %s\n%!" e; exit 1
+ | Error (`Msg e) ->
+ Printf.eprintf "ensure_base: %s\n%!" e;
+ exit 1
in
let benv = ctx.benv in
- let results = List.map (fun s ->
- let target = OpamPackage.of_string s in
- Printf.printf "\n================ %s ================\n%!" s;
- let r =
- try
- Day11_opam_build.Tools.build_tool ~sw env benv
- ~np:8
- ~packages:ctx.git_packages
- ~repos:ctx.repos_with_shas
- ~constraints
- ~ocaml_version:mainline
- ~doc:false
- target
- with exn ->
- Rresult.R.error_msgf "exception: %s" (Printexc.to_string exn)
- in
- match r with
- | Ok _ -> Printf.printf "RESULT: %s OK\n%!" s; (s, `Ok)
- | Error (`Msg e) -> Printf.printf "RESULT: %s FAILED: %s\n%!" s e; (s, `Failed e)
- ) candidates in
+ let results =
+ List.map
+ (fun s ->
+ let target = OpamPackage.of_string s in
+ Printf.printf "\n================ %s ================\n%!" s;
+ let r =
+ try
+ Day11_opam_build.Tools.build_tool ~sw env benv ~np:8
+ ~packages:ctx.git_packages ~repos:ctx.repos_with_shas ~constraints
+ ~ocaml_version:mainline ~doc:false target
+ with exn ->
+ Rresult.R.error_msgf "exception: %s" (Printexc.to_string exn)
+ in
+ match r with
+ | Ok _ ->
+ Printf.printf "RESULT: %s OK\n%!" s;
+ (s, `Ok)
+ | Error (`Msg e) ->
+ Printf.printf "RESULT: %s FAILED: %s\n%!" s e;
+ (s, `Failed e))
+ candidates
+ in
Printf.printf "\n================ summary ================\n";
let ok = List.filter (fun (_, r) -> r = `Ok) results
and fail = List.filter (fun (_, r) -> r <> `Ok) results in
Printf.printf "OK (%d):\n" (List.length ok);
List.iter (fun (s, _) -> Printf.printf " %s\n" s) ok;
Printf.printf "FAILED (%d):\n" (List.length fail);
- List.iter (function
- | s, `Failed e -> Printf.printf " %s — %s\n" s e
- | _ -> ()) fail
+ List.iter
+ (function s, `Failed e -> Printf.printf " %s — %s\n" s e | _ -> ())
+ fail
File "day11/solver_pool/test/test_solver_pool.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver_pool/test/test_solver_pool.ml b/_build/default/day11/solver_pool/test/.formatted/test_solver_pool.ml
index 9b45942..94767d6 100644
--- a/_build/default/day11/solver_pool/test/test_solver_pool.ml
+++ b/_build/default/day11/solver_pool/test/.formatted/test_solver_pool.ml
@@ -11,23 +11,23 @@ let pkg s = OpamPackage.of_string s
let test_solve_single () =
let opam_repo = opam_repository () in
with_eio @@ fun ~sw env ->
- let results = Day11_solver_pool.Solver_pool.solve_many ~sw env
- ~np:1 ~repos:[(opam_repo, "HEAD")]
- [ pkg "astring.0.8.5" ]
+ let results =
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ~np:1
+ ~repos:[ (opam_repo, "HEAD") ]
+ [ pkg "astring.0.8.5" ]
in
Alcotest.(check int) "one result" 1 (List.length results);
match results with
| [ (p, Ok _) ] ->
- Alcotest.(check string) "target"
- "astring.0.8.5" (OpamPackage.to_string p)
+ Alcotest.(check string) "target" "astring.0.8.5" (OpamPackage.to_string p)
| [ (_, Error (msg, _)) ] ->
- Alcotest.fail (Printf.sprintf "solve failed: %s" msg)
+ Alcotest.fail (Printf.sprintf "solve failed: %s" msg)
| _ -> Alcotest.fail "unexpected result shape"
let test_solve_empty () =
with_eio @@ fun ~sw env ->
- let results = Day11_solver_pool.Solver_pool.solve_many ~sw env
- ~np:4 ~repos:[] []
+ let results =
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ~np:4 ~repos:[] []
in
Alcotest.(check int) "no results" 0 (List.length results)
@@ -36,34 +36,40 @@ let test_on_progress () =
let opam_repo = opam_repository () in
with_eio @@ fun ~sw env ->
let calls = ref [] in
- let on_progress ~done_count ~total =
- calls := (done_count, total) :: !calls
- in
+ let on_progress ~done_count ~total = calls := (done_count, total) :: !calls in
let targets = [ pkg "astring.0.8.5"; pkg "fmt.0.9.0" ] in
- let _ = Day11_solver_pool.Solver_pool.solve_many ~sw env
- ~on_progress ~np:2 ~repos:[(opam_repo, "HEAD")] targets
+ let _ =
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ~on_progress ~np:2
+ ~repos:[ (opam_repo, "HEAD") ]
+ targets
in
- Alcotest.(check bool) "on_progress was called"
- true (!calls <> []);
+ Alcotest.(check bool) "on_progress was called" true (!calls <> []);
(* Every call's total equals the number of targets. *)
- List.iter (fun (_, t) ->
- Alcotest.(check int) "total" (List.length targets) t
- ) !calls
+ List.iter
+ (fun (_, t) -> Alcotest.(check int) "total" (List.length targets) t)
+ !calls
let test_parallel_np () =
(* Spawning 4 workers for 4 targets should still return all 4 results,
with no results lost to fiber races. *)
let opam_repo = opam_repository () in
with_eio @@ fun ~sw env ->
- let targets = [
- pkg "astring.0.8.5"; pkg "fmt.0.9.0";
- pkg "fpath.0.7.3"; pkg "rresult.0.7.0"
- ] in
- let results = Day11_solver_pool.Solver_pool.solve_many ~sw env
- ~np:4 ~repos:[(opam_repo, "HEAD")] targets
+ let targets =
+ [
+ pkg "astring.0.8.5";
+ pkg "fmt.0.9.0";
+ pkg "fpath.0.7.3";
+ pkg "rresult.0.7.0";
+ ]
+ in
+ let results =
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ~np:4
+ ~repos:[ (opam_repo, "HEAD") ]
+ targets
in
- Alcotest.(check int) "result count matches target count"
- (List.length targets) (List.length results)
+ Alcotest.(check int)
+ "result count matches target count" (List.length targets)
+ (List.length results)
let () =
Alcotest.run "day11_solver_pool"
File "day11/solver_pool/test/test_who_wants_odoc_310.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver_pool/test/test_who_wants_odoc_310.ml b/_build/default/day11/solver_pool/test/.formatted/test_who_wants_odoc_310.ml
index 83562dd..184858c 100644
--- a/_build/default/day11/solver_pool/test/test_who_wants_odoc_310.ml
+++ b/_build/default/day11/solver_pool/test/.formatted/test_who_wants_odoc_310.ml
@@ -1,17 +1,28 @@
(** Which target pulls odoc.3.1.0+ox into its solution? *)
let repos =
- [ "/home/jjl25/ocaml/opam-repository";
+ [
+ "/home/jjl25/ocaml/opam-repository";
"/home/jjl25/oxcaml/opam-repository";
- "/home/jjl25/local/opam-repository" ]
+ "/home/jjl25/local/opam-repository";
+ ]
let ocaml_version = OpamPackage.of_string "ocaml-variants.5.2.0+ox"
(* The same 10 targets as profile oxcaml-small — expand to all versions. *)
-let target_names = [
- "fmt"; "logs"; "fpath"; "bos"; "astring"; "cmdliner";
- "yojson"; "ppxlib"; "eio"; "cstruct";
-]
+let target_names =
+ [
+ "fmt";
+ "logs";
+ "fpath";
+ "bos";
+ "astring";
+ "cmdliner";
+ "yojson";
+ "ppxlib";
+ "eio";
+ "cstruct";
+ ]
let odoc_310 = OpamPackage.of_string "odoc.3.1.0+ox"
@@ -19,54 +30,68 @@ let () =
Eio_main.run @@ fun env ->
Eio.Switch.run @@ fun sw ->
let repos_with_shas =
- List.map (fun path ->
- let sha =
- let cmd = Bos.Cmd.(v "git" % "-C" % path % "rev-parse" % "HEAD") in
- match Bos.OS.Cmd.(run_out cmd |> out_string) with
- | Ok (s, (_, `Exited 0)) -> String.trim s
- | _ -> "HEAD"
- in
- (path, sha)
- ) repos in
+ List.map
+ (fun path ->
+ let sha =
+ let cmd = Bos.Cmd.(v "git" % "-C" % path % "rev-parse" % "HEAD") in
+ match Bos.OS.Cmd.(run_out cmd |> out_string) with
+ | Ok (s, (_, `Exited 0)) -> String.trim s
+ | _ -> "HEAD"
+ in
+ (path, sha))
+ repos
+ in
let env = (env :> Eio_unix.Stdenv.base) in
(* Enumerate all versions of each target name by querying the repos. *)
let packages, _ =
Day11_opam.Git_packages.of_repositories
- (List.map (fun r -> (r, None)) repos) in
+ (List.map (fun r -> (r, None)) repos)
+ in
let all_versions name =
try
- Day11_opam.Git_packages.get_versions packages (OpamPackage.Name.of_string name)
+ Day11_opam.Git_packages.get_versions packages
+ (OpamPackage.Name.of_string name)
|> OpamPackage.Version.Map.keys
- |> List.map (fun v -> OpamPackage.create (OpamPackage.Name.of_string name) v)
+ |> List.map (fun v ->
+ OpamPackage.create (OpamPackage.Name.of_string name) v)
with _ -> []
in
let targets = List.concat_map all_versions target_names in
- Printf.printf "total targets: %d (across %d names)\n%!"
- (List.length targets) (List.length target_names);
+ Printf.printf "total targets: %d (across %d names)\n%!" (List.length targets)
+ (List.length target_names);
let results =
- Day11_solver_pool.Solver_pool.solve_many ~sw env
- ~ocaml_version ~np:8 ~repos:repos_with_shas targets
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ~ocaml_version ~np:8
+ ~repos:repos_with_shas targets
+ in
+ let pulls_in_odoc310 =
+ List.filter_map
+ (fun (t, r) ->
+ match r with
+ | Ok sr ->
+ if
+ OpamPackage.Map.mem odoc_310
+ sr.Day11_solution.Solve_result.build_deps
+ then
+ let patches =
+ OpamPackage.Map.bindings
+ sr.Day11_solution.Solve_result.build_deps
+ |> List.filter (fun (p, _) ->
+ OpamPackage.Name.to_string (OpamPackage.name p)
+ = "oxcaml-odoc-patches")
+ |> List.map (fun (p, _) ->
+ OpamPackage.version p |> OpamPackage.Version.to_string)
+ |> String.concat ","
+ in
+ Some (OpamPackage.to_string t, patches)
+ else None
+ | Error _ -> None)
+ results
in
- let pulls_in_odoc310 = List.filter_map (fun (t, r) ->
- match r with
- | Ok sr ->
- if OpamPackage.Map.mem odoc_310
- sr.Day11_solution.Solve_result.build_deps then begin
- let patches =
- OpamPackage.Map.bindings sr.Day11_solution.Solve_result.build_deps
- |> List.filter (fun (p, _) ->
- OpamPackage.Name.to_string (OpamPackage.name p)
- = "oxcaml-odoc-patches")
- |> List.map (fun (p, _) -> OpamPackage.version p
- |> OpamPackage.Version.to_string)
- |> String.concat "," in
- Some (OpamPackage.to_string t, patches)
- end else None
- | Error _ -> None
- ) results in
Printf.printf "\ntargets whose solution includes %s (%d):\n"
- (OpamPackage.to_string odoc_310) (List.length pulls_in_odoc310);
- List.iter (fun (t, patches) ->
- Printf.printf " %s (oxcaml-odoc-patches: %s)\n" t
- (if patches = "" then "<none>" else patches)
- ) pulls_in_odoc310
+ (OpamPackage.to_string odoc_310)
+ (List.length pulls_in_odoc310);
+ List.iter
+ (fun (t, patches) ->
+ Printf.printf " %s (oxcaml-odoc-patches: %s)\n" t
+ (if patches = "" then "<none>" else patches))
+ pulls_in_odoc310
File "day11/solver_pool/test/test_why_not_odoc_320.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/solver_pool/test/test_why_not_odoc_320.ml b/_build/default/day11/solver_pool/test/.formatted/test_why_not_odoc_320.ml
index d0c4186..2a3e8e9 100644
--- a/_build/default/day11/solver_pool/test/test_why_not_odoc_320.ml
+++ b/_build/default/day11/solver_pool/test/.formatted/test_why_not_odoc_320.ml
@@ -1,18 +1,19 @@
-(** For a single [+ox] target that currently pulls [odoc.3.1.0+ox],
- ask the solver to ALSO pin [odoc.3.2.0+ox] and report what
- conflict prevented [3.2.0+ox] in the first place. *)
+(** For a single [+ox] target that currently pulls [odoc.3.1.0+ox], ask the
+ solver to ALSO pin [odoc.3.2.0+ox] and report what conflict prevented
+ [3.2.0+ox] in the first place. *)
let repos =
- [ "/home/jjl25/ocaml/opam-repository";
+ [
+ "/home/jjl25/ocaml/opam-repository";
"/home/jjl25/oxcaml/opam-repository";
- "/home/jjl25/local/opam-repository" ]
+ "/home/jjl25/local/opam-repository";
+ ]
let ocaml_version = OpamPackage.of_string "ocaml-variants.5.2.0+ox"
-let target = OpamPackage.of_string
- (match Sys.argv with
- | [| _; t |] -> t
- | _ -> "cstruct.3.3.0")
+let target =
+ OpamPackage.of_string
+ (match Sys.argv with [| _; t |] -> t | _ -> "cstruct.3.3.0")
let extra_targets = [ OpamPackage.of_string "odoc.3.2.0+ox" ]
@@ -20,26 +21,25 @@ let () =
Eio_main.run @@ fun env ->
Eio.Switch.run @@ fun sw ->
let repos_with_shas =
- List.map (fun path ->
- let sha =
- let cmd = Bos.Cmd.(v "git" % "-C" % path % "rev-parse" % "HEAD") in
- match Bos.OS.Cmd.(run_out cmd |> out_string) with
- | Ok (s, (_, `Exited 0)) -> String.trim s
- | _ -> "HEAD"
- in
- (path, sha)
- ) repos in
+ List.map
+ (fun path ->
+ let sha =
+ let cmd = Bos.Cmd.(v "git" % "-C" % path % "rev-parse" % "HEAD") in
+ match Bos.OS.Cmd.(run_out cmd |> out_string) with
+ | Ok (s, (_, `Exited 0)) -> String.trim s
+ | _ -> "HEAD"
+ in
+ (path, sha))
+ repos
+ in
Printf.printf "Target: %s (extra-target: odoc.3.2.0+ox)\n"
(OpamPackage.to_string target);
let env = (env :> Eio_unix.Stdenv.base) in
let results =
- Day11_solver_pool.Solver_pool.solve_many ~sw env
- ~ocaml_version ~extra_targets
- ~np:1 ~repos:repos_with_shas [ target ]
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ~ocaml_version
+ ~extra_targets ~np:1 ~repos:repos_with_shas [ target ]
in
match List.assoc_opt target results with
| None -> Printf.printf "no result\n"
- | Some (Ok _) ->
- Printf.printf "OK — solved with odoc.3.2.0+ox pinned\n"
- | Some (Error (msg, _)) ->
- Printf.printf "FAILED:\n%s\n" msg
+ | Some (Ok _) -> Printf.printf "OK — solved with odoc.3.2.0+ox pinned\n"
+ | Some (Error (msg, _)) -> Printf.printf "FAILED:\n%s\n" msg
File "day11/opam_build/backend.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/backend.ml b/_build/default/day11/opam_build/.formatted/backend.ml
index d8f1e29..7f70793 100644
--- a/_build/default/day11/opam_build/backend.ml
+++ b/_build/default/day11/opam_build/.formatted/backend.ml
@@ -12,6 +12,5 @@ module type S = sig
Day11_opam_layer.Build.t ->
target_fs:Fpath.t ->
unit ->
- (Day11_sys.Run.t * Day11_layer.Meta.timing,
- [> Rresult.R.msg ]) result
+ (Day11_sys.Run.t * Day11_layer.Meta.timing, [> Rresult.R.msg ]) result
end
File "day11/opam_build/backend.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/backend.mli b/_build/default/day11/opam_build/.formatted/backend.mli
index 0ae209b..01b6d4e 100644
--- a/_build/default/day11/opam_build/backend.mli
+++ b/_build/default/day11/opam_build/.formatted/backend.mli
@@ -1,28 +1,24 @@
(** Build-backend abstraction.
- A {b backend} turns a {!Day11_opam_layer.Build.t} node plus its
- dep layers into a populated [fs/] directory. Two concrete
- backends exist:
+ A {b backend} turns a {!Day11_opam_layer.Build.t} node plus its dep layers
+ into a populated [fs/] directory. Two concrete backends exist:
- - {!Container_backend} — the original implementation: stacks
- dep layers as an overlayfs, runs the build command inside a
- runc container, captures the overlay upper dir. Needs sudo,
- produces root-owned layers.
+ - {!Container_backend} — the original implementation: stacks dep layers as
+ an overlayfs, runs the build command inside a runc container, captures the
+ overlay upper dir. Needs sudo, produces root-owned layers.
- - {!Native_backend} (added in Phase 2) — hardlinks dep layers
- into a temp prefix, runs the build command directly on the
- host, captures the diff via {!Day11_layer.Snapshot}. No sudo,
- produces user-owned layers.
+ - {!Native_backend} (added in Phase 2) — hardlinks dep layers into a temp
+ prefix, runs the build command directly on the host, captures the diff via
+ {!Day11_layer.Snapshot}. No sudo, produces user-owned layers.
- Shared layer format: both backends produce byte-identical
- [fs/] trees (modulo build-prefix paths that relocatable OCaml
+ Shared layer format: both backends produce byte-identical [fs/] trees
+ (modulo build-prefix paths that relocatable OCaml
+ [OPAM_SWITCH_PREFIX] resolve at runtime).
- The {!S.build} signature is a bit wider than a pure shared
- interface — it carries container-only options ([mounts],
- [prep_upper]) for backward compatibility with the rich API
- {!Build_layer.build} has always exposed. {!Native_backend}
- ignores those parameters. *)
+ The {!S.build} signature is a bit wider than a pure shared interface — it
+ carries container-only options ([mounts], [prep_upper]) for backward
+ compatibility with the rich API {!Build_layer.build} has always exposed.
+ {!Native_backend} ignores those parameters. *)
module type S = sig
val build :
@@ -38,35 +34,31 @@ module type S = sig
Day11_opam_layer.Build.t ->
target_fs:Fpath.t ->
unit ->
- (Day11_sys.Run.t * Day11_layer.Meta.timing,
- [> Rresult.R.msg ]) result
- (** [build ~sw env benv ... node ~target_fs ()] runs the build for
- [node] and places the captured filesystem tree at [target_fs].
+ (Day11_sys.Run.t * Day11_layer.Meta.timing, [> Rresult.R.msg ]) result
+ (** [build ~sw env benv ... node ~target_fs ()] runs the build for [node] and
+ places the captured filesystem tree at [target_fs].
The backend is responsible for:
- - stacking the dep layers (via overlayfs, hardlinks, or
- whatever mechanism fits)
+ - stacking the dep layers (via overlayfs, hardlinks, or whatever mechanism
+ fits)
- running the build command
- applying [strategy.cleanup] to the captured tree
- - {b moving / placing the captured files at [target_fs]}
- — [target_fs] must not exist beforehand; the backend
- creates it
+ - {b moving / placing the captured files at [target_fs]} — [target_fs]
+ must not exist beforehand; the backend creates it
- [opam_repositories] are the repo source paths a per-package slice
- is extracted from (just [node.pkg]) and mounted as the container's
- [default] repo, so opam only sees the one package rather than the
- whole opam-repository baked into the base image. It is {b required}
- (not optional) on purpose: a build only ever needs its own
- package, so omitting it used to silently fall back to the full
- base repo — a several-second switch-state load per node. Pass [[]]
- to deliberately opt into that fallback.
+ [opam_repositories] are the repo source paths a per-package slice is
+ extracted from (just [node.pkg]) and mounted as the container's [default]
+ repo, so opam only sees the one package rather than the whole
+ opam-repository baked into the base image. It is {b required} (not
+ optional) on purpose: a build only ever needs its own package, so omitting
+ it used to silently fall back to the full base repo — a several-second
+ switch-state load per node. Pass [[]] to deliberately opt into that
+ fallback.
- Returns [(run, timing)] — [run.status] is the build's exit
- code; [timing] is a per-phase timing alist for [layer.json]'s
- [timing] field.
+ Returns [(run, timing)] — [run.status] is the build's exit code; [timing]
+ is a per-phase timing alist for [layer.json]'s [timing] field.
- Container-specific parameters ([mounts], [prep_upper]) are
- ignored by non-container backends; the caller is responsible
- for not relying on them when running under a backend that
- doesn't honour them. *)
+ Container-specific parameters ([mounts], [prep_upper]) are ignored by
+ non-container backends; the caller is responsible for not relying on them
+ when running under a backend that doesn't honour them. *)
end
File "day11/opam_build/base.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/base.ml b/_build/default/day11/opam_build/.formatted/base.ml
index 8528eca..50d0b92 100644
--- a/_build/default/day11/opam_build/base.ml
+++ b/_build/default/day11/opam_build/.formatted/base.ml
@@ -1,4 +1,5 @@
let src = Logs.Src.create "day11.build.base" ~doc:"Base image management"
+
module Log = (val Logs.src_log src)
let hash ~image = Day11_layer.Hash.base_hash ~image
@@ -7,8 +8,8 @@ let build_hash ~os_distribution ~os_version ~arch:_ ?digest () =
match digest with
| Some d -> hash ~image:d
| None ->
- let image = Printf.sprintf "%s:%s" os_distribution os_version in
- hash ~image
+ let image = Printf.sprintf "%s:%s" os_distribution os_version in
+ hash ~image
let make_base_layer ~image ~base_dir : Day11_layer.Base.t =
{ hash = hash ~image; dir = base_dir; image }
@@ -58,15 +59,22 @@ let generate_opam_build_dockerfile ~arch ~local_opam_build =
let plat = platform arch in
let get_opam =
from ~platform:plat base_image
- @@ run "apt update && apt install -y curl build-essential git unzip bubblewrap"
- @@ run "curl -fsSL https://github.com/ocaml/opam/releases/download/2.4.1/opam-2.4.1-%s-linux -o /usr/local/bin/opam && chmod +x /usr/local/bin/opam"
+ @@ run
+ "apt update && apt install -y curl build-essential git unzip \
+ bubblewrap"
+ @@ run
+ "curl -fsSL \
+ https://github.com/ocaml/opam/releases/download/2.4.1/opam-2.4.1-%s-linux \
+ -o /usr/local/bin/opam && chmod +x /usr/local/bin/opam"
(opam_arch arch)
in
let get_source =
if local_opam_build then
copy ~src:[ "opam-build" ] ~dst:"/tmp/opam-build" ()
else
- run "git clone --depth 1 --branch apt-update https://github.com/jonludlam/opam-build.git /tmp/opam-build"
+ run
+ "git clone --depth 1 --branch apt-update \
+ https://github.com/jonludlam/opam-build.git /tmp/opam-build"
in
get_opam
@@ run "opam init --disable-sandboxing -a --bare -y"
@@ -79,7 +87,8 @@ let generate_opam_build_dockerfile ~arch ~local_opam_build =
let generate_dockerfile ~os_distribution ~os_version ~arch ~uid ~gid
~has_opam_build_bin ?digest () =
let open Dockerfile in
- let base_image = match digest with
+ let base_image =
+ match digest with
| Some d -> Printf.sprintf "%s@%s" os_distribution d
| None -> Printf.sprintf "%s:%s" os_distribution os_version
in
@@ -88,7 +97,10 @@ let generate_dockerfile ~os_distribution ~os_version ~arch ~uid ~gid
let stage1 =
from ~platform:plat ~alias:"opam-builder" base_image
@@ run "apt update && apt install -y curl"
- @@ run "curl -fsSL https://github.com/ocaml/opam/releases/download/2.4.1/opam-2.4.1-%s-linux -o /usr/local/bin/opam && chmod +x /usr/local/bin/opam"
+ @@ run
+ "curl -fsSL \
+ https://github.com/ocaml/opam/releases/download/2.4.1/opam-2.4.1-%s-linux \
+ -o /usr/local/bin/opam && chmod +x /usr/local/bin/opam"
(opam_arch arch)
in
(* Final stage *)
@@ -99,15 +111,22 @@ let generate_dockerfile ~os_distribution ~os_version ~arch ~uid ~gid
@@ copy ~from:"opam-builder" ~src:[ "/usr/local/bin/opam" ]
~dst:"/usr/local/bin/opam" ()
@@ (if has_opam_build_bin then
- (* COPY from context doesn't preserve exec for runc overlayfs,
+ (* COPY from context doesn't preserve exec for runc overlayfs,
so copy then chmod inside the image *)
- copy ~src:[ "opam-build-bin" ] ~dst:"/tmp/opam-build-bin" ()
- @@ run "install -m 755 /tmp/opam-build-bin /usr/local/bin/opam-build && rm /tmp/opam-build-bin"
- else empty)
- @@ run "echo 'debconf debconf/frontend select Noninteractive' | debconf-set-selections"
+ copy ~src:[ "opam-build-bin" ] ~dst:"/tmp/opam-build-bin" ()
+ @@ run
+ "install -m 755 /tmp/opam-build-bin /usr/local/bin/opam-build \
+ && rm /tmp/opam-build-bin"
+ else empty)
+ @@ run
+ "echo 'debconf debconf/frontend select Noninteractive' | \
+ debconf-set-selections"
@@ run "if getent passwd %i; then userdel -r $(id -nu %i); fi" uid uid
@@ run "groupadd --gid %i opam" gid
- @@ run "adduser --disabled-password --gecos '@opam' --no-create-home --uid %i --gid %i --home /home/opam opam" uid gid
+ @@ run
+ "adduser --disabled-password --gecos '@opam' --no-create-home --uid \
+ %i --gid %i --home /home/opam opam"
+ uid gid
@@ run "mkdir -p /home/opam && chown -R %i:%i /home/opam" uid gid
@@ run "echo 'opam ALL=(ALL:ALL) NOPASSWD:ALL' > /etc/sudoers.d/opam"
@@ run "chmod 440 /etc/sudoers.d/opam"
@@ -125,130 +144,145 @@ let generate_dockerfile ~os_distribution ~os_version ~arch ~uid ~gid
of it on switch-state load when no slice was mounted). *)
@@ run "mkdir -p /home/opam/empty-repo/packages"
@@ run "echo 'opam-version: \"2.0\"' > /home/opam/empty-repo/repo"
- @@ run "opam init -k local -a /home/opam/empty-repo --bare --disable-sandboxing -y"
+ @@ run
+ "opam init -k local -a /home/opam/empty-repo --bare \
+ --disable-sandboxing -y"
@@ run "opam switch create default --empty"
in
stage1 @@ final
(** Cache key for the opam-build binary. Profiles with different
- [opam_build_repo] settings need distinct binaries (local forks
- often handle packages upstream can't), so the binary cache is
- keyed by the source rather than shared globally. *)
+ [opam_build_repo] settings need distinct binaries (local forks often handle
+ packages upstream can't), so the binary cache is keyed by the source rather
+ than shared globally. *)
let opam_build_bin_path ~cache_dir ~opam_build_repo =
- let key = match opam_build_repo with
+ let key =
+ match opam_build_repo with
| None -> "upstream"
| Some path ->
- let s = Fpath.to_string path in
- let h = Digest.string s |> Digest.to_hex in
- "local-" ^ String.sub h 0 12
+ let s = Fpath.to_string path in
+ let h = Digest.string s |> Digest.to_hex in
+ "local-" ^ String.sub h 0 12
in
Fpath.(cache_dir / ("opam-build-bin-" ^ key))
let build_opam_build ~sw env ~cache_dir ~arch ?opam_build_repo () =
let bin_path = opam_build_bin_path ~cache_dir ~opam_build_repo in
- if Bos.OS.File.exists bin_path |> Result.get_ok then
- Ok bin_path
- else begin
+ if Bos.OS.File.exists bin_path |> Result.get_ok then Ok bin_path
+ else (
Log.info (fun m -> m "Building opam-build binary...");
let temp_dir = Bos.OS.Dir.tmp "day11_opam_build_%s" |> Result.get_ok in
- let local_opam_build = match opam_build_repo with
- | Some src ->
- let dst = Fpath.(temp_dir / "opam-build") in
- (match Day11_sys.Tree.copy ~source:src ~target:dst with
- | Ok () ->
- ignore (Sys.command (Printf.sprintf "rm -rf %s"
- (Fpath.to_string Fpath.(dst / "_build"))));
- true
- | Error _ -> false)
+ let local_opam_build =
+ match opam_build_repo with
+ | Some src -> (
+ let dst = Fpath.(temp_dir / "opam-build") in
+ match Day11_sys.Tree.copy ~source:src ~target:dst with
+ | Ok () ->
+ ignore
+ (Sys.command
+ (Printf.sprintf "rm -rf %s"
+ (Fpath.to_string Fpath.(dst / "_build"))));
+ true
+ | Error _ -> false)
| None -> false
in
- let dockerfile =
- generate_opam_build_dockerfile ~arch ~local_opam_build in
+ let dockerfile = generate_opam_build_dockerfile ~arch ~local_opam_build in
let dockerfile_path = Fpath.(temp_dir / "Dockerfile") in
- Bos.OS.File.write dockerfile_path
- (Dockerfile.string_of_t dockerfile) |> ignore;
+ Bos.OS.File.write dockerfile_path (Dockerfile.string_of_t dockerfile)
+ |> ignore;
(* Tag by source so concurrent builds for different
[opam_build_repo] values don't race on the same image tag. *)
- let tag_suffix = match opam_build_repo with
+ let tag_suffix =
+ match opam_build_repo with
| None -> "upstream"
| Some p ->
- let h = Digest.string (Fpath.to_string p) |> Digest.to_hex in
- "local-" ^ String.sub h 0 12
+ let h = Digest.string (Fpath.to_string p) |> Digest.to_hex in
+ "local-" ^ String.sub h 0 12
in
let tag = Printf.sprintf "day11-opam-build:%s" tag_suffix in
let build_log = Fpath.(temp_dir / "docker-build.log") in
let build_run =
Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "docker" % "build" % "--network=host" % "--no-cache"
- % "-t" % tag % Fpath.to_string temp_dir)
+ Bos.Cmd.(
+ v "docker"
+ % "build"
+ % "--network=host"
+ % "--no-cache"
+ % "-t"
+ % tag
+ % Fpath.to_string temp_dir)
(Some build_log)
in
match build_run.status with
- | `Exited 0 ->
- (* Extract just the binary from the image *)
- let extract_run =
- Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "docker" % "run" % "--rm" % tag
- % "cat" % "/usr/local/bin/opam-build")
- None
- in
- (match extract_run.status with
- | `Exited 0 ->
- let oc = open_out_bin (Fpath.to_string bin_path) in
- output_string oc extract_run.output;
- close_out oc;
- Unix.chmod (Fpath.to_string bin_path) 0o755;
- Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
- Ok bin_path
- | _ ->
- Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
- Rresult.R.error_msgf "Failed to extract opam-build binary")
+ | `Exited 0 -> (
+ (* Extract just the binary from the image *)
+ let extract_run =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(
+ v "docker"
+ % "run"
+ % "--rm"
+ % tag
+ % "cat"
+ % "/usr/local/bin/opam-build")
+ None
+ in
+ match extract_run.status with
+ | `Exited 0 ->
+ let oc = open_out_bin (Fpath.to_string bin_path) in
+ output_string oc extract_run.output;
+ close_out oc;
+ Unix.chmod (Fpath.to_string bin_path) 0o755;
+ Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
+ Ok bin_path
+ | _ ->
+ Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
+ Rresult.R.error_msgf "Failed to extract opam-build binary")
| `Exited n ->
- let saved_log = Fpath.(cache_dir / "opam-build-failed.log") in
- ignore (Bos.OS.File.read build_log |> Result.map (fun content ->
- ignore (Bos.OS.File.write saved_log content)));
- Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
- Rresult.R.error_msgf
- "opam-build Docker build failed (exit %d). Log: %a"
- n Fpath.pp saved_log
+ let saved_log = Fpath.(cache_dir / "opam-build-failed.log") in
+ ignore
+ (Bos.OS.File.read build_log
+ |> Result.map (fun content ->
+ ignore (Bos.OS.File.write saved_log content)));
+ Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
+ Rresult.R.error_msgf "opam-build Docker build failed (exit %d). Log: %a"
+ n Fpath.pp saved_log
| `Signaled n ->
- Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
- Rresult.R.error_msgf "opam-build Docker build signaled %d" n
- end
+ Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
+ Rresult.R.error_msgf "opam-build Docker build signaled %d" n)
let opam_build_mount ~cache_dir ?opam_build_repo () =
let bin_path = opam_build_bin_path ~cache_dir ~opam_build_repo in
if Bos.OS.File.exists bin_path |> Result.get_ok then
- Some (Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string bin_path)
- "/usr/local/bin/opam-build")
- else
- None
+ Some
+ (Day11_container.Mount.bind_ro ~src:(Fpath.to_string bin_path)
+ "/usr/local/bin/opam-build")
+ else None
let load_cached ~cache_dir ~os_distribution ~os_version =
let base_dir = Fpath.(cache_dir / "base") in
let marker = Fpath.(base_dir / "fs" / "usr") in
- if Bos.OS.Dir.exists marker |> Result.get_ok then begin
+ if Bos.OS.Dir.exists marker |> Result.get_ok then
(* Use stored digest if available, otherwise fall back to tag *)
- let image = match load_digest base_dir with
+ let image =
+ match load_digest base_dir with
| Some d -> d
| None -> Printf.sprintf "%s:%s" os_distribution os_version
in
Some (make_base_layer ~image ~base_dir)
- end else
- None
+ else None
-let build ~sw env ~cache_dir ~os_distribution ~os_version ~arch
- ~uid ~gid ?digest () =
+let build ~sw env ~cache_dir ~os_distribution ~os_version ~arch ~uid ~gid
+ ?digest () =
let base_dir = Fpath.(cache_dir / "base") in
let marker = Fpath.(base_dir / "fs" / "usr") in
let image = Printf.sprintf "%s:%s" os_distribution os_version in
- if Bos.OS.Dir.exists marker |> Result.get_ok then begin
+ if Bos.OS.Dir.exists marker |> Result.get_ok then (
Log.info (fun m -> m "Base layer cached");
- Ok (make_base_layer ~image ~base_dir)
- end else begin
- Log.info (fun m -> m "Building base image from %s:%s"
- os_distribution os_version);
+ Ok (make_base_layer ~image ~base_dir))
+ else (
+ Log.info (fun m ->
+ m "Building base image from %s:%s" os_distribution os_version);
let temp_dir = Bos.OS.Dir.tmp "day11_base_%s" |> Result.get_ok in
(* The base image no longer bakes any opam-repository — builds mount
a per-package slice at run time — so nothing repo-related needs
@@ -256,32 +290,39 @@ let build ~sw env ~cache_dir ~os_distribution ~os_version ~arch
(* Copy opam-build binary into Docker context if available *)
let has_opam_build_bin =
let cached = Fpath.(cache_dir / "opam-build-bin") in
- if Bos.OS.File.exists cached |> Result.get_ok then begin
- ignore (Sys.command (Printf.sprintf "cp %s %s"
- (Fpath.to_string cached)
- (Fpath.to_string Fpath.(temp_dir / "opam-build-bin"))));
- true
- end else false
+ if Bos.OS.File.exists cached |> Result.get_ok then (
+ ignore
+ (Sys.command
+ (Printf.sprintf "cp %s %s" (Fpath.to_string cached)
+ (Fpath.to_string Fpath.(temp_dir / "opam-build-bin"))));
+ true)
+ else false
in
let dockerfile =
generate_dockerfile ~os_distribution ~os_version ~arch ~uid ~gid
~has_opam_build_bin ?digest ()
in
let dockerfile_path = Fpath.(temp_dir / "Dockerfile") in
- Bos.OS.File.write dockerfile_path
- (Dockerfile.string_of_t dockerfile) |> ignore;
+ Bos.OS.File.write dockerfile_path (Dockerfile.string_of_t dockerfile)
+ |> ignore;
(* Docker build *)
let tag = Printf.sprintf "day11-%s:%s" os_distribution os_version in
let build_log = Fpath.(temp_dir / "docker-build.log") in
Log.info (fun m -> m "Running docker build (tag: %s)" tag);
let build_run =
Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "docker" % "build" % "--network=host" % "--no-cache"
- % "-t" % tag % Fpath.to_string temp_dir)
+ Bos.Cmd.(
+ v "docker"
+ % "build"
+ % "--network=host"
+ % "--no-cache"
+ % "-t"
+ % tag
+ % Fpath.to_string temp_dir)
(Some build_log)
in
match build_run.status with
- | `Exited 0 ->
+ | `Exited 0 -> (
Log.info (fun m -> m "Docker build succeeded, importing");
(* Import the built image *)
Bos.OS.Dir.create ~path:true base_dir |> ignore;
@@ -291,36 +332,48 @@ let build ~sw env ~cache_dir ~os_distribution ~os_version ~arch
(* Clean up temp dir *)
Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
(* Clean up state cache files *)
- (match result with
- | Ok () ->
- ignore (Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "sh" % "-c"
- % Printf.sprintf "rm -f %s"
- (Fpath.to_string
- Fpath.(base_dir / "fs" / "home" / "opam"
- / ".opam" / "repo"
- / "state-*.cache"))));
- (* Save the digest so future loads use it for the hash *)
- (match digest with
- | Some d -> save_digest base_dir d
- | None -> ());
- let image_for_hash = match digest with
- | Some d -> d | None -> image in
- Ok (make_base_layer ~image:image_for_hash ~base_dir)
- | Error _ as e -> e)
+ match result with
+ | Ok () ->
+ ignore
+ (Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "sh"
+ % "-c"
+ % Printf.sprintf "rm -f %s"
+ (Fpath.to_string
+ Fpath.(
+ base_dir
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / "repo"
+ / "state-*.cache"))));
+ (* Save the digest so future loads use it for the hash *)
+ (match digest with
+ | Some d -> save_digest base_dir d
+ | None -> ());
+ let image_for_hash =
+ match digest with Some d -> d | None -> image
+ in
+ Ok (make_base_layer ~image:image_for_hash ~base_dir)
+ | Error _ as e -> e)
| `Exited n ->
(* Preserve log and Dockerfile before deleting temp dir *)
let saved_log = Fpath.(cache_dir / "docker-build-failed.log") in
let saved_df = Fpath.(cache_dir / "Dockerfile.failed") in
- ignore (Bos.OS.File.read build_log |> Result.map (fun content ->
- ignore (Bos.OS.File.write saved_log content)));
- ignore (Bos.OS.File.read dockerfile_path |> Result.map (fun content ->
- ignore (Bos.OS.File.write saved_df content)));
+ ignore
+ (Bos.OS.File.read build_log
+ |> Result.map (fun content ->
+ ignore (Bos.OS.File.write saved_log content)));
+ ignore
+ (Bos.OS.File.read dockerfile_path
+ |> Result.map (fun content ->
+ ignore (Bos.OS.File.write saved_df content)));
Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
Rresult.R.error_msgf
- "Docker build failed (exit %d). Log saved to: %a\nSTDERR:\n%s"
- n Fpath.pp saved_log build_run.errors
+ "Docker build failed (exit %d). Log saved to: %a\nSTDERR:\n%s" n
+ Fpath.pp saved_log build_run.errors
| `Signaled n ->
Day11_sys.Sudo.rm_rf ~sw env temp_dir |> ignore;
- Rresult.R.error_msgf "Docker build signaled %d" n
- end
+ Rresult.R.error_msgf "Docker build signaled %d" n)
File "day11/opam_build/base.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/base.mli b/_build/default/day11/opam_build/.formatted/base.mli
index 317f58a..abecfe9 100644
--- a/_build/default/day11/opam_build/base.mli
+++ b/_build/default/day11/opam_build/.formatted/base.mli
@@ -1,14 +1,13 @@
(** Base image management.
- Builds and caches the root filesystem layer that all package builds
- start from. The base contains a Debian image with opam, build tools,
- and pre-initialised opam repositories. Docker is used to produce the
- image, which is then imported as a layer for overlayfs use.
+ Builds and caches the root filesystem layer that all package builds start
+ from. The base contains a Debian image with opam, build tools, and
+ pre-initialised opam repositories. Docker is used to produce the image,
+ which is then imported as a layer for overlayfs use.
- When a [digest] is provided (e.g. [sha256:abc123...] from the
- profile), the base image is pulled by digest for reproducibility.
- The digest is saved alongside the base layer so future loads use
- the same hash. *)
+ When a [digest] is provided (e.g. [sha256:abc123...] from the profile), the
+ base image is pulled by digest for reproducibility. The digest is saved
+ alongside the base layer so future loads use the same hash. *)
val ensure :
sw:Eio.Switch.t ->
@@ -16,8 +15,8 @@ val ensure :
cache_dir:Fpath.t ->
image:string ->
(Day11_layer.Base.t, [> Rresult.R.msg ]) result
-(** Ensure a base layer exists for the given Docker [image] tag,
- building and importing it if not already cached. *)
+(** Ensure a base layer exists for the given Docker [image] tag, building and
+ importing it if not already cached. *)
val build :
sw:Eio.Switch.t ->
@@ -31,11 +30,11 @@ val build :
?digest:string ->
unit ->
(Day11_layer.Base.t, [> Rresult.R.msg ]) result
-(** Build a base layer from scratch. When [digest] is provided
- (e.g. from {!Day11_batch.Profile.base_image_digest}), the
- Dockerfile uses [debian\@sha256:...] instead of [debian:bookworm]
- for a reproducible base. The digest is saved on disk so that
- {!load_cached} returns a base with the correct hash. *)
+(** Build a base layer from scratch. When [digest] is provided (e.g. from
+ {!Day11_batch.Profile.base_image_digest}), the Dockerfile uses
+ [debian\@sha256:...] instead of [debian:bookworm] for a reproducible base.
+ The digest is saved on disk so that {!load_cached} returns a base with the
+ correct hash. *)
val build_opam_build :
sw:Eio.Switch.t ->
@@ -52,25 +51,28 @@ val opam_build_mount :
?opam_build_repo:Fpath.t ->
unit ->
Day11_container.Mount.t option
-(** Return a read-only bind mount for the cached [opam-build] binary
- associated with the given [opam_build_repo] (or the upstream
- master build when [None]). Profiles with different local
- checkouts get their own cached binaries; the mount shadows the
- binary (if any) baked into the base image. *)
+(** Return a read-only bind mount for the cached [opam-build] binary associated
+ with the given [opam_build_repo] (or the upstream master build when [None]).
+ Profiles with different local checkouts get their own cached binaries; the
+ mount shadows the binary (if any) baked into the base image. *)
val hash : image:string -> string
(** Compute a content hash for a Docker image identifier (tag or digest). *)
val build_hash :
- os_distribution:string -> os_version:string -> arch:string ->
- ?digest:string -> unit -> string
-(** Compute the base hash. When [digest] is provided, it is used
- instead of the tag name, ensuring the hash changes when the
- upstream image is updated. *)
+ os_distribution:string ->
+ os_version:string ->
+ arch:string ->
+ ?digest:string ->
+ unit ->
+ string
+(** Compute the base hash. When [digest] is provided, it is used instead of the
+ tag name, ensuring the hash changes when the upstream image is updated. *)
val load_cached :
cache_dir:Fpath.t ->
- os_distribution:string -> os_version:string ->
+ os_distribution:string ->
+ os_version:string ->
Day11_layer.Base.t option
-(** Load a previously cached base layer. Uses the stored digest
- (if any) for the hash, otherwise falls back to the tag name. *)
+(** Load a previously cached base layer. Uses the stored digest (if any) for the
+ hash, otherwise falls back to the tag name. *)
File "day11/opam_build/build_layer.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/build_layer.ml b/_build/default/day11/opam_build/.formatted/build_layer.ml
index d4cf593..cc0b8f6 100644
--- a/_build/default/day11/opam_build/build_layer.ml
+++ b/_build/default/day11/opam_build/.formatted/build_layer.ml
@@ -1,11 +1,10 @@
let src = Logs.Src.create "day11.build.build_layer" ~doc:"Package build"
-module Log = (val Logs.src_log src)
+module Log = (val Logs.src_log src)
module Build = Day11_opam_layer.Build
module Layer = Day11_layer.Layer
-let mkdir path =
- Bos.OS.Dir.create ~path:true path |> ignore
+let mkdir path = Bos.OS.Dir.create ~path:true path |> ignore
(* Re-exports for backward compatibility — the helpers now live in
Container_backend. *)
@@ -19,51 +18,52 @@ let result_of_layer env layer (node : Build.t) =
else Types.Failure (Build.dir_name node)
let exit_code_of (run : Day11_sys.Run.t) =
- match run.status with
- | `Exited n -> n
- | `Signaled n -> 128 + n
+ match run.status with `Exited n -> n | `Signaled n -> 128 + n
-(** Format the transitive dependency tree of a build node, deduped
- by build_hash and ordered by package name, for inclusion at the
- top of layer.log. The list shows the actual layer stack mounted
- in the container, which is what differs between universes — so
- diff'ing two layer.log headers immediately reveals why two
- universes' builds disagree (different fmt version, different
+(** Format the transitive dependency tree of a build node, deduped by build_hash
+ and ordered by package name, for inclusion at the top of layer.log. The list
+ shows the actual layer stack mounted in the container, which is what differs
+ between universes — so diff'ing two layer.log headers immediately reveals
+ why two universes' builds disagree (different fmt version, different
compiler, etc.). *)
let format_deps_block (node : Build.t) =
let seen = Hashtbl.create 32 in
let acc = ref [] in
let rec walk (b : Build.t) =
- if not (Hashtbl.mem seen b.hash) then begin
+ if not (Hashtbl.mem seen b.hash) then (
Hashtbl.replace seen b.hash ();
List.iter walk b.deps;
- acc := b :: !acc
- end
+ acc := b :: !acc)
in
List.iter walk node.Build.deps;
- let sorted = List.sort (fun (a : Build.t) (b : Build.t) ->
- OpamPackage.compare a.pkg b.pkg) (List.rev !acc) in
- let lines = List.map (fun (d : Build.t) ->
- Printf.sprintf " %-50s %s"
- (OpamPackage.to_string d.pkg)
- (String.sub d.hash 0 (min 12 (String.length d.hash)))
- ) sorted in
+ let sorted =
+ List.sort
+ (fun (a : Build.t) (b : Build.t) -> OpamPackage.compare a.pkg b.pkg)
+ (List.rev !acc)
+ in
+ let lines =
+ List.map
+ (fun (d : Build.t) ->
+ Printf.sprintf " %-50s %s"
+ (OpamPackage.to_string d.pkg)
+ (String.sub d.hash 0 (min 12 (String.length d.hash))))
+ sorted
+ in
Printf.sprintf "=== DEPENDENCIES (%d transitive) ===\n%s\n"
(List.length sorted) (String.concat "\n" lines)
-(** Persist everything we know about the build BEFORE attempting it,
- so a failed build remains diagnosable.
+(** Persist everything we know about the build BEFORE attempting it, so a failed
+ build remains diagnosable.
- Writes [build.json] (with [installed_libs]/[installed_docs] empty
- — those need a successful build to scan), the [base] symlink,
- the [opam-repository/] slice, and the runc [config.json]
- template. None of these need the build to have succeeded; they
- describe its inputs.
+ Writes [build.json] (with [installed_libs]/[installed_docs] empty — those
+ need a successful build to scan), the [base] symlink, the [opam-repository/]
+ slice, and the runc [config.json] template. None of these need the build to
+ have succeeded; they describe its inputs.
- The presence-of-[layer.json] convention still marks success; this
- function never touches [layer.json]. *)
-let record_input env ~layer ~node ~benv
- ?patches ?strategy ?(snapshot_repos = []) () =
+ The presence-of-[layer.json] convention still marks success; this function
+ never touches [layer.json]. *)
+let record_input env ~layer ~node ~benv ?patches ?strategy
+ ?(snapshot_repos = []) () =
let _ = env in
let layer_dir = Layer.dir layer in
(* Symlink to the base layer dir so a human inspecting this layer
@@ -72,42 +72,50 @@ let record_input env ~layer ~node ~benv
a different filesystem), the recorded [base_image] field below
still identifies which image was used. *)
let base_link = Fpath.(layer_dir / "base") in
- (try Unix.symlink (Fpath.to_string benv.Types.base.dir)
- (Fpath.to_string base_link)
+ (try
+ Unix.symlink
+ (Fpath.to_string benv.Types.base.dir)
+ (Fpath.to_string base_link)
with Unix.Unix_error _ -> ());
- let cmd = match strategy with
- | Some s -> s.Types.cmd
- | None -> ""
+ let cmd = match strategy with Some s -> s.Types.cmd | None -> "" in
+ let build_meta : Day11_opam_layer.Build_meta.t =
+ {
+ package = OpamPackage.to_string node.Build.pkg;
+ deps =
+ List.map
+ (fun (d : Build.t) ->
+ {
+ Day11_opam_layer.Build_meta.pkg = OpamPackage.to_string d.pkg;
+ hash = d.hash;
+ })
+ node.Build.deps;
+ stack = Container_backend.collect_transitive_dep_hashes node;
+ installed_libs = [];
+ installed_docs = [];
+ patches =
+ (match patches with
+ | Some p -> Patches.patch_filenames p node.Build.pkg
+ | None -> []);
+ base_image = benv.Types.base.image;
+ cmd;
+ universe = Day11_solution.Universe.to_string node.Build.universe;
+ }
in
- let build_meta : Day11_opam_layer.Build_meta.t = {
- package = OpamPackage.to_string node.Build.pkg;
- deps = List.map (fun (d : Build.t) ->
- { Day11_opam_layer.Build_meta.pkg = OpamPackage.to_string d.pkg;
- hash = d.hash })
- node.Build.deps;
- stack = Container_backend.collect_transitive_dep_hashes node;
- installed_libs = [];
- installed_docs = [];
- patches = (match patches with
- | Some p -> Patches.patch_filenames p node.Build.pkg
- | None -> []);
- base_image = benv.Types.base.image;
- cmd;
- universe = Day11_solution.Universe.to_string node.Build.universe;
- } in
let _ = Day11_opam_layer.Build_meta.save layer_dir build_meta in
let slice_written =
- if snapshot_repos <> [] then begin
- let patch_files = match patches with
+ if snapshot_repos <> [] then
+ let patch_files =
+ match patches with
| Some p -> List.map Fpath.v (Patches.patches_for p node.Build.pkg)
| None -> []
in
- match Day11_opam_layer.Opam_repo.snapshot_to_layer
- ~layer_dir ~opam_repositories:snapshot_repos
- ~patches:patch_files node.Build.pkg with
+ match
+ Day11_opam_layer.Opam_repo.snapshot_to_layer ~layer_dir
+ ~opam_repositories:snapshot_repos ~patches:patch_files node.Build.pkg
+ with
| Ok () -> true
| Error _ -> false
- end else false
+ else false
in
(* Write a runc-runnable [config.json] template. Mounts the
per-layer opam-repository slice (when one was written) at
@@ -118,131 +126,138 @@ let record_input env ~layer ~node ~benv
match strategy with
| None -> ()
| Some s ->
- let slice_mount =
- if slice_written
- then [ Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string
- Fpath.(layer_dir / "opam-repository"))
- "/home/opam/.opam/repo/default" ]
- else []
- in
- let spec =
- Container_backend.opam_build_spec
- ~cmd:s.Types.cmd
- ~mounts:slice_mount
- ~uid:benv.Types.uid ~gid:benv.gid ()
- in
- let _ = Day11_container.Oci_spec.write_template
- Fpath.(layer_dir / "config.json") spec in
- ()
+ let slice_mount =
+ if slice_written then
+ [
+ Day11_container.Mount.bind_ro
+ ~src:(Fpath.to_string Fpath.(layer_dir / "opam-repository"))
+ "/home/opam/.opam/repo/default";
+ ]
+ else []
+ in
+ let spec =
+ Container_backend.opam_build_spec ~cmd:s.Types.cmd ~mounts:slice_mount
+ ~uid:benv.Types.uid ~gid:benv.gid ()
+ in
+ let _ =
+ Day11_container.Oci_spec.write_template
+ Fpath.(layer_dir / "config.json")
+ spec
+ in
+ ()
(** Persist the result of a build attempt.
- [layer.log] is always written so failed builds remain
- diagnosable. [layer.json] is written ONLY for successful builds
- ([exit_code = 0]); its presence is the success marker —
- [{!Day11_layer.Layer.is_ok}] returns true iff this file exists.
- Failure tracking also lives in [<os_dir>/layer_status.jsonl] (see
- {!Day11_layer.Layer_status}), recording exit_status without
- polluting the layer cache.
+ [layer.log] is always written so failed builds remain diagnosable.
+ [layer.json] is written ONLY for successful builds ([exit_code = 0]); its
+ presence is the success marker — [{!Day11_layer.Layer.is_ok}] returns true
+ iff this file exists. Failure tracking also lives in
+ [<os_dir>/layer_status.jsonl] (see {!Day11_layer.Layer_status}), recording
+ exit_status without polluting the layer cache.
- On success, also re-writes [build.json] to fill in
- [installed_libs] and [installed_docs] — both fields require the
- build to have actually run and produced [fs/]. The other fields
- were already populated by {!record_input} pre-build. *)
+ On success, also re-writes [build.json] to fill in [installed_libs] and
+ [installed_docs] — both fields require the build to have actually run and
+ produced [fs/]. The other fields were already populated by {!record_input}
+ pre-build. *)
let record_attempt env ~layer ~node ~benv ~timing ?patches
(run : Day11_sys.Run.t) =
let exit_code = exit_code_of run in
- let _ = Bos.OS.File.write (Layer.log_path layer)
- (Printf.sprintf "%s=== STDOUT ===\n%s\n=== STDERR ===\n%s\n"
- (format_deps_block node) run.output run.errors) in
- if exit_code = 0 then begin
- let dep_hashes =
- List.map (fun (d : Build.t) -> d.hash) node.Build.deps in
- let disk_usage = match Day11_sys.Util.dir_size (Layer.dir layer) with
- | Ok size -> size
- | Error _ -> 0
- in
- let meta : Day11_layer.Meta.t = {
- exit_status = 0;
- parent_hashes = dep_hashes;
- uid = benv.Types.uid; gid = benv.gid;
- base_hash = benv.base.hash;
- disk_usage;
- timing;
- created_at = "";
- failed_dep = None;
- } in
- let _ = Day11_layer.Meta.save env (Layer.meta_path layer) meta in
- let layer_dir = Layer.dir layer in
- (* Re-load the input-side build.json written by [record_input],
+ let _ =
+ Bos.OS.File.write (Layer.log_path layer)
+ (Printf.sprintf "%s=== STDOUT ===\n%s\n=== STDERR ===\n%s\n"
+ (format_deps_block node) run.output run.errors)
+ in
+ (if exit_code = 0 then
+ let dep_hashes = List.map (fun (d : Build.t) -> d.hash) node.Build.deps in
+ let disk_usage =
+ match Day11_sys.Util.dir_size (Layer.dir layer) with
+ | Ok size -> size
+ | Error _ -> 0
+ in
+ let meta : Day11_layer.Meta.t =
+ {
+ exit_status = 0;
+ parent_hashes = dep_hashes;
+ uid = benv.Types.uid;
+ gid = benv.gid;
+ base_hash = benv.base.hash;
+ disk_usage;
+ timing;
+ created_at = "";
+ failed_dep = None;
+ }
+ in
+ let _ = Day11_layer.Meta.save env (Layer.meta_path layer) meta in
+ let layer_dir = Layer.dir layer in
+ (* Re-load the input-side build.json written by [record_input],
fill in the post-build scan results, save again. Falling back
to a fresh record if the load fails keeps things robust if a
caller invoked [record_attempt] without [record_input]. *)
- let bm =
- match Day11_opam_layer.Build_meta.load layer_dir with
- | Ok bm -> bm
- | Error _ -> {
- package = OpamPackage.to_string node.Build.pkg;
- deps = List.map (fun (d : Build.t) ->
- { Day11_opam_layer.Build_meta.pkg = OpamPackage.to_string d.pkg;
- hash = d.hash })
- node.Build.deps;
- stack = Container_backend.collect_transitive_dep_hashes node;
- installed_libs = [];
- installed_docs = [];
- patches = (match patches with
- | Some p -> Patches.patch_filenames p node.Build.pkg
- | None -> []);
- base_image = benv.Types.base.image;
- cmd = "";
- universe = Day11_solution.Universe.to_string node.Build.universe;
- }
- in
- let bm = {
- bm with
- installed_libs =
- Day11_opam_layer.Installed_files.scan_libs ~layer_dir;
- installed_docs =
- Day11_opam_layer.Installed_files.scan_docs ~layer_dir;
- } in
- let _ = Day11_opam_layer.Build_meta.save layer_dir bm in
- ()
- end;
+ let bm =
+ match Day11_opam_layer.Build_meta.load layer_dir with
+ | Ok bm -> bm
+ | Error _ ->
+ {
+ package = OpamPackage.to_string node.Build.pkg;
+ deps =
+ List.map
+ (fun (d : Build.t) ->
+ {
+ Day11_opam_layer.Build_meta.pkg =
+ OpamPackage.to_string d.pkg;
+ hash = d.hash;
+ })
+ node.Build.deps;
+ stack = Container_backend.collect_transitive_dep_hashes node;
+ installed_libs = [];
+ installed_docs = [];
+ patches =
+ (match patches with
+ | Some p -> Patches.patch_filenames p node.Build.pkg
+ | None -> []);
+ base_image = benv.Types.base.image;
+ cmd = "";
+ universe = Day11_solution.Universe.to_string node.Build.universe;
+ }
+ in
+ let bm =
+ {
+ bm with
+ installed_libs = Day11_opam_layer.Installed_files.scan_libs ~layer_dir;
+ installed_docs = Day11_opam_layer.Installed_files.scan_docs ~layer_dir;
+ }
+ in
+ let _ = Day11_opam_layer.Build_meta.save layer_dir bm in
+ ());
let os_dir = Fpath.parent (Layer.dir layer) in
- Day11_layer.Layer_status.append ~os_dir
- ~hash:(Layer.hash layer) ~exit_status:exit_code;
+ Day11_layer.Layer_status.append ~os_dir ~hash:(Layer.hash layer)
+ ~exit_status:exit_code;
exit_code
-(** Container setup itself failed (couldn't even run the build). Just
- log the outcome to {!Day11_layer.Layer_status}; don't write any
- layer.json. *)
+(** Container setup itself failed (couldn't even run the build). Just log the
+ outcome to {!Day11_layer.Layer_status}; don't write any layer.json. *)
let record_setup_failure ~layer =
let os_dir = Fpath.parent (Layer.dir layer) in
- Day11_layer.Layer_status.append ~os_dir
- ~hash:(Layer.hash layer) ~exit_status:1
+ Day11_layer.Layer_status.append ~os_dir ~hash:(Layer.hash layer)
+ ~exit_status:1
(** Main entry point. *)
-let build ?(backend = (module Container_backend : Backend.S))
- ~sw env (benv : Types.build_env)
- ~opam_repositories ?snapshot_repos ?mounts
- ?patches ?build_dirs ?prep_upper
- ?(on_extract = fun ~layer_dir:_ ~success:_ -> ())
- (node : Build.t)
- ?strategy () =
+let build ?(backend = (module Container_backend : Backend.S)) ~sw env
+ (benv : Types.build_env) ~opam_repositories ?snapshot_repos ?mounts ?patches
+ ?build_dirs ?prep_upper ?(on_extract = fun ~layer_dir:_ ~success:_ -> ())
+ (node : Build.t) ?strategy () =
(* If the caller didn't explicitly supply [snapshot_repos], fall
back to the in-flight [opam_repositories] (rerun's case) — both
describe the source of opam metadata for this build. *)
- let snapshot_repos = match snapshot_repos with
- | Some r -> r
- | None -> opam_repositories
+ let snapshot_repos =
+ match snapshot_repos with Some r -> r | None -> opam_repositories
in
let os_dir = benv.os_dir in
let pkg_str = OpamPackage.to_string node.pkg in
let layer_name = Build.dir_name node in
let module B = (val backend : Backend.S) in
let layer = Build.layer ~os_dir node in
- if Layer.exists env layer then begin
+ if Layer.exists env layer then (
(* Layer dir with [layer.json] means a previous attempt
succeeded — content-addressed, deterministic, durable. Failed
attempts leave only a [layer.log] (no layer.json), so they
@@ -250,8 +265,8 @@ let build ?(backend = (module Container_backend : Backend.S))
OCurrent's rebuild flow. *)
Log.info (fun m -> m "Cache hit: %s (%s)" pkg_str layer_name);
Day11_layer.Last_used.touch env (Layer.dir layer);
- result_of_layer env layer node
- end else begin
+ result_of_layer env layer node)
+ else (
Log.info (fun m -> m "Building %s (%s)" pkg_str layer_name);
let layer_dir = Layer.dir layer in
let lock_file = Fpath.(os_dir / (layer_name ^ ".lock")) in
@@ -271,14 +286,14 @@ let build ?(backend = (module Container_backend : Backend.S))
back to [opam_build_strategy ?patches node.pkg] when no
strategy is passed; lifting the resolution doesn't change
behaviour. *)
- let resolved_strategy = match strategy with
+ let resolved_strategy =
+ match strategy with
| Some s -> s
| None -> Container_backend.opam_build_strategy ?patches node.pkg
in
let _lock_result =
Day11_sys.Dir_lock.with_lock ~marker_file:(Fpath.v "layer.json")
- ~lock_file layer_dir
- (fun ~set_temp_log_path:_ _dir ->
+ ~lock_file layer_dir (fun ~set_temp_log_path:_ _dir ->
mkdir layer_dir;
(* Persist the build's input description {b before} we run
it. If the build fails (or the host crashes mid-build),
@@ -289,16 +304,16 @@ let build ?(backend = (module Container_backend : Backend.S))
record_input env ~layer ~node ~benv ?patches
~strategy:resolved_strategy ~snapshot_repos ();
let target_fs = Layer.fs layer in
- match B.build ~sw env benv
- ~opam_repositories ?mounts ?patches ?build_dirs
- ?prep_upper ~strategy:resolved_strategy node
- ~target_fs () with
+ match
+ B.build ~sw env benv ~opam_repositories ?mounts ?patches ?build_dirs
+ ?prep_upper ~strategy:resolved_strategy node ~target_fs ()
+ with
| Ok (run, timing) ->
let exit_code =
- record_attempt env ~layer ~node ~benv ~timing
- ?patches run in
- Log.info (fun m -> m "Build %s: exit %d (%.1fs)"
- pkg_str exit_code run.time);
+ record_attempt env ~layer ~node ~benv ~timing ?patches run
+ in
+ Log.info (fun m ->
+ m "Build %s: exit %d (%.1fs)" pkg_str exit_code run.time);
on_extract ~layer_dir ~success:(exit_code = 0);
Ok ()
| Error (`Msg e) ->
@@ -308,8 +323,5 @@ let build ?(backend = (module Container_backend : Backend.S))
on_extract ~layer_dir:(Layer.dir layer) ~success:false;
Ok ())
in
- if Layer.is_ok env layer then
- result_of_layer env layer node
- else
- Types.Failure layer_name
- end
+ if Layer.is_ok env layer then result_of_layer env layer node
+ else Types.Failure layer_name)
File "day11/opam_build/build_layer.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/build_layer.mli b/_build/default/day11/opam_build/.formatted/build_layer.mli
index 20ea695..7c0598f 100644
--- a/_build/default/day11/opam_build/build_layer.mli
+++ b/_build/default/day11/opam_build/.formatted/build_layer.mli
@@ -1,19 +1,17 @@
(** Build one layer via a {!Backend.S}.
- Handles the backend-agnostic parts of the build lifecycle:
- cache lookup, layer locking, writing the generic [layer.json],
- calling [on_extract] so callers can drop domain-specific
- sidecars. The backend (typically {!Container_backend}) owns
- the part that differs: stacking deps, running the build,
- capturing the filesystem diff. *)
+ Handles the backend-agnostic parts of the build lifecycle: cache lookup,
+ layer locking, writing the generic [layer.json], calling [on_extract] so
+ callers can drop domain-specific sidecars. The backend (typically
+ {!Container_backend}) owns the part that differs: stacking deps, running the
+ build, capturing the filesystem diff. *)
(** {1 Container-backend helpers}
These used to live directly in {!Build_layer}. They are now
- container-specific primitives in {!Container_backend} and
- re-exported here for backward compatibility — callers that
- build a custom [?strategy] on top of [opam-build] typically
- compose with [opam_build_cleanup], etc. *)
+ container-specific primitives in {!Container_backend} and re-exported here
+ for backward compatibility — callers that build a custom [?strategy] on top
+ of [opam-build] typically compose with [opam_build_cleanup], etc. *)
val opam_build_cleanup :
sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> Fpath.t -> unit
@@ -24,14 +22,20 @@ val opam_build_spec :
?numa_mems:string ->
cmd:string ->
mounts:Day11_container.Mount.t list ->
- uid:int -> gid:int ->
+ uid:int ->
+ gid:int ->
unit ->
Day11_container.Oci_spec.t
(** See {!Container_backend.opam_build_spec}. *)
val opam_build_prep_upper :
- sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> uid:int -> gid:int ->
- upper:Fpath.t -> lowers:Fpath.t list -> unit
+ sw:Eio.Switch.t ->
+ Eio_unix.Stdenv.base ->
+ uid:int ->
+ gid:int ->
+ upper:Fpath.t ->
+ lowers:Fpath.t list ->
+ unit
(** See {!Container_backend.opam_build_prep_upper}. *)
(** {1 Main entry point} *)
@@ -52,35 +56,35 @@ val build :
?strategy:Types.build_strategy ->
unit ->
Types.build_result
-(** [build ?backend ~sw env benv ?... node ()] builds [node] via
- [backend] (default: {!Container_backend}), writes its generic
- [layer.json], and calls [on_extract] so the caller can write
- any domain-specific sidecar files.
+(** [build ?backend ~sw env benv ?... node ()] builds [node] via [backend]
+ (default: {!Container_backend}), writes its generic [layer.json], and calls
+ [on_extract] so the caller can write any domain-specific sidecar files.
- @param backend The build backend to use. Defaults to
- {!Container_backend} — the runc + overlayfs implementation
- that day11's pipeline has always used. {!Native_backend}
- (Phase 2) is an alternative for host-native builds without
- sudo.
- @param opam_repositories Repo source paths the backend extracts a
- one-package slice from to mount as the container's [default]
- repo. Required (see {!Backend.S.build}): pass [[]] only to
- deliberately fall back to the base image's full opam-repository.
- @param snapshot_repos Source repositories from which to take a
- one-package opam-repository slice for the layer dir's
- [opam-repository/] subdir. Defaults to [opam_repositories]
- when not given. Pass [Some []] to skip slice writing
- altogether. The resulting slice plus the layer's [fs/] make
- every successful layer self-describing for cold-storage
- rerun.
- @param build_dirs Override the dep layer directories stacked
- as overlay lowers. By default ([None]), collects the
- transitive deps of [node] from the cache.
- @param prep_upper Override the pre-mount prep callback.
- Container backend default: dump opam switch-state + chown
- [/home]. Ignored by non-container backends.
- @param on_extract Called after a build's [fs/] has been moved
- into place and [layer.json] written, with [success:true] iff
- exit status was 0. NOT called on cache hits.
+ @param backend
+ The build backend to use. Defaults to {!Container_backend} — the runc +
+ overlayfs implementation that day11's pipeline has always used.
+ {!Native_backend} (Phase 2) is an alternative for host-native builds
+ without sudo.
+ @param opam_repositories
+ Repo source paths the backend extracts a one-package slice from to mount
+ as the container's [default] repo. Required (see {!Backend.S.build}): pass
+ [[]] only to deliberately fall back to the base image's full
+ opam-repository.
+ @param snapshot_repos
+ Source repositories from which to take a one-package opam-repository slice
+ for the layer dir's [opam-repository/] subdir. Defaults to
+ [opam_repositories] when not given. Pass [Some []] to skip slice writing
+ altogether. The resulting slice plus the layer's [fs/] make every
+ successful layer self-describing for cold-storage rerun.
+ @param build_dirs
+ Override the dep layer directories stacked as overlay lowers. By default
+ ([None]), collects the transitive deps of [node] from the cache.
+ @param prep_upper
+ Override the pre-mount prep callback. Container backend default: dump opam
+ switch-state + chown [/home]. Ignored by non-container backends.
+ @param on_extract
+ Called after a build's [fs/] has been moved into place and [layer.json]
+ written, with [success:true] iff exit status was 0. NOT called on cache
+ hits.
Default strategy is [opam-build -v <pkg>]. *)
File "day11/opam_build/compiler_pkg.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/compiler_pkg.ml b/_build/default/day11/opam_build/.formatted/compiler_pkg.ml
index ae0a33b..d7c2b17 100644
--- a/_build/default/day11/opam_build/compiler_pkg.ml
+++ b/_build/default/day11/opam_build/.formatted/compiler_pkg.ml
@@ -3,8 +3,9 @@
real compiler out of [ocaml-base-compiler] into [ocaml-compiler]
at 5.3.0; [oxcaml-compiler] is the oxcaml equivalent. We document
these so downstream cross-references like [Stdlib.Format] resolve. *)
-let names = List.map OpamPackage.Name.of_string
- [ "ocaml-compiler"; "ocaml-base-compiler"; "oxcaml-compiler" ]
+let names =
+ List.map OpamPackage.Name.of_string
+ [ "ocaml-compiler"; "ocaml-base-compiler"; "oxcaml-compiler" ]
let v_5_3_0 = OpamPackage.Version.of_string "5.3.0"
@@ -19,11 +20,11 @@ let is_compiler (pkg : OpamPackage.t) : bool =
| "ocaml-base-compiler" -> cmp version v_5_3_0 < 0
| _ -> false
-(** Post-build invariant for compiler packages: their build layer
- should contain [lib/ocaml/stdlib.cmti]. Returns [Ok ()] for
- non-compiler packages, doc layers (which have [odoc-out/] rather
- than [lib/ocaml/]), or when the file is present. Returns [Error]
- when the package was {e expected} to install stdlib but didn't. *)
+(** Post-build invariant for compiler packages: their build layer should contain
+ [lib/ocaml/stdlib.cmti]. Returns [Ok ()] for non-compiler packages, doc
+ layers (which have [odoc-out/] rather than [lib/ocaml/]), or when the file
+ is present. Returns [Error] when the package was {e expected} to install
+ stdlib but didn't. *)
let check_stdlib_installed ~build_layer (pkg : OpamPackage.t) =
if not (is_compiler pkg) then Ok ()
else
@@ -32,17 +33,26 @@ let check_stdlib_installed ~build_layer (pkg : OpamPackage.t) =
[Container_backend.build] but produce [odoc-out/], not
[lib/ocaml/]. Skip the stdlib check for those — the real
package build's layer is what we actually want to validate. *)
- if Bos.OS.Dir.exists odoc_out |> Result.value ~default:false
- then Ok ()
+ if Bos.OS.Dir.exists odoc_out |> Result.value ~default:false then Ok ()
else
let stdlib_cmti =
- Fpath.(build_layer / "fs" / "home" / "opam" / ".opam"
- / "default" / "lib" / "ocaml" / "stdlib.cmti") in
- if Bos.OS.File.exists stdlib_cmti |> Result.value ~default:false
- then Ok ()
+ Fpath.(
+ build_layer
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / "default"
+ / "lib"
+ / "ocaml"
+ / "stdlib.cmti")
+ in
+ if Bos.OS.File.exists stdlib_cmti |> Result.value ~default:false then
+ Ok ()
else
Rresult.R.error_msgf
"%s: classified as a compiler package but did not install %a — \
downstream Stdlib xrefs will not resolve. Either the package's \
build is broken or [Compiler_pkg.is_compiler] needs updating."
- (OpamPackage.to_string pkg) Fpath.pp stdlib_cmti
+ (OpamPackage.to_string pkg)
+ Fpath.pp stdlib_cmti
File "day11/opam_build/compiler_pkg.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/compiler_pkg.mli b/_build/default/day11/opam_build/.formatted/compiler_pkg.mli
index 2afbc4a..4d4ae45 100644
--- a/_build/default/day11/opam_build/compiler_pkg.mli
+++ b/_build/default/day11/opam_build/.formatted/compiler_pkg.mli
@@ -1,32 +1,28 @@
-(** Identification of "real compiler" packages and a post-build
- sanity check on their install.
+(** Identification of "real compiler" packages and a post-build sanity check on
+ their install.
- The {e real} compiler is the package whose build script actually
- runs [./configure && make && make install] and lays down
- [lib/ocaml/stdlib*.cmti]. Mainline split this out of
- [ocaml-base-compiler] into [ocaml-compiler] at 5.3.0; oxcaml's
- equivalent is [oxcaml-compiler]. Wrappers ([ocaml-variants],
- post-5.3.0 [ocaml-base-compiler], [ocaml-system]) carry
- [flags: compiler] in opam but install nothing of substance. *)
+ The {e real} compiler is the package whose build script actually runs
+ [./configure && make && make install] and lays down
+ [lib/ocaml/stdlib*.cmti]. Mainline split this out of [ocaml-base-compiler]
+ into [ocaml-compiler] at 5.3.0; oxcaml's equivalent is [oxcaml-compiler].
+ Wrappers ([ocaml-variants], post-5.3.0 [ocaml-base-compiler],
+ [ocaml-system]) carry [flags: compiler] in opam but install nothing of
+ substance. *)
val names : OpamPackage.Name.t list
-(** Cheap name-based prefilter: the set of names {!is_compiler} can
- return true for. Use {!is_compiler} for an authoritative check
- (it includes a version split). *)
+(** Cheap name-based prefilter: the set of names {!is_compiler} can return true
+ for. Use {!is_compiler} for an authoritative check (it includes a version
+ split). *)
val is_compiler : OpamPackage.t -> bool
(** [is_compiler pkg] returns true for the real-compiler packages:
- {ul
- {- [ocaml-compiler] {b ≥} 5.3.0}
- {- [ocaml-base-compiler] {b <} 5.3.0}
- {- [oxcaml-compiler] (any version).}}
-*)
+ - [ocaml-compiler] {b ≥} 5.3.0
+ - [ocaml-base-compiler] {b <} 5.3.0
+ - [oxcaml-compiler] (any version). *)
val check_stdlib_installed :
- build_layer:Fpath.t ->
- OpamPackage.t ->
- (unit, [> Rresult.R.msg ]) result
-(** [check_stdlib_installed ~build_layer pkg] is the post-build
- invariant for compiler packages: their build must have left
- [lib/ocaml/stdlib.cmti] in [build_layer/fs/home/opam/.opam/default/].
- For non-compiler packages, returns [Ok ()] without checking. *)
+ build_layer:Fpath.t -> OpamPackage.t -> (unit, [> Rresult.R.msg ]) result
+(** [check_stdlib_installed ~build_layer pkg] is the post-build invariant for
+ compiler packages: their build must have left [lib/ocaml/stdlib.cmti] in
+ [build_layer/fs/home/opam/.opam/default/]. For non-compiler packages,
+ returns [Ok ()] without checking. *)
File "day11/opam_build/container_backend.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/container_backend.ml b/_build/default/day11/opam_build/.formatted/container_backend.ml
index af5affa..506c157 100644
--- a/_build/default/day11/opam_build/container_backend.ml
+++ b/_build/default/day11/opam_build/.formatted/container_backend.ml
@@ -1,35 +1,42 @@
-let src = Logs.Src.create "day11.build.container_backend"
- ~doc:"Container-based opam package build backend"
-module Log = (val Logs.src_log src)
+let src =
+ Logs.Src.create "day11.build.container_backend"
+ ~doc:"Container-based opam package build backend"
+module Log = (val Logs.src_log src)
module Build = Day11_opam_layer.Build
module Layer = Day11_layer.Layer
-let mkdir path =
- Bos.OS.Dir.create ~path:true path |> ignore
+let mkdir path = Bos.OS.Dir.create ~path:true path |> ignore
(** Standard cleanup for opam-build layers. *)
let opam_build_cleanup ~sw env upper =
- let switch_dir = Fpath.(upper / "home" / "opam" / ".opam"
- / Types.switch / ".opam-switch") in
- ignore (Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "rm" % "-rf"
- % Fpath.to_string Fpath.(switch_dir / "sources")
- % Fpath.to_string Fpath.(switch_dir / "build")
- % Fpath.to_string Fpath.(switch_dir / "packages" / "cache")
- % Fpath.to_string Fpath.(upper / "tmp")));
- ignore (Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "sh" % "-c"
- % Printf.sprintf "rm -f %s"
- (Fpath.to_string
- Fpath.(upper / "home" / "opam" / ".opam"
- / "repo" / "state-*.cache"))))
+ let switch_dir =
+ Fpath.(upper / "home" / "opam" / ".opam" / Types.switch / ".opam-switch")
+ in
+ ignore
+ (Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "rm"
+ % "-rf"
+ % Fpath.to_string Fpath.(switch_dir / "sources")
+ % Fpath.to_string Fpath.(switch_dir / "build")
+ % Fpath.to_string Fpath.(switch_dir / "packages" / "cache")
+ % Fpath.to_string Fpath.(upper / "tmp")));
+ ignore
+ (Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "sh"
+ % "-c"
+ % Printf.sprintf "rm -f %s"
+ (Fpath.to_string
+ Fpath.(
+ upper / "home" / "opam" / ".opam" / "repo" / "state-*.cache"))))
let opam_build_strategy ?patches pkg =
let pkg_str = OpamPackage.to_string pkg in
- let patch_args = match patches with
- | Some p when Patches.has_patches p pkg ->
- " " ^ Patches.patch_args p pkg
+ let patch_args =
+ match patches with
+ | Some p when Patches.has_patches p pkg -> " " ^ Patches.patch_args p pkg
| _ -> ""
in
(* TEMPORARY DIAGNOSTIC: run opam-build *under* strace from launch (not
@@ -42,129 +49,131 @@ let opam_build_strategy ?patches pkg =
in-process; a slow child still surfaces as a long wait4 gap). Falls
back to a plain run if strace can't be installed, so builds never
break. Revert to the plain [opam-build -v ...] once diagnosed. *)
- { Types.cmd = Printf.sprintf "opam-build -v %s%s" pkg_str patch_args;
- cleanup = opam_build_cleanup }
+ {
+ Types.cmd = Printf.sprintf "opam-build -v %s%s" pkg_str patch_args;
+ cleanup = opam_build_cleanup;
+ }
(** Default container env for opam-build containers. *)
-let opam_container_env = [
- ("PATH", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin");
- ("HOME", "/home/opam");
-]
+let opam_container_env =
+ [
+ ("PATH", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin");
+ ("HOME", "/home/opam");
+ ]
-(** Build an OCI spec template for an opam-build container running
- [cmd] via [bash -c]. [?cpuset] and [?numa_mems] pin the container
- to a subset of host CPUs / NUMA memory nodes via cgroups, used by
- {!Day11_runner.Cpu_slots} to cap nested build parallelism. *)
-let opam_build_spec ?cpuset ?numa_mems ~cmd ~mounts ~uid ~gid
- () : Day11_container.Oci_spec.t =
- Day11_container.Oci_spec.make
- ~cwd:"/home/opam"
- ~hostname:"builder"
- ~env:opam_container_env
- ~mounts
- ~network:true
- ?cpuset ?numa_mems
+(** Build an OCI spec template for an opam-build container running [cmd] via
+ [bash -c]. [?cpuset] and [?numa_mems] pin the container to a subset of host
+ CPUs / NUMA memory nodes via cgroups, used by {!Day11_runner.Cpu_slots} to
+ cap nested build parallelism. *)
+let opam_build_spec ?cpuset ?numa_mems ~cmd ~mounts ~uid ~gid () :
+ Day11_container.Oci_spec.t =
+ Day11_container.Oci_spec.make ~cwd:"/home/opam" ~hostname:"builder"
+ ~env:opam_container_env ~mounts ~network:true ?cpuset ?numa_mems
~argv:[ "/usr/bin/env"; "bash"; "-c"; cmd ]
- ~uid ~gid
- ()
+ ~uid ~gid ()
(** Default pre-mount prep for opam-build containers. *)
let opam_build_prep_upper ~sw env ~uid ~gid ~upper ~lowers =
- let switch_rel = Fpath.(v "home" / "opam" / ".opam" / Types.switch
- / ".opam-switch") in
+ let switch_rel =
+ Fpath.(v "home" / "opam" / ".opam" / Types.switch / ".opam-switch")
+ in
let packages_rel = Fpath.(switch_rel / "packages") in
- let packages_dirs = List.filter_map (fun dir ->
- let p = Fpath.(dir // packages_rel) in
- if Bos.OS.Dir.exists p |> Result.get_ok then Some p else None
- ) lowers in
- if packages_dirs <> [] then begin
+ let packages_dirs =
+ List.filter_map
+ (fun dir ->
+ let p = Fpath.(dir // packages_rel) in
+ if Bos.OS.Dir.exists p |> Result.get_ok then Some p else None)
+ lowers
+ in
+ if packages_dirs <> [] then (
let state_dir = Fpath.(upper // switch_rel) in
mkdir state_dir;
Day11_opam_layer.Opamh.dump_state packages_dirs
- Fpath.(state_dir / "switch-state") |> ignore
- end;
+ Fpath.(state_dir / "switch-state")
+ |> ignore);
let home_dir = Fpath.(upper / "home") in
if Bos.OS.Dir.exists home_dir |> Result.get_ok then
- ignore (Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "chown" % "-R" % Printf.sprintf "%d:%d" uid gid
- % Fpath.to_string home_dir))
+ ignore
+ (Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "chown"
+ % "-R"
+ % Printf.sprintf "%d:%d" uid gid
+ % Fpath.to_string home_dir))
-(** Collect the transitive dep layer hashes of a build node, in the
- order they are stacked as overlayfs lowers.
+(** Collect the transitive dep layer hashes of a build node, in the order they
+ are stacked as overlayfs lowers.
- Returned in deterministic DFS post-order: every dep appears after
- all its own deps, with duplicates removed by first occurrence.
- The list is then reversed so direct deps sit at the front —
- those become the topmost lowers in overlayfs, matching the
- dependency ordering the DAG was built with.
+ Returned in deterministic DFS post-order: every dep appears after all its
+ own deps, with duplicates removed by first occurrence. The list is then
+ reversed so direct deps sit at the front — those become the topmost lowers
+ in overlayfs, matching the dependency ordering the DAG was built with.
- The previous implementation used [Hashtbl.fold], which gives
- undefined iteration order: two runs of the same node could stack
- the layers differently, so the visible version of single-file-
- across-layers things like [/var/lib/dpkg/status] was
- non-deterministic. For lablgl builds in particular this made
- opam alternately report [libglu1-mesa-dev] as installed or
- uninstalled depending on whichever layer's [dpkg/status] ended
- up topmost — leading to flaky build outcomes.
+ The previous implementation used [Hashtbl.fold], which gives undefined
+ iterationrder: two runs of the same node could stack the layers
+ differently, so the visible version of single-file- across-layers things
+ like [/var/lib/dpkg/status] was non-deterministic. For lablgl builds in
+ particular this made opam alternately report [libglu1-mesa-dev] as installed
+ or uninstalled depending on whichever layer's [dpkg/status] ended up topmost
+ — leading to flaky build outcomes.
- This is the source of truth for the lower-stack order. It is
- recorded verbatim in [build.json] ([Build_meta.t.stack]) so a tool
- replaying the build reconstructs the identical rootfs without
- re-deriving the DAG ordering. *)
+ This is the source of truth for the lower-stack order. It is recorded
+ verbatim in [build.json] ([Build_meta.t.stack]) so a tool replaying the
+ build reconstructs the identical rootfs without re-deriving the DAG
+ ordering. *)
let collect_transitive_dep_hashes (node : Build.t) =
let seen = Hashtbl.create 16 in
let acc = ref [] in
let rec walk (b : Build.t) =
- if not (Hashtbl.mem seen b.hash) then begin
+ if not (Hashtbl.mem seen b.hash) then (
Hashtbl.replace seen b.hash ();
List.iter walk b.deps;
- acc := b.hash :: !acc
- end
+ acc := b.hash :: !acc)
in
List.iter walk node.deps;
List.rev !acc
-(** Collect transitive dep layer dirs from a build node, in
- overlay-stack order. The dir-level view of
- {!collect_transitive_dep_hashes}. *)
+(** Collect transitive dep layer dirs from a build node, in overlay-stack order.
+ The dir-level view of {!collect_transitive_dep_hashes}. *)
let collect_transitive_dep_dirs ~os_dir (node : Build.t) =
- List.map (fun hash -> Layer.dir (Layer.of_hash ~os_dir hash))
+ List.map
+ (fun hash -> Layer.dir (Layer.of_hash ~os_dir hash))
(collect_transitive_dep_hashes node)
-(** Transitive dependency packages of a build node (the full closure,
- deduped). The per-package repo slice mounted at [repo/default] must
- contain {b every} package opam will see as installed — i.e. [node.pkg]
- plus this closure — otherwise opam's switch-state load fails with
- "No definition found for the following installed packages" (it looks
- up each installed package's opam definition in the repo). A 1-package
- slice is too narrow; the full ~18k-package repo is too broad (slow). *)
+(** Transitive dependency packages of a build node (the full closure, deduped).
+ The per-package repo slice mounted at [repo/default] must contain {b every}
+ package opam will see as installed — i.e. [node.pkg] plus this closure —
+ otherwise opam's switch-state load fails with "No definition found for the
+ following installed packages" (it looks up each installed package's opam
+ definition in the repo). A 1-package slice is too narrow; the full
+ ~18k-package repo is too broad (slow). *)
let collect_transitive_dep_pkgs (node : Build.t) =
let seen = Hashtbl.create 16 in
let acc = ref [] in
let rec walk (b : Build.t) =
- if not (Hashtbl.mem seen b.hash) then begin
+ if not (Hashtbl.mem seen b.hash) then (
Hashtbl.replace seen b.hash ();
List.iter walk b.deps;
- acc := b.pkg :: !acc
- end
+ acc := b.pkg :: !acc)
in
List.iter walk node.deps;
List.rev !acc
-let build ~sw env (benv : Types.build_env)
- ~opam_repositories ?(mounts = [])
- ?patches ?build_dirs ?prep_upper
- ?strategy (node : Build.t) ~target_fs () =
+let build ~sw env (benv : Types.build_env) ~opam_repositories ?(mounts = [])
+ ?patches ?build_dirs ?prep_upper ?strategy (node : Build.t) ~target_fs () =
let os_dir = benv.os_dir in
- let strategy = match strategy with
+ let strategy =
+ match strategy with
| Some s -> s
| None -> opam_build_strategy ?patches node.pkg
in
- let dep_dirs = match build_dirs with
+ let dep_dirs =
+ match build_dirs with
| Some dirs -> dirs
| None -> collect_transitive_dep_dirs ~os_dir node
in
- let base_prep_upper = match prep_upper with
+ let base_prep_upper =
+ match prep_upper with
| Some f -> f
| None -> opam_build_prep_upper ~sw env ~uid:benv.uid ~gid:benv.gid
in
@@ -187,8 +196,8 @@ let build ~sw env (benv : Types.build_env)
base_prep_upper ~upper ~lowers;
let etc = Fpath.(upper / "etc") in
mkdir etc;
- ignore (Bos.OS.File.write Fpath.(etc / "hosts")
- "127.0.0.1\tlocalhost builder\n")
+ ignore
+ (Bos.OS.File.write Fpath.(etc / "hosts") "127.0.0.1\tlocalhost builder\n")
in
let repo_mounts =
if opam_repositories = [] then []
@@ -200,42 +209,50 @@ let build ~sw env (benv : Types.build_env)
closure — opam resolves every installed package's definition
against the repo at switch-state load. *)
let pkgs = node.pkg :: collect_transitive_dep_pkgs node in
- let _ = Day11_opam_layer.Opam_repo.populate ~opam_repo:repo_dir
- ~opam_repositories pkgs in
- [ Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string repo_dir)
- "/home/opam/.opam/repo/default" ]
+ let _ =
+ Day11_opam_layer.Opam_repo.populate ~opam_repo:repo_dir
+ ~opam_repositories pkgs
+ in
+ [
+ Day11_container.Mount.bind_ro ~src:(Fpath.to_string repo_dir)
+ "/home/opam/.opam/repo/default";
+ ]
| Error _ -> []
in
- let patch_mounts = match patches with
+ let patch_mounts =
+ match patches with
| Some p when Patches.has_patches p node.pkg ->
- let patch_files = Patches.patches_for p node.pkg in
- List.mapi (fun i src ->
- Day11_container.Mount.bind_ro ~src
- (Printf.sprintf "/patches/%03d.patch" i)
- ) patch_files
+ let patch_files = Patches.patches_for p node.pkg in
+ List.mapi
+ (fun i src ->
+ Day11_container.Mount.bind_ro ~src
+ (Printf.sprintf "/patches/%03d.patch" i))
+ patch_files
| _ -> []
in
let all_mounts = repo_mounts @ patch_mounts @ mounts in
(* Acquire a CPU slot if the env has a pool; fibre-blocks until one
is free. Within the slot's lifetime, nproc inside the container
reports the slot size, so nested [make -j$(nproc)] self-limits. *)
- let run_in_slot f = match benv.Types.cpu_slots with
+ let run_in_slot f =
+ match benv.Types.cpu_slots with
| None -> f ~cpuset:None ~numa_mems:None
| Some pool ->
- Day11_runner.Cpu_slots.with_slot pool (fun slot ->
- f ~cpuset:(Some slot.cpuset) ~numa_mems:slot.numa_mems)
+ Day11_runner.Cpu_slots.with_slot pool (fun slot ->
+ f ~cpuset:(Some slot.cpuset) ~numa_mems:slot.numa_mems)
in
run_in_slot @@ fun ~cpuset ~numa_mems ->
- let spec = opam_build_spec ?cpuset ?numa_mems
- ~cmd:strategy.Types.cmd
- ~mounts:all_mounts ~uid:benv.uid ~gid:benv.gid ()
+ let spec =
+ opam_build_spec ?cpuset ?numa_mems ~cmd:strategy.Types.cmd
+ ~mounts:all_mounts ~uid:benv.uid ~gid:benv.gid ()
in
- match Day11_runner.Run_in_layers.run ~sw env ~base:benv.base
- ~build_dirs:dep_dirs ~prep_upper spec with
+ match
+ Day11_runner.Run_in_layers.run ~sw env ~base:benv.base ~build_dirs:dep_dirs
+ ~prep_upper spec
+ with
| Ok (run, upper, timing) ->
- strategy.cleanup ~sw env upper;
- (* Strip overlayfs [trusted.overlay.opaque] xattrs from the
+ strategy.cleanup ~sw env upper;
+ (* Strip overlayfs [trusted.overlay.opaque] xattrs from the
captured upper. The kernel places this xattr on directories
that the container modified in a way that replaces the lower
contents (e.g. apt remove + reinstall, or mkdir after rmdir).
@@ -251,30 +268,36 @@ let build ~sw env (benv : Types.build_env)
[setfattr -x] fails if the attribute isn't present, so filter
via [getfattr -R --match] first to get only the set. *)
- let _ = Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "bash" % "-c"
- % Printf.sprintf
- "getfattr -h -R -n trusted.overlay.opaque --absolute-names %s \
- 2>/dev/null | awk '/^# file:/ {print $3}' | \
- xargs -r -I{} setfattr -x trusted.overlay.opaque {}"
- (Filename.quote (Fpath.to_string upper))) in
- let _ = Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "mv" % Fpath.to_string upper
- % Fpath.to_string target_fs) in
- ignore (Day11_sys.Sudo.rm_rf ~sw env (Fpath.parent upper));
- (* Post-build invariant: a package classified as a real compiler
+ let _ =
+ Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "bash"
+ % "-c"
+ % Printf.sprintf
+ "getfattr -h -R -n trusted.overlay.opaque --absolute-names %s \
+ 2>/dev/null | awk '/^# file:/ {print $3}' | xargs -r -I{} \
+ setfattr -x trusted.overlay.opaque {}"
+ (Filename.quote (Fpath.to_string upper)))
+ in
+ let _ =
+ Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(v "mv" % Fpath.to_string upper % Fpath.to_string target_fs)
+ in
+ ignore (Day11_sys.Sudo.rm_rf ~sw env (Fpath.parent upper));
+ (* Post-build invariant: a package classified as a real compiler
by [Compiler_pkg.is_compiler] must have left
[lib/ocaml/stdlib.cmti] in its build layer. Logging at error
level (rather than failing the build) so the diagnostic is
visible without blocking unrelated work — a misclassified
package shouldn't take down the whole pipeline. *)
- let build_layer = Fpath.parent target_fs in
- (match Compiler_pkg.check_stdlib_installed
- ~build_layer node.pkg with
- | Ok () -> ()
- | Error (`Msg e) -> Log.err (fun m -> m "%s" e));
- Ok (run, timing)
+ let build_layer = Fpath.parent target_fs in
+ (match Compiler_pkg.check_stdlib_installed ~build_layer node.pkg with
+ | Ok () -> ()
+ | Error (`Msg e) -> Log.err (fun m -> m "%s" e));
+ Ok (run, timing)
| Error (`Msg e) as err ->
- Log.err (fun m -> m "Container build failed for %s: %s"
- (OpamPackage.to_string node.pkg) e);
- err
+ Log.err (fun m ->
+ m "Container build failed for %s: %s"
+ (OpamPackage.to_string node.pkg)
+ e);
+ err
File "day11/opam_build/container_backend.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/container_backend.mli b/_build/default/day11/opam_build/.formatted/container_backend.mli
index 3a898dc..af936a4 100644
--- a/_build/default/day11/opam_build/container_backend.mli
+++ b/_build/default/day11/opam_build/.formatted/container_backend.mli
@@ -1,66 +1,66 @@
(** Container-based build backend.
- Stacks dep layers as an overlayfs and runs the build inside a
- runc container. This is the original day11 behaviour, factored
- out from {!Build_layer.build} so that a native-host alternative
- ({!Native_backend}) can be plugged into the same
- {!Backend.S} slot.
+ Stacks dep layers as an overlayfs and runs the build inside a runc
+ container. This is the original day11 behaviour, factored out from
+ {!Build_layer.build} so that a native-host alternative ({!Native_backend})
+ can be plugged into the same {!Backend.S} slot.
- The helpers re-exported here ({!opam_build_cleanup},
- {!opam_build_spec}, {!opam_build_prep_upper}) are the
- container-specific building blocks that callers compose into
- custom strategies — e.g. the doc pipeline passes its own
- strategy with [opam_build_cleanup] as the cleanup function. *)
+ The helpers re-exported here ({!opam_build_cleanup}, {!opam_build_spec},
+ {!opam_build_prep_upper}) are the container-specific building blocks that
+ callers compose into custom strategies — e.g. the doc pipeline passes its
+ own strategy with [opam_build_cleanup] as the cleanup function. *)
val opam_build_cleanup :
sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> Fpath.t -> unit
-(** Remove [.opam-switch/build/], [sources/], [packages/cache],
- [/tmp], and [repo state-*.cache] from an upper dir. Suitable
- for any layer built with opam. *)
+(** Remove [.opam-switch/build/], [sources/], [packages/cache], [/tmp], and
+ [repo state-*.cache] from an upper dir. Suitable for any layer built with
+ opam. *)
val opam_build_spec :
?cpuset:string ->
?numa_mems:string ->
cmd:string ->
mounts:Day11_container.Mount.t list ->
- uid:int -> gid:int ->
+ uid:int ->
+ gid:int ->
unit ->
Day11_container.Oci_spec.t
-(** Build an OCI spec template for a container that runs [cmd] via
- [bash -c], with the cwd / env / hostname / network defaults
- that opam-build expects.
- @param cpuset Restrict the container to these host CPUs (cgroup
- cpuset.cpus). Normally supplied from
- {!Day11_runner.Cpu_slots.acquire}.
- @param numa_mems Restrict the container's memory to these NUMA
- nodes (cgroup cpuset.mems). Pairs with [?cpuset]. *)
+(** Build an OCI spec template for a container that runs [cmd] via [bash -c],
+ with the cwd / env / hostname / network defaults that opam-build expects.
+ @param cpuset
+ Restrict the container to these host CPUs (cgroup cpuset.cpus). Normally
+ supplied from {!Day11_runner.Cpu_slots.acquire}.
+ @param numa_mems
+ Restrict the container's memory to these NUMA nodes (cgroup cpuset.mems).
+ Pairs with [?cpuset]. *)
val opam_build_prep_upper :
- sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> uid:int -> gid:int ->
- upper:Fpath.t -> lowers:Fpath.t list -> unit
-(** Standard pre-mount prep for an opam-build container:
- dumps a synthetic opam [switch-state] file from the lowers'
- [.opam-switch/packages] directories into the upper, and chowns
- [upper/home] to [uid:gid]. *)
+ sw:Eio.Switch.t ->
+ Eio_unix.Stdenv.base ->
+ uid:int ->
+ gid:int ->
+ upper:Fpath.t ->
+ lowers:Fpath.t list ->
+ unit
+(** Standard pre-mount prep for an opam-build container: dumps a synthetic opam
+ [switch-state] file from the lowers' [.opam-switch/packages] directories
+ into the upper, and chowns [upper/home] to [uid:gid]. *)
val opam_build_strategy :
?patches:Patches.t -> OpamPackage.t -> Types.build_strategy
-(** Default build strategy for a package — runs
- [opam-build -v <pkg>] and cleans via {!opam_build_cleanup}. *)
+(** Default build strategy for a package — runs [opam-build -v <pkg>] and cleans
+ via {!opam_build_cleanup}. *)
-val collect_transitive_dep_hashes :
- Day11_opam_layer.Build.t -> string list
-(** Transitive dep layer hashes in overlayfs-stack order (direct deps
- frontmost / topmost). The hash-level core of
- {!collect_transitive_dep_dirs}; recorded verbatim in [build.json]
- ([Build_meta.t.stack]) so a tool can reconstruct the rootfs lower
- stack without re-deriving the DAG ordering. *)
+val collect_transitive_dep_hashes : Day11_opam_layer.Build.t -> string list
+(** Transitive dep layer hashes in overlayfs-stack order (direct deps frontmost
+ / topmost). The hash-level core of {!collect_transitive_dep_dirs}; recorded
+ verbatim in [build.json] ([Build_meta.t.stack]) so a tool can reconstruct
+ the rootfs lower stack without re-deriving the DAG ordering. *)
val collect_transitive_dep_dirs :
os_dir:Fpath.t -> Day11_opam_layer.Build.t -> Fpath.t list
-(** Collect transitive dep layer dirs from a build node, in
- overlay-stack order. Used as the default [?build_dirs] when none
- is supplied. *)
+(** Collect transitive dep layer dirs from a build node, in overlay-stack order.
+ Used as the default [?build_dirs] when none is supplied. *)
include Backend.S
(** {1 Backend interface} *)
File "day11/opam_build/dag.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/dag.ml b/_build/default/day11/opam_build/.formatted/dag.ml
index 233359a..fb7416a 100644
--- a/_build/default/day11/opam_build/dag.ml
+++ b/_build/default/day11/opam_build/.formatted/dag.ml
@@ -1,5 +1,6 @@
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
+
type build = Build.t
let build_dag cache ~base_hash solutions =
@@ -28,43 +29,49 @@ let build_dag cache ~base_hash solutions =
match Hashtbl.find_opt memo hash with
| Some node -> node
| None ->
- (* Universe identity reflects the {b doc-deps} closure. Two
+ (* Universe identity reflects the {b doc-deps} closure. Two
solutions sharing build-deps but differing in doc-deps will
hash-collide here (same [hash]); the first-arriving one's
universe is the one we keep — same convention as
[build_by_hash]'s last-write-wins. Falls back to build-deps
when [pkg] isn't in [trans_doc] (defensive — shouldn't
happen, since doc_solution ⊇ solution). *)
- let pkg_universe_deps =
- match OpamPackage.Map.find_opt pkg trans_doc with
- | Some s -> OpamPackage.Set.elements s
- | None -> pkg_build_deps
- in
- let universe =
- Day11_solution.Universe.of_deps
- (OpamPackage.Set.of_list pkg_universe_deps) in
- let direct_deps =
- match OpamPackage.Map.find_opt pkg solution with
- | Some s -> OpamPackage.Set.elements s
- | None -> []
- in
- let deps = List.filter_map (fun dep ->
- if OpamPackage.Map.mem dep solution then
- Some (get_node solution trans_build trans_doc dep)
- else
- None
- ) direct_deps in
- let node : build = { hash; pkg; deps; universe } in
- Hashtbl.replace memo hash node;
- node
+ let pkg_universe_deps =
+ match OpamPackage.Map.find_opt pkg trans_doc with
+ | Some s -> OpamPackage.Set.elements s
+ | None -> pkg_build_deps
+ in
+ let universe =
+ Day11_solution.Universe.of_deps
+ (OpamPackage.Set.of_list pkg_universe_deps)
+ in
+ let direct_deps =
+ match OpamPackage.Map.find_opt pkg solution with
+ | Some s -> OpamPackage.Set.elements s
+ | None -> []
+ in
+ let deps =
+ List.filter_map
+ (fun dep ->
+ if OpamPackage.Map.mem dep solution then
+ Some (get_node solution trans_build trans_doc dep)
+ else None)
+ direct_deps
+ in
+ let node : build = { hash; pkg; deps; universe } in
+ Hashtbl.replace memo hash node;
+ node
in
- List.iter (fun (_target, solution, doc_solution) ->
- let trans_build = Day11_solution.Deps.transitive_deps solution in
- let trans_doc = Day11_solution.Deps.transitive_deps doc_solution in
- OpamPackage.Map.iter (fun pkg _deps ->
- ignore (get_node solution trans_build trans_doc pkg)
- ) solution
- ) solutions;
+ List.iter
+ (fun (_target, solution, doc_solution) ->
+ let trans_build = Day11_solution.Deps.transitive_deps solution in
+ let trans_doc = Day11_solution.Deps.transitive_deps doc_solution in
+ OpamPackage.Map.iter
+ (fun pkg _deps -> ignore (get_node solution trans_build trans_doc pkg))
+ solution)
+ solutions;
let all_nodes = Hashtbl.fold (fun _ node acc -> node :: acc) memo [] in
- List.sort (fun (a : build) (b : build) ->
- compare (List.length a.deps) (List.length b.deps)) all_nodes
+ List.sort
+ (fun (a : build) (b : build) ->
+ compare (List.length a.deps) (List.length b.deps))
+ all_nodes
File "day11/opam_build/dag.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/dag.mli b/_build/default/day11/opam_build/.formatted/dag.mli
index d618612..61c756d 100644
--- a/_build/default/day11/opam_build/dag.mli
+++ b/_build/default/day11/opam_build/.formatted/dag.mli
@@ -1,22 +1,20 @@
(** Global DAG construction across solutions.
- Builds deduplicated DAGs of build, doc compile, and doc link
- nodes from multiple solved targets. *)
+ Builds deduplicated DAGs of build, doc compile, and doc link nodes from
+ multiple solved targets. *)
val build_dag :
Hash_cache.t ->
base_hash:string ->
(OpamPackage.t * Day11_solution.Deps.t * Day11_solution.Deps.t) list ->
Day11_opam_layer.Build.t list
-(** [build_dag cache ~base_hash solutions] builds a deduplicated DAG
- of build nodes across all solutions. Each solution is
- [(target, build_deps, doc_deps)]. The build LAYER hash is
- computed from each package's transitive build-deps closure, so
- the same package solved with the same build_deps in different
- targets shares one layer. The build NODE's [universe] field is
- computed from the transitive doc-deps closure, so two solutions
- that agree on build_deps but disagree on doc_deps produce
- distinct [Build.t] records (same hash, distinct universe) — the
- doc DAG keys compile/link/doc-all hashes off [universe], which
- keeps each doc-side identity from contaminating the others. *)
-
+(** [build_dag cache ~base_hash solutions] builds a deduplicated DAG of build
+ nodes across all solutions. Each solution is
+ [(target, build_deps, doc_deps)]. The build LAYER hash is computed from each
+ package's transitive build-deps closure, so the same package solved with the
+ same build_deps in different targets shares one layer. The build NODE's
+ [universe] field is computed from the transitive doc-deps closure, so two
+ solutions that agree on build_deps but disagree on doc_deps produce distinct
+ [Build.t] records (same hash, distinct universe) — the doc DAG keys
+ compile/link/doc-all hashes off [universe], which keeps each doc-side
+ identity from contaminating the others. *)
File "day11/opam_build/dag_executor.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/dag_executor.ml b/_build/default/day11/opam_build/.formatted/dag_executor.ml
index fce8816..236e7e2 100644
--- a/_build/default/day11/opam_build/dag_executor.ml
+++ b/_build/default/day11/opam_build/.formatted/dag_executor.ml
@@ -13,8 +13,8 @@
open Eio.Std
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
-type build = Build.t
+type build = Build.t
type outcome = Ok | Failed | Cascaded
type cache_status = Not_cached | Cached_ok | Cached_fail
@@ -27,8 +27,8 @@ type stats = {
cached : int;
}
-let execute env ~np ~on_complete ~on_cascade
- ?(priority = fun _ -> 0) ?(is_cached = fun _ -> Not_cached) nodes build_one =
+let execute env ~np ~on_complete ~on_cascade ?(priority = fun _ -> 0)
+ ?(is_cached = fun _ -> Not_cached) nodes build_one =
let a_completed = Atomic.make 0 in
let a_ok = Atomic.make 0 in
let a_failed = Atomic.make 0 in
@@ -41,92 +41,112 @@ let execute env ~np ~on_complete ~on_cascade
caller via [on_complete] so the run log, recorder, and stats see
cached outcomes in the same way they see fresh ones. *)
let cached_outcomes : (build * bool) list ref = ref [] in
- List.iter (fun (node : build) ->
- match is_cached node with
- | Not_cached -> ()
- | Cached_ok ->
- let p, r = Promise.create () in
- Hashtbl.replace promises node.hash p;
- Promise.resolve r Ok;
- cached_outcomes := (node, true) :: !cached_outcomes
- | Cached_fail ->
- let p, r = Promise.create () in
- Hashtbl.replace promises node.hash p;
- Promise.resolve r Failed;
- cached_outcomes := (node, false) :: !cached_outcomes
- ) nodes;
+ List.iter
+ (fun (node : build) ->
+ match is_cached node with
+ | Not_cached -> ()
+ | Cached_ok ->
+ let p, r = Promise.create () in
+ Hashtbl.replace promises node.hash p;
+ Promise.resolve r Ok;
+ cached_outcomes := (node, true) :: !cached_outcomes
+ | Cached_fail ->
+ let p, r = Promise.create () in
+ Hashtbl.replace promises node.hash p;
+ Promise.resolve r Failed;
+ cached_outcomes := (node, false) :: !cached_outcomes)
+ nodes;
let cached = List.length !cached_outcomes in
- let uncached = List.filter (fun (node : build) ->
- not (Hashtbl.mem promises node.hash)
- ) nodes in
+ let uncached =
+ List.filter
+ (fun (node : build) -> not (Hashtbl.mem promises node.hash))
+ nodes
+ in
let total = List.length uncached in
- Printf.printf " Executor: %d cached (pre-resolved), %d to run\n%!"
- cached total;
+ Printf.printf " Executor: %d cached (pre-resolved), %d to run\n%!" cached
+ total;
let make_stats () =
- { total; completed = Atomic.get a_completed;
- ok = Atomic.get a_ok; failed = Atomic.get a_failed;
- cascaded = Atomic.get a_cascaded; cached }
+ {
+ total;
+ completed = Atomic.get a_completed;
+ ok = Atomic.get a_ok;
+ failed = Atomic.get a_failed;
+ cascaded = Atomic.get a_cascaded;
+ cached;
+ }
in
(* Notify the caller about cached outcomes before running uncached
nodes, so callers see a deterministic order: cached first (in the
order they were declared), then fresh builds as they complete.
Cached outcomes don't count toward [completed]/[ok]/[failed] — those
track fresh executor work — but they are reported via [on_complete]. *)
- List.iter (fun (node, success) ->
- on_complete ~stats:(make_stats ()) ~cached:true node success
- ) (List.rev !cached_outcomes);
- let sorted_nodes = List.sort (fun a b ->
- compare (priority b) (priority a)) uncached in
+ List.iter
+ (fun (node, success) ->
+ on_complete ~stats:(make_stats ()) ~cached:true node success)
+ (List.rev !cached_outcomes);
+ let sorted_nodes =
+ List.sort (fun a b -> compare (priority b) (priority a)) uncached
+ in
let rec run_node (node : build) : outcome =
match Hashtbl.find_opt promises node.hash with
| Some p -> Promise.await p
| None ->
- let p, r = Promise.create () in
- Hashtbl.add promises node.hash p;
- let resolved, unresolved = List.partition (fun (dep : build) ->
- match Hashtbl.find_opt promises dep.hash with
- | Some dp -> Promise.is_resolved dp
- | None -> false
- ) node.deps in
- let resolved_outcomes = List.map (fun (dep : build) ->
- Promise.await (Hashtbl.find promises dep.hash)
- ) resolved in
- let unresolved_outcomes =
- Fiber.List.map (fun dep -> run_node dep) unresolved
- in
- let dep_outcomes = resolved_outcomes @ unresolved_outcomes in
- let any_dep_failed =
- List.exists (fun o -> match o with Ok -> false | _ -> true) dep_outcomes
- in
- let outcome =
- if any_dep_failed then begin
- let failed_dep =
- List.find (fun (dep : build) ->
+ let p, r = Promise.create () in
+ Hashtbl.add promises node.hash p;
+ let resolved, unresolved =
+ List.partition
+ (fun (dep : build) ->
match Hashtbl.find_opt promises dep.hash with
- | Some p -> (match Promise.await p with Ok -> false | _ -> true)
- | None -> false
- ) node.deps
- in
- ignore (Atomic.fetch_and_add a_completed 1);
- ignore (Atomic.fetch_and_add a_cascaded 1);
- on_cascade ~failed:node ~failed_dep;
- on_complete ~stats:(make_stats ()) ~cached:false node false;
- Cascaded
- end else begin
- Eio.Semaphore.acquire sem;
- let success =
- Fun.protect ~finally:(fun () -> Eio.Semaphore.release sem)
- (fun () -> build_one node)
- in
- ignore (Atomic.fetch_and_add a_completed 1);
- if success then ignore (Atomic.fetch_and_add a_ok 1)
- else ignore (Atomic.fetch_and_add a_failed 1);
- on_complete ~stats:(make_stats ()) ~cached:false node success;
- if success then Ok else Failed
- end
- in
- Promise.resolve r outcome;
- outcome
+ | Some dp -> Promise.is_resolved dp
+ | None -> false)
+ node.deps
+ in
+ let resolved_outcomes =
+ List.map
+ (fun (dep : build) ->
+ Promise.await (Hashtbl.find promises dep.hash))
+ resolved
+ in
+ let unresolved_outcomes =
+ Fiber.List.map (fun dep -> run_node dep) unresolved
+ in
+ let dep_outcomes = resolved_outcomes @ unresolved_outcomes in
+ let any_dep_failed =
+ List.exists
+ (fun o -> match o with Ok -> false | _ -> true)
+ dep_outcomes
+ in
+ let outcome =
+ if any_dep_failed then (
+ let failed_dep =
+ List.find
+ (fun (dep : build) ->
+ match Hashtbl.find_opt promises dep.hash with
+ | Some p -> (
+ match Promise.await p with Ok -> false | _ -> true)
+ | None -> false)
+ node.deps
+ in
+ ignore (Atomic.fetch_and_add a_completed 1);
+ ignore (Atomic.fetch_and_add a_cascaded 1);
+ on_cascade ~failed:node ~failed_dep;
+ on_complete ~stats:(make_stats ()) ~cached:false node false;
+ Cascaded)
+ else (
+ Eio.Semaphore.acquire sem;
+ let success =
+ Fun.protect
+ ~finally:(fun () -> Eio.Semaphore.release sem)
+ (fun () -> build_one node)
+ in
+ ignore (Atomic.fetch_and_add a_completed 1);
+ if success then ignore (Atomic.fetch_and_add a_ok 1)
+ else ignore (Atomic.fetch_and_add a_failed 1);
+ on_complete ~stats:(make_stats ()) ~cached:false node success;
+ if success then Ok else Failed)
+ in
+ Promise.resolve r outcome;
+ outcome
in
ignore (env : Eio_unix.Stdenv.base);
ignore (Fiber.List.map (fun node -> run_node node) sorted_nodes)
File "day11/opam_build/dag_executor.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/dag_executor.mli b/_build/default/day11/opam_build/.formatted/dag_executor.mli
index 0aa74cc..f2dbbd3 100644
--- a/_build/default/day11/opam_build/dag_executor.mli
+++ b/_build/default/day11/opam_build/.formatted/dag_executor.mli
@@ -1,13 +1,12 @@
(** Eio-based parallel DAG execution.
- Executes build nodes in dependency order using Eio fibers and
- promise-based memoization. Each node becomes a fiber that awaits
- its dependency promises before building.
+ Executes build nodes in dependency order using Eio fibers and promise-based
+ memoization. Each node becomes a fiber that awaits its dependency promises
+ before building.
- Cached nodes (identified by [is_cached]) have their promises
- pre-resolved so they never enter the executor loop, but
- [on_complete] is still invoked for them with [~cached:true] so
- callers see a single outcome stream. *)
+ Cached nodes (identified by [is_cached]) have their promises pre-resolved so
+ they never enter the executor loop, but [on_complete] is still invoked for
+ them with [~cached:true] so callers see a single outcome stream. *)
type cache_status = Not_cached | Cached_ok | Cached_fail
@@ -23,19 +22,21 @@ type stats = {
val execute :
Eio_unix.Stdenv.base ->
np:int ->
- on_complete:(stats:stats -> cached:bool ->
- Day11_opam_layer.Build.t -> bool -> unit) ->
- on_cascade:(failed:Day11_opam_layer.Build.t ->
- failed_dep:Day11_opam_layer.Build.t -> unit) ->
+ on_complete:
+ (stats:stats -> cached:bool -> Day11_opam_layer.Build.t -> bool -> unit) ->
+ on_cascade:
+ (failed:Day11_opam_layer.Build.t ->
+ failed_dep:Day11_opam_layer.Build.t ->
+ unit) ->
?priority:(Day11_opam_layer.Build.t -> int) ->
?is_cached:(Day11_opam_layer.Build.t -> cache_status) ->
Day11_opam_layer.Build.t list ->
(Day11_opam_layer.Build.t -> bool) ->
unit
-(** [execute env ~np ~on_complete ~on_cascade ?priority ?is_cached nodes build_one]
- executes [nodes] in dependency order with up to [np] concurrent
- workers. Nodes where [is_cached] returns [Cached_ok] or [Cached_fail]
- are pre-resolved and [build_one] is not called for them, but
- [on_complete] is invoked with [~cached:true] so callers can log or
- record the outcome. [Cached_fail] nodes propagate failure to
- dependents (triggering cascades). *)
+(** [execute env ~np ~on_complete ~on_cascade ?priority ?is_cached nodes
+ build_one] executes [nodes] in dependency order with up to [np] concurrent
+ workers. Nodes where [is_cached] returns [Cached_ok] or [Cached_fail] are
+ pre-resolved and [build_one] is not called for them, but [on_complete] is
+ invoked with [~cached:true] so callers can log or record the outcome.
+ [Cached_fail] nodes propagate failure to dependents (triggering cascades).
+*)
File "day11/opam_build/debug.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/debug.ml b/_build/default/day11/opam_build/.formatted/debug.ml
index 2053376..4f5d6a4 100644
--- a/_build/default/day11/opam_build/debug.ml
+++ b/_build/default/day11/opam_build/.formatted/debug.ml
@@ -1,5 +1,6 @@
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
+
type build = Build.t
type session = {
@@ -11,11 +12,14 @@ type session = {
gid : int;
}
-let debug_env = [
- ("PATH", "/home/opam/.opam/default/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin");
- ("HOME", "/home/opam");
- ("OPAM_SWITCH_PREFIX", "/home/opam/.opam/default");
-]
+let debug_env =
+ [
+ ( "PATH",
+ "/home/opam/.opam/default/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"
+ );
+ ("HOME", "/home/opam");
+ ("OPAM_SWITCH_PREFIX", "/home/opam/.opam/default");
+ ]
let setup ~sw env ~os_dir ?(keep = false) node =
let cache_dir = Fpath.parent os_dir in
@@ -24,31 +28,34 @@ let setup ~sw env ~os_dir ?(keep = false) node =
match Day11_layer.Meta.load env layer_json with
| Error _ as e -> e
| Ok meta ->
- (* Reconstruct base *)
- let base_dir = Fpath.(cache_dir / "base") in
- let base : Day11_layer.Base.t = {
- hash = meta.base_hash; dir = base_dir; image = "";
- } in
- let uid = meta.uid and gid = meta.gid in
- (* Create temp dir *)
- let temp_dir =
- if keep then
- Fpath.(cache_dir / Printf.sprintf "debug-%s"
- (String.sub node.hash 0 (min 12 (String.length node.hash))))
- else
- Bos.OS.Dir.tmp "day11_debug_%s" |> Result.get_ok
- in
- let resuming = Bos.OS.Dir.exists Fpath.(temp_dir / "rootfs" / "home")
- |> Result.get_ok in
- Bos.OS.Dir.create ~path:true temp_dir |> ignore;
- if not resuming then begin
- let upper = Fpath.(temp_dir / "fs") in
- let work = Fpath.(temp_dir / "work") in
- let rootfs = Fpath.(temp_dir / "rootfs") in
- let merged_lower = Fpath.(temp_dir / "lower") in
- List.iter (fun d -> Bos.OS.Dir.create ~path:true d |> ignore)
- [ upper; work; rootfs ];
- (* Mirror {!Day11_runner.Run_in_layers.run}'s mount strategy so
+ (* Reconstruct base *)
+ let base_dir = Fpath.(cache_dir / "base") in
+ let base : Day11_layer.Base.t =
+ { hash = meta.base_hash; dir = base_dir; image = "" }
+ in
+ let uid = meta.uid and gid = meta.gid in
+ (* Create temp dir *)
+ let temp_dir =
+ if keep then
+ Fpath.(
+ cache_dir
+ / Printf.sprintf "debug-%s"
+ (String.sub node.hash 0 (min 12 (String.length node.hash))))
+ else Bos.OS.Dir.tmp "day11_debug_%s" |> Result.get_ok
+ in
+ let resuming =
+ Bos.OS.Dir.exists Fpath.(temp_dir / "rootfs" / "home") |> Result.get_ok
+ in
+ Bos.OS.Dir.create ~path:true temp_dir |> ignore;
+ if not resuming then (
+ let upper = Fpath.(temp_dir / "fs") in
+ let work = Fpath.(temp_dir / "work") in
+ let rootfs = Fpath.(temp_dir / "rootfs") in
+ let merged_lower = Fpath.(temp_dir / "lower") in
+ List.iter
+ (fun d -> Bos.OS.Dir.create ~path:true d |> ignore)
+ [ upper; work; rootfs ];
+ (* Mirror {!Day11_runner.Run_in_layers.run}'s mount strategy so
the debug container sees the exact same lowerdir sequence a
production build would: [separate_dirs] each as their own
lowerdir, a [merged_lower] for anything that would overflow
@@ -56,103 +63,120 @@ let setup ~sw env ~os_dir ?(keep = false) node =
are collected via {!Container_backend.collect_transitive_dep_dirs}
(DFS post-order, reversed — direct deps topmost), matching
what [Build_layer.build] would pass. *)
- let build_dirs = Container_backend.collect_transitive_dep_dirs
- ~os_dir node in
- let base_dir = base.Day11_layer.Base.dir in
- let base_fs = Fpath.(base_dir / "fs") in
- let dep_entry_cost d =
- String.length (Fpath.to_string Fpath.(d / "fs")) + 1 in
- let fixed_overhead =
- String.length "lowerdir="
- + String.length (Fpath.to_string base_fs)
- + String.length ",upperdir=" + String.length (Fpath.to_string upper)
- + String.length ",workdir=" + String.length (Fpath.to_string work)
- in
- let merged_overhead =
- String.length (Fpath.to_string merged_lower) + 1 in
- let available = 4000 - fixed_overhead in
- let separate_dirs, to_merge_dirs =
- Day11_layer.Stack.plan_lowerdir
- ~available ~merged_overhead ~entry_cost:dep_entry_cost build_dirs
- in
- let did_merge = to_merge_dirs <> [] in
- if did_merge then begin
- Bos.OS.Dir.create ~path:true merged_lower |> ignore;
- match Day11_layer.Stack.merge ~sw env
- ~layer_dirs:to_merge_dirs ~target:merged_lower with
- | Ok () -> ()
- | Error (`Msg e) ->
- ignore (Day11_sys.Sudo.rm_rf ~sw env temp_dir);
- failwith e
- end;
- let layer_fs_dirs =
- List.map (fun d -> Fpath.(d / "fs")) separate_dirs
- @ (if did_merge then [ merged_lower ] else [])
- in
- let overlay_lowers = layer_fs_dirs @ [ base_fs ] in
- (* Dump switch-state into upper so opam sees deps as installed.
+ let build_dirs =
+ Container_backend.collect_transitive_dep_dirs ~os_dir node
+ in
+ let base_dir = base.Day11_layer.Base.dir in
+ let base_fs = Fpath.(base_dir / "fs") in
+ let dep_entry_cost d =
+ String.length (Fpath.to_string Fpath.(d / "fs")) + 1
+ in
+ let fixed_overhead =
+ String.length "lowerdir="
+ + String.length (Fpath.to_string base_fs)
+ + String.length ",upperdir="
+ + String.length (Fpath.to_string upper)
+ + String.length ",workdir="
+ + String.length (Fpath.to_string work)
+ in
+ let merged_overhead =
+ String.length (Fpath.to_string merged_lower) + 1
+ in
+ let available = 4000 - fixed_overhead in
+ let separate_dirs, to_merge_dirs =
+ Day11_layer.Stack.plan_lowerdir ~available ~merged_overhead
+ ~entry_cost:dep_entry_cost build_dirs
+ in
+ let did_merge = to_merge_dirs <> [] in
+ if did_merge then (
+ Bos.OS.Dir.create ~path:true merged_lower |> ignore;
+ match
+ Day11_layer.Stack.merge ~sw env ~layer_dirs:to_merge_dirs
+ ~target:merged_lower
+ with
+ | Ok () -> ()
+ | Error (`Msg e) ->
+ ignore (Day11_sys.Sudo.rm_rf ~sw env temp_dir);
+ failwith e);
+ let layer_fs_dirs =
+ List.map (fun d -> Fpath.(d / "fs")) separate_dirs
+ @ if did_merge then [ merged_lower ] else []
+ in
+ let overlay_lowers = layer_fs_dirs @ [ base_fs ] in
+ (* Dump switch-state into upper so opam sees deps as installed.
Reading from the FIRST lower that has a packages dir matches
what [Container_backend.opam_build_prep_upper] does. *)
- let switch = Types.switch in
- let switch_rel = Fpath.(v "home" / "opam" / ".opam" / switch
- / ".opam-switch") in
- let packages_dirs = List.filter_map (fun dir ->
- let p = Fpath.(dir // Fpath.(v "packages")) in
- (* [dir] is already a [.../fs] path, so [packages_rel] is relative
+ let switch = Types.switch in
+ let switch_rel =
+ Fpath.(v "home" / "opam" / ".opam" / switch / ".opam-switch")
+ in
+ let packages_dirs =
+ List.filter_map
+ (fun dir ->
+ let p = Fpath.(dir // Fpath.(v "packages")) in
+ (* [dir] is already a [.../fs] path, so [packages_rel] is relative
to [home/opam/...]. Pull the full rel from [switch_rel/packages]. *)
- ignore p;
- let packages_rel = Fpath.(switch_rel / "packages") in
- let abs = Fpath.(dir // packages_rel) in
- if Bos.OS.Dir.exists abs |> Result.value ~default:false then Some abs
- else None
- ) overlay_lowers in
- if packages_dirs <> [] then begin
- let state_dir = Fpath.(upper // switch_rel) in
- Bos.OS.Dir.create ~path:true state_dir |> ignore;
- Day11_opam_layer.Opamh.dump_state packages_dirs
- Fpath.(state_dir / "switch-state") |> ignore
- end;
- (* Mount overlay with the same lower sequence as production. *)
- (match Day11_container.Overlay.mount ~sw env
- ~lower:overlay_lowers ~upper ~work ~target:rootfs with
- | Ok () -> ()
- | Error (`Msg e) ->
- ignore (Day11_sys.Sudo.rm_rf ~sw env temp_dir);
- failwith e);
- (* Extract source *)
- let source_cmd = Printf.sprintf
- "opam source %s --dir=/home/opam/src"
- (OpamPackage.to_string node.pkg) in
- let spec = Day11_container.Oci_spec.make
- ~cwd:"/home/opam"
- ~hostname:"debug" ~env:debug_env ~network:true
- ~argv:[ "/usr/bin/env"; "bash"; "-c"; source_cmd ]
- ~uid ~gid () in
- ignore (Day11_container.Oci_spec.write
- ~root:(Fpath.to_string rootfs) temp_dir spec);
- let container_id = Printf.sprintf "debug-src-%d" (Unix.getpid ()) in
- ignore (Day11_container.Runc.delete ~sw env container_id);
- ignore (Day11_container.Runc.run ~sw env ~bundle:temp_dir ~container_id);
- ignore (Day11_container.Runc.delete ~sw env container_id)
- end;
- Ok { temp_dir; os_dir; build = node; pkg = node.pkg; uid; gid }
+ ignore p;
+ let packages_rel = Fpath.(switch_rel / "packages") in
+ let abs = Fpath.(dir // packages_rel) in
+ if Bos.OS.Dir.exists abs |> Result.value ~default:false then
+ Some abs
+ else None)
+ overlay_lowers
+ in
+ if packages_dirs <> [] then (
+ let state_dir = Fpath.(upper // switch_rel) in
+ Bos.OS.Dir.create ~path:true state_dir |> ignore;
+ Day11_opam_layer.Opamh.dump_state packages_dirs
+ Fpath.(state_dir / "switch-state")
+ |> ignore);
+ (* Mount overlay with the same lower sequence as production. *)
+ (match
+ Day11_container.Overlay.mount ~sw env ~lower:overlay_lowers ~upper
+ ~work ~target:rootfs
+ with
+ | Ok () -> ()
+ | Error (`Msg e) ->
+ ignore (Day11_sys.Sudo.rm_rf ~sw env temp_dir);
+ failwith e);
+ (* Extract source *)
+ let source_cmd =
+ Printf.sprintf "opam source %s --dir=/home/opam/src"
+ (OpamPackage.to_string node.pkg)
+ in
+ let spec =
+ Day11_container.Oci_spec.make ~cwd:"/home/opam" ~hostname:"debug"
+ ~env:debug_env ~network:true
+ ~argv:[ "/usr/bin/env"; "bash"; "-c"; source_cmd ]
+ ~uid ~gid ()
+ in
+ ignore
+ (Day11_container.Oci_spec.write ~root:(Fpath.to_string rootfs)
+ temp_dir spec);
+ let container_id = Printf.sprintf "debug-src-%d" (Unix.getpid ()) in
+ ignore (Day11_container.Runc.delete ~sw env container_id);
+ ignore (Day11_container.Runc.run ~sw env ~bundle:temp_dir ~container_id);
+ ignore (Day11_container.Runc.delete ~sw env container_id));
+ Ok { temp_dir; os_dir; build = node; pkg = node.pkg; uid; gid }
let run_in_session ~sw env session ~terminal ~argv =
let rootfs = Fpath.(session.temp_dir / "rootfs") in
let uid = session.uid and gid = session.gid in
- let spec = Day11_container.Oci_spec.make
- ~terminal
- ~cwd:"/home/opam/src"
- ~hostname:"debug" ~env:debug_env ~network:true
- ~argv ~uid ~gid () in
- ignore (Day11_container.Oci_spec.write
- ~root:(Fpath.to_string rootfs) session.temp_dir spec);
+ let spec =
+ Day11_container.Oci_spec.make ~terminal ~cwd:"/home/opam/src"
+ ~hostname:"debug" ~env:debug_env ~network:true ~argv ~uid ~gid ()
+ in
+ ignore
+ (Day11_container.Oci_spec.write ~root:(Fpath.to_string rootfs)
+ session.temp_dir spec);
let container_id = Printf.sprintf "debug-%d" (Unix.getpid ()) in
ignore (Day11_container.Runc.delete ~sw env container_id);
- let result = match
- Day11_container.Runc.run ~sw env ~bundle:session.temp_dir ~container_id
- with
- | Ok run -> (match run.status with `Exited n -> n | `Signaled n -> 128 + n)
+ let result =
+ match
+ Day11_container.Runc.run ~sw env ~bundle:session.temp_dir ~container_id
+ with
+ | Ok run -> (
+ match run.status with `Exited n -> n | `Signaled n -> 128 + n)
| Error _ -> 1
in
ignore (Day11_container.Runc.delete ~sw env container_id);
@@ -160,16 +184,13 @@ let run_in_session ~sw env session ~terminal ~argv =
let run_interactive ~sw env session =
let pkg_str = OpamPackage.to_string session.pkg in
- let cmd = Printf.sprintf
- "echo '==> Source: /home/opam/src'; \
- echo '==> Building %s'; \
- opam-build -v %s; \
- if [ $? -ne 0 ]; then \
- echo; echo '==> Build failed. Dropping to interactive shell.'; \
- echo '==> Run: opam-build -v %s to retry'; echo; \
- exec bash -i; \
- fi"
- pkg_str pkg_str pkg_str
+ let cmd =
+ Printf.sprintf
+ "echo '==> Source: /home/opam/src'; echo '==> Building %s'; opam-build \
+ -v %s; if [ $? -ne 0 ]; then echo; echo '==> Build failed. Dropping to \
+ interactive shell.'; echo '==> Run: opam-build -v %s to retry'; echo; \
+ exec bash -i; fi"
+ pkg_str pkg_str pkg_str
in
run_in_session ~sw env session ~terminal:true
~argv:[ "/usr/bin/env"; "bash"; "-c"; cmd ]
File "day11/opam_build/debug.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/debug.mli b/_build/default/day11/opam_build/.formatted/debug.mli
index 64d63ee..9bb3398 100644
--- a/_build/default/day11/opam_build/debug.mli
+++ b/_build/default/day11/opam_build/.formatted/debug.mli
@@ -1,8 +1,7 @@
(** Interactive debug containers for failed builds.
- Drops into an interactive shell inside a container with the
- failed package's dependencies stacked, source extracted, and
- opam tools available. *)
+ Drops into an interactive shell inside a container with the failed package's
+ dependencies stacked, source extracted, and opam tools available. *)
type session = {
temp_dir : Fpath.t;
@@ -20,33 +19,19 @@ val setup :
?keep:bool ->
Day11_opam_layer.Build.t ->
(session, [> Rresult.R.msg ]) result
-(** [setup ~sw env ~os_dir ?keep node] prepares a debug container for
- [node]. Reads uid/gid/base from the layer's metadata. Derives
- [cache_dir] from [os_dir]. If [keep] is true, uses a stable
- directory name for re-entry. *)
+(** [setup ~sw env ~os_dir ?keep node] prepares a debug container for [node].
+ Reads uid/gid/base from the layer's metadata. Derives [cache_dir] from
+ [os_dir]. If [keep] is true, uses a stable directory name for re-entry. *)
-val run_interactive :
- sw:Eio.Switch.t ->
- Eio_unix.Stdenv.base ->
- session ->
- int
-(** [run_interactive ~sw env session] launches an interactive shell
- that attempts to build, then drops to bash on failure. Returns
- the exit code. *)
+val run_interactive : sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> session -> int
+(** [run_interactive ~sw env session] launches an interactive shell that
+ attempts to build, then drops to bash on failure. Returns the exit code. *)
val run_command :
- sw:Eio.Switch.t ->
- Eio_unix.Stdenv.base ->
- session ->
- string ->
- int
-(** [run_command ~sw env session cmd] runs [cmd] non-interactively
- in the debug container. Returns the exit code. *)
+ sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> session -> string -> int
+(** [run_command ~sw env session cmd] runs [cmd] non-interactively in the debug
+ container. Returns the exit code. *)
-val teardown :
- sw:Eio.Switch.t ->
- Eio_unix.Stdenv.base ->
- session ->
- unit
-(** [teardown ~sw env session] unmounts the overlay and cleans up.
- Call after the debug session unless [keep] was used. *)
+val teardown : sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> session -> unit
+(** [teardown ~sw env session] unmounts the overlay and cleans up. Call after
+ the debug session unless [keep] was used. *)
File "day11/opam_build/hash_cache.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/hash_cache.ml b/_build/default/day11/opam_build/.formatted/hash_cache.ml
index 48aa5a7..8caed0c 100644
--- a/_build/default/day11/opam_build/hash_cache.ml
+++ b/_build/default/day11/opam_build/.formatted/hash_cache.ml
@@ -6,9 +6,12 @@ type t = {
}
let create ~find_opam ?patches () =
- { find_opam; patches;
+ {
+ find_opam;
+ patches;
per_pkg = Hashtbl.create 256;
- per_layer = Hashtbl.create 256; }
+ per_layer = Hashtbl.create 256;
+ }
let pkg_opam_hash t pkg =
let key = OpamPackage.to_string pkg in
@@ -21,14 +24,16 @@ let pkg_opam_hash t pkg =
opam
|> OpamFile.OPAM.effective_part
|> OpamFile.OPAM.write_to_string
- |> Digest.string |> Digest.to_hex
+ |> Digest.string
+ |> Digest.to_hex
| None -> "missing-" ^ key
in
- let h = match t.patches with
+ let h =
+ match t.patches with
| Some patches ->
- let ph = Patches.hash_for patches pkg in
- if ph = "" then opam_h
- else Digest.string (opam_h ^ ph) |> Digest.to_hex
+ let ph = Patches.hash_for patches pkg in
+ if ph = "" then opam_h
+ else Digest.string (opam_h ^ ph) |> Digest.to_hex
| None -> opam_h
in
Hashtbl.replace t.per_pkg key h;
@@ -40,15 +45,14 @@ let layer_hash t ~base_hash pkgs =
universes of 50-100 packages and 4000+ solutions, an un-digested
key made per-entry Hashtbl ops O(universe_size) and dominated
[build_dag] wall-clock. *)
- let str = String.concat ","
- (base_hash :: List.map OpamPackage.to_string pkgs) in
+ let str =
+ String.concat "," (base_hash :: List.map OpamPackage.to_string pkgs)
+ in
let key = Digest.to_hex (Digest.string str) in
match Hashtbl.find_opt t.per_layer key with
| Some h -> h
| None ->
- let hashes =
- List.map (fun pkg -> pkg_opam_hash t pkg) pkgs
- in
+ let hashes = List.map (fun pkg -> pkg_opam_hash t pkg) pkgs in
let h = Day11_layer.Hash.of_strings (base_hash :: hashes) in
Hashtbl.replace t.per_layer key h;
h
File "day11/opam_build/hash_cache.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/hash_cache.mli b/_build/default/day11/opam_build/.formatted/hash_cache.mli
index db2c50d..cfbaf23 100644
--- a/_build/default/day11/opam_build/hash_cache.mli
+++ b/_build/default/day11/opam_build/.formatted/hash_cache.mli
@@ -1,21 +1,23 @@
(** Memoized hash computation for layer cache keys.
- Caches opam file hashes and layer hashes to avoid redundant
- computation when building many packages with shared dependencies. *)
+ Caches opam file hashes and layer hashes to avoid redundant computation when
+ building many packages with shared dependencies. *)
type t
(** A hash cache instance. *)
val create :
find_opam:(OpamPackage.t -> OpamFile.OPAM.t option) ->
- ?patches:Patches.t -> unit -> t
-(** [create ~find_opam ?patches ()] creates a new hash cache.
- When [patches] is provided, patch content is incorporated into
- package hashes so patched builds get distinct cache keys. *)
+ ?patches:Patches.t ->
+ unit ->
+ t
+(** [create ~find_opam ?patches ()] creates a new hash cache. When [patches] is
+ provided, patch content is incorporated into package hashes so patched
+ builds get distinct cache keys. *)
val pkg_opam_hash : t -> OpamPackage.t -> string
val layer_hash : t -> base_hash:string -> OpamPackage.t list -> string
-(** [layer_hash t ~base_hash pkgs] returns a hash for a build layer.
- Depends on the base image hash and each package's effective opam
- content. Memoized per package list. *)
+(** [layer_hash t ~base_hash pkgs] returns a hash for a build layer. Depends on
+ the base image hash and each package's effective opam content. Memoized per
+ package list. *)
File "day11/opam_build/native_backend.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/native_backend.ml b/_build/default/day11/opam_build/.formatted/native_backend.ml
index c6a29f5..f49e655 100644
--- a/_build/default/day11/opam_build/native_backend.ml
+++ b/_build/default/day11/opam_build/.formatted/native_backend.ml
@@ -1,12 +1,12 @@
-let src = Logs.Src.create "day11.build.native_backend"
- ~doc:"Host-native opam package build backend"
-module Log = (val Logs.src_log src)
+let src =
+ Logs.Src.create "day11.build.native_backend"
+ ~doc:"Host-native opam package build backend"
+module Log = (val Logs.src_log src)
module Build = Day11_opam_layer.Build
module Snapshot = Day11_layer.Snapshot
-let mkdir path =
- Bos.OS.Dir.create ~path:true path |> ignore
+let mkdir path = Bos.OS.Dir.create ~path:true path |> ignore
(* -- Subprocess with custom env ------------------------------------------ *)
@@ -19,42 +19,41 @@ let run_with_env env ~cmd ~environ : Day11_sys.Run.t =
match cmd with
| [] -> [ "/bin/true" ]
| exe :: _ when String.contains exe '/' -> cmd
- | exe :: rest ->
- (* Resolve exe against PATH in environ to avoid Eio's execvp
+ | exe :: rest -> (
+ (* Resolve exe against PATH in environ to avoid Eio's execvp
using the parent's PATH. *)
- let path =
- List.assoc_opt "PATH" environ
- |> Option.value ~default:"/usr/local/bin:/usr/bin:/bin"
- in
- let found =
- String.split_on_char ':' path
- |> List.find_map (fun d ->
- if d = "" then None
- else
- let cand = Filename.concat d exe in
- try Unix.access cand [ Unix.X_OK ]; Some cand
- with Unix.Unix_error _ -> None)
- in
- (match found with
- | Some p -> p :: rest
- | None -> cmd)
- in
- let env_arr =
- Array.of_list (List.map (fun (k, v) -> k ^ "=" ^ v) environ)
+ let path =
+ List.assoc_opt "PATH" environ
+ |> Option.value ~default:"/usr/local/bin:/usr/bin:/bin"
+ in
+ let found =
+ String.split_on_char ':' path
+ |> List.find_map (fun d ->
+ if d = "" then None
+ else
+ let cand = Filename.concat d exe in
+ try
+ Unix.access cand [ Unix.X_OK ];
+ Some cand
+ with Unix.Unix_error _ -> None)
+ in
+ match found with Some p -> p :: rest | None -> cmd)
in
+ let env_arr = Array.of_list (List.map (fun (k, v) -> k ^ "=" ^ v) environ) in
let run () =
Eio.Switch.run (fun sw ->
- let r, w = Eio.Process.pipe ~sw proc_mgr in
- let child = Eio.Process.spawn ~sw proc_mgr ~env:env_arr
- ~stdout:w ~stderr:w argv in
- Eio.Flow.close w;
- let output =
- try Eio.Buf_read.(parse_exn take_all) r ~max_size:max_int
- with End_of_file -> ""
- in
- Eio.Flow.close r;
- let status = Eio.Process.await child in
- (output, status))
+ let r, w = Eio.Process.pipe ~sw proc_mgr in
+ let child =
+ Eio.Process.spawn ~sw proc_mgr ~env:env_arr ~stdout:w ~stderr:w argv
+ in
+ Eio.Flow.close w;
+ let output =
+ try Eio.Buf_read.(parse_exn take_all) r ~max_size:max_int
+ with End_of_file -> ""
+ in
+ Eio.Flow.close r;
+ let status = Eio.Process.await child in
+ (output, status))
in
let output, status_eio =
try run ()
@@ -62,85 +61,88 @@ let run_with_env env ~cmd ~environ : Day11_sys.Run.t =
(Format.asprintf "native run failed: %a" Eio.Exn.pp_err e, `Exited 127)
in
let t_end = Unix.gettimeofday () in
- let status = match status_eio with
- | `Exited n -> `Exited n
- | `Signaled n -> `Signaled n
+ let status =
+ match status_eio with `Exited n -> `Exited n | `Signaled n -> `Signaled n
in
- { Day11_sys.Run.cmd = argv;
+ {
+ Day11_sys.Run.cmd = argv;
time = t_end -. t_start;
output_file = None;
output;
errors = "";
- status }
+ status;
+ }
(* -- Captured fs placement ----------------------------------------------- *)
-(** Copy the files listed in [rels] (relative to [src_root]) into
- [dst_root] (keeping the same relative paths). Uses hardlinks
- when possible to avoid copying file data. *)
+(** Copy the files listed in [rels] (relative to [src_root]) into [dst_root]
+ (keeping the same relative paths). Uses hardlinks when possible to avoid
+ copying file data. *)
let place_changed_files ~src_root ~dst_root rels =
let src_s = Fpath.to_string src_root in
let dst_s = Fpath.to_string dst_root in
mkdir dst_root;
- List.iter (fun rel ->
- let src = Filename.concat src_s rel in
- let dst = Filename.concat dst_s rel in
- let parent = Filename.dirname dst in
- if not (Sys.file_exists parent) then
- mkdir (Fpath.v parent);
- match Unix.lstat src with
- | exception Unix.Unix_error _ -> ()
- | st ->
- match st.st_kind with
- | Unix.S_LNK ->
- (try
- let target = Unix.readlink src in
- (try Unix.unlink dst with Unix.Unix_error _ -> ());
- Unix.symlink target dst
- with Unix.Unix_error _ -> ())
- | Unix.S_REG ->
- (try
- (try Unix.unlink dst with Unix.Unix_error _ -> ());
- Unix.link src dst
- with Unix.Unix_error _ ->
- (* Different filesystem or hardlink protection: fall back
+ List.iter
+ (fun rel ->
+ let src = Filename.concat src_s rel in
+ let dst = Filename.concat dst_s rel in
+ let parent = Filename.dirname dst in
+ if not (Sys.file_exists parent) then mkdir (Fpath.v parent);
+ match Unix.lstat src with
+ | exception Unix.Unix_error _ -> ()
+ | st -> (
+ match st.st_kind with
+ | Unix.S_LNK -> (
+ try
+ let target = Unix.readlink src in
+ (try Unix.unlink dst with Unix.Unix_error _ -> ());
+ Unix.symlink target dst
+ with Unix.Unix_error _ -> ())
+ | Unix.S_REG -> (
+ try
+ (try Unix.unlink dst with Unix.Unix_error _ -> ());
+ Unix.link src dst
+ with Unix.Unix_error _ ->
+ (* Different filesystem or hardlink protection: fall back
to copy via cp --preserve=all. *)
- let _ = Sys.command (Printf.sprintf "cp -p --no-dereference %s %s"
- (Filename.quote src) (Filename.quote dst)) in ())
- | _ -> ()
- ) rels
+ let _ =
+ Sys.command
+ (Printf.sprintf "cp -p --no-dereference %s %s"
+ (Filename.quote src) (Filename.quote dst))
+ in
+ ())
+ | _ -> ()))
+ rels
(* -- Entry point --------------------------------------------------------- *)
-let build ~sw env (benv : Types.build_env)
- ~opam_repositories ?mounts:_
- ?patches ?build_dirs
- ?prep_upper:_ ?strategy
- (node : Build.t) ~target_fs () =
+let build ~sw env (benv : Types.build_env) ~opam_repositories ?mounts:_ ?patches
+ ?build_dirs ?prep_upper:_ ?strategy (node : Build.t) ~target_fs () =
let os_dir = benv.os_dir in
let pkg_str = OpamPackage.to_string node.pkg in
- let strategy = match strategy with
+ let strategy =
+ match strategy with
| Some s -> s
| None -> Container_backend.opam_build_strategy ?patches node.pkg
in
- let dep_dirs = match build_dirs with
+ let dep_dirs =
+ match build_dirs with
| Some dirs -> dirs
- | None ->
- Container_backend.collect_transitive_dep_dirs ~os_dir node
+ | None -> Container_backend.collect_transitive_dep_dirs ~os_dir node
in
(* Every native build needs a valid OPAMROOT. Seed one via
Opam_init_base and stack it AT THE BOTTOM so dep layers'
switch-state / install records override the empty init. *)
let dep_dirs =
- match Opam_init_base.ensure ~sw env ~os_dir
- ~opam_repositories () with
+ match Opam_init_base.ensure ~sw env ~os_dir ~opam_repositories () with
| Ok layer ->
- Log.info (fun m -> m "Seeding native build with opam-init base %s"
- (Day11_layer.Layer.hash layer));
- dep_dirs @ [ Day11_layer.Layer.dir layer ]
+ Log.info (fun m ->
+ m "Seeding native build with opam-init base %s"
+ (Day11_layer.Layer.hash layer));
+ dep_dirs @ [ Day11_layer.Layer.dir layer ]
| Error (`Msg e) ->
- Log.warn (fun m -> m "Opam_init_base.ensure failed: %s" e);
- dep_dirs
+ Log.warn (fun m -> m "Opam_init_base.ensure failed: %s" e);
+ dep_dirs
in
let temp_dir = Bos.OS.Dir.tmp "day11_native_%s" |> Result.get_ok in
let switch_rel = Fpath.(v "home" / "opam" / ".opam" / Types.switch) in
@@ -151,202 +153,231 @@ let build ~sw env (benv : Types.build_env)
[$HOME/.day11/native-debug/] for post-mortem inspection. *)
let keep_temp = Sys.getenv_opt "DAY11_NATIVE_KEEP_TEMP" <> None in
let cleanup_temp () =
- if keep_temp then begin
- let keep_root = Fpath.(v (Sys.getenv "HOME") / ".day11"
- / "native-debug") in
+ if keep_temp then (
+ let keep_root =
+ Fpath.(v (Sys.getenv "HOME") / ".day11" / "native-debug")
+ in
ignore (Bos.OS.Dir.create ~path:true keep_root);
let dst = Fpath.(keep_root / Fpath.basename temp_dir) in
- let _ = Sys.command (Printf.sprintf "mv %s %s 2>/dev/null"
- (Filename.quote (Fpath.to_string temp_dir))
- (Filename.quote (Fpath.to_string dst))) in
- Log.info (fun m -> m "DAY11_NATIVE_KEEP_TEMP — saved %a"
- Fpath.pp dst)
- end else
- ignore (Bos.OS.Path.delete ~recurse:true temp_dir)
+ let _ =
+ Sys.command
+ (Printf.sprintf "mv %s %s 2>/dev/null"
+ (Filename.quote (Fpath.to_string temp_dir))
+ (Filename.quote (Fpath.to_string dst)))
+ in
+ Log.info (fun m -> m "DAY11_NATIVE_KEEP_TEMP — saved %a" Fpath.pp dst))
+ else ignore (Bos.OS.Path.delete ~recurse:true temp_dir)
in
Log.info (fun m -> m "Native build %s in %a" pkg_str Fpath.pp temp_dir);
(* 1. Merge dep layers into temp_dir. Each dep's fs/ looks like
fs/home/opam/.opam/default/<stuff>, so merging fs/ into temp_dir
reconstructs that structure under temp_dir/home/opam/.opam/default/. *)
- Log.info (fun m -> m "Merging %d dep dirs into %a for %s"
- (List.length dep_dirs) Fpath.pp temp_dir pkg_str);
- List.iter (fun d ->
- Log.info (fun m -> m " dep %a" Fpath.pp d)) dep_dirs;
- match Day11_layer.Stack.merge_no_sudo env ~layer_dirs:dep_dirs ~target:temp_dir with
+ Log.info (fun m ->
+ m "Merging %d dep dirs into %a for %s" (List.length dep_dirs) Fpath.pp
+ temp_dir pkg_str);
+ List.iter (fun d -> Log.info (fun m -> m " dep %a" Fpath.pp d)) dep_dirs;
+ match
+ Day11_layer.Stack.merge_no_sudo env ~layer_dirs:dep_dirs ~target:temp_dir
+ with
| Error (`Msg e) as err ->
- Log.err (fun m -> m "Merge failed: %s" e);
- cleanup_temp ();
- err
+ Log.err (fun m -> m "Merge failed: %s" e);
+ cleanup_temp ();
+ err
| Ok () ->
- (* 2. Ensure prefix dirs exist even if no deps (first-layer builds). *)
- List.iter mkdir [ temp_home; temp_opamroot; temp_switch ];
- (* 3. Populate opam-build's repo mount location from provided repos. *)
- let repo_dst = Fpath.(temp_opamroot / "repo" / "default") in
- (match opam_repositories with
- | [] -> ()
- | repos ->
- mkdir (Fpath.parent repo_dst);
- (match Day11_opam_layer.Opam_repo.create (Fpath.parent repo_dst) with
- | Ok _ ->
- let _ = Day11_opam_layer.Opam_repo.populate ~opam_repo:repo_dst
- ~opam_repositories:repos [ node.pkg ] in ()
- | Error _ -> ()));
- (* 4. Write switch-state from merged packages dir. *)
- let packages_dir = Fpath.(temp_switch / ".opam-switch" / "packages") in
- if Bos.OS.Dir.exists packages_dir |> Result.get_ok then begin
- let state_file = Fpath.(temp_switch / ".opam-switch" / "switch-state") in
- ignore (Day11_opam_layer.Opamh.dump_state [ packages_dir ] state_file)
- end;
- (* 4b. Rewrite switch-config for the CURRENT temp path. Dep
+ (* 2. Ensure prefix dirs exist even if no deps (first-layer builds). *)
+ List.iter mkdir [ temp_home; temp_opamroot; temp_switch ];
+ (* 3. Populate opam-build's repo mount location from provided repos. *)
+ let repo_dst = Fpath.(temp_opamroot / "repo" / "default") in
+ (match opam_repositories with
+ | [] -> ()
+ | repos -> (
+ mkdir (Fpath.parent repo_dst);
+ match Day11_opam_layer.Opam_repo.create (Fpath.parent repo_dst) with
+ | Ok _ ->
+ let _ =
+ Day11_opam_layer.Opam_repo.populate ~opam_repo:repo_dst
+ ~opam_repositories:repos [ node.pkg ]
+ in
+ ()
+ | Error _ -> ()));
+ (* 4. Write switch-state from merged packages dir. *)
+ let packages_dir = Fpath.(temp_switch / ".opam-switch" / "packages") in
+ (if Bos.OS.Dir.exists packages_dir |> Result.get_ok then
+ let state_file =
+ Fpath.(temp_switch / ".opam-switch" / "switch-state")
+ in
+ ignore (Day11_opam_layer.Opamh.dump_state [ packages_dir ] state_file));
+ (* 4b. Rewrite switch-config for the CURRENT temp path. Dep
layers built by container carry a switch-config hard-coded
to /home/opam/.opam, which makes opam barf with Not_found
here. A fresh file keyed to our temp path sidesteps that. *)
- let switch_config =
- Fpath.(temp_switch / ".opam-switch" / "switch-config") in
- let user =
- try (Unix.getpwuid benv.uid).pw_name
- with Not_found -> string_of_int benv.uid
- in
- let group =
- try (Unix.getgrgid benv.gid).gr_name
- with Not_found -> string_of_int benv.gid
- in
- let _ = Bos.OS.File.write switch_config
- (Printf.sprintf
- "opam-version: \"2.0\"\n\
- synopsis: \"default\"\n\
- opam-root: %S\n\
- paths {\n}\n\
- variables {\n user: %S\n group: %S\n}\n"
- (Fpath.to_string temp_opamroot) user group)
- in
- (* 4c. Rewrite .opam-switch/environment. Dep layers carry a
+ let switch_config =
+ Fpath.(temp_switch / ".opam-switch" / "switch-config")
+ in
+ let user =
+ try (Unix.getpwuid benv.uid).pw_name
+ with Not_found -> string_of_int benv.uid
+ in
+ let group =
+ try (Unix.getgrgid benv.gid).gr_name
+ with Not_found -> string_of_int benv.gid
+ in
+ let _ =
+ Bos.OS.File.write switch_config
+ (Printf.sprintf
+ "opam-version: \"2.0\"\n\
+ synopsis: \"default\"\n\
+ opam-root: %S\n\
+ paths {\n\
+ }\n\
+ variables {\n\
+ \ user: %S\n\
+ \ group: %S\n\
+ }\n"
+ (Fpath.to_string temp_opamroot)
+ user group)
+ in
+ (* 4c. Rewrite .opam-switch/environment. Dep layers carry a
stale OPAM_SWITCH_PREFIX and PATH baked to the old build's
[/tmp/day11_native_XXXXXX] path. opam-build would then
export those and downstream tools (js_of_ocaml, dune) would
look for findlib.conf etc. at the dead temp location. Replace
any such embedded path with our current temp_switch. *)
- let environment_file =
- Fpath.(temp_switch / ".opam-switch" / "environment") in
- (match Bos.OS.File.read environment_file with
- | Error _ -> ()
- | Ok contents ->
- (* Scan for /tmp/day11_native_XXXXXX/home/opam/.opam/default,
+ let environment_file =
+ Fpath.(temp_switch / ".opam-switch" / "environment")
+ in
+ (match Bos.OS.File.read environment_file with
+ | Error _ -> ()
+ | Ok contents ->
+ (* Scan for /tmp/day11_native_XXXXXX/home/opam/.opam/default,
replace every occurrence with temp_switch. *)
- let needle_prefix = "/tmp/day11_native_" in
- let rec replace acc i =
- match String.index_from_opt contents i needle_prefix.[0] with
- | None -> acc ^ String.sub contents i (String.length contents - i)
- | Some j ->
- let tail_start = j + String.length needle_prefix in
- if tail_start > String.length contents
- || not (String.length contents - j >= String.length needle_prefix
- && String.sub contents j (String.length needle_prefix) = needle_prefix)
- then replace (acc ^ String.sub contents i (j - i + 1)) (j + 1)
- else begin
- (* Advance past the 6-hex suffix and the "/home/opam/.opam/default" *)
- let rec eat_hex k =
- if k < String.length contents
- && ((contents.[k] >= '0' && contents.[k] <= '9')
- || (contents.[k] >= 'a' && contents.[k] <= 'f'))
- then eat_hex (k + 1) else k
- in
- let hex_end = eat_hex tail_start in
- let suffix = "/home/opam/.opam/default" in
- let suf_len = String.length suffix in
- if hex_end + suf_len <= String.length contents
- && String.sub contents hex_end suf_len = suffix
- then
- replace
- (acc ^ String.sub contents i (j - i)
- ^ Fpath.to_string temp_switch)
- (hex_end + suf_len)
- else
- replace (acc ^ String.sub contents i (j - i + 1)) (j + 1)
- end
- in
- let new_contents = replace "" 0 in
- if new_contents <> contents then begin
- (* Break the hardlink from the dep layer before writing. *)
- ignore (Unix.unlink (Fpath.to_string environment_file));
- let _ = Bos.OS.File.write environment_file new_contents in
- Log.info (fun m -> m "Rewrote .opam-switch/environment prefix paths")
- end);
- (* 5. Snapshot the prefix before the build. *)
- let before = Snapshot.take env temp_switch in
- Log.info (fun m -> m "Snapshot before: %d files" (Snapshot.size before));
- (* 6. Run opam-build. Build a stripped-down env so host opam
+ let needle_prefix = "/tmp/day11_native_" in
+ let rec replace acc i =
+ match String.index_from_opt contents i needle_prefix.[0] with
+ | None -> acc ^ String.sub contents i (String.length contents - i)
+ | Some j ->
+ let tail_start = j + String.length needle_prefix in
+ if
+ tail_start > String.length contents
+ || not
+ (String.length contents - j
+ >= String.length needle_prefix
+ && String.sub contents j (String.length needle_prefix)
+ = needle_prefix)
+ then replace (acc ^ String.sub contents i (j - i + 1)) (j + 1)
+ else
+ (* Advance past the 6-hex suffix and the "/home/opam/.opam/default" *)
+ let rec eat_hex k =
+ if
+ k < String.length contents
+ && ((contents.[k] >= '0' && contents.[k] <= '9')
+ || (contents.[k] >= 'a' && contents.[k] <= 'f'))
+ then eat_hex (k + 1)
+ else k
+ in
+ let hex_end = eat_hex tail_start in
+ let suffix = "/home/opam/.opam/default" in
+ let suf_len = String.length suffix in
+ if
+ hex_end + suf_len <= String.length contents
+ && String.sub contents hex_end suf_len = suffix
+ then
+ replace
+ (acc
+ ^ String.sub contents i (j - i)
+ ^ Fpath.to_string temp_switch)
+ (hex_end + suf_len)
+ else replace (acc ^ String.sub contents i (j - i + 1)) (j + 1)
+ in
+ let new_contents = replace "" 0 in
+ if new_contents <> contents then (
+ (* Break the hardlink from the dep layer before writing. *)
+ ignore (Unix.unlink (Fpath.to_string environment_file));
+ let _ = Bos.OS.File.write environment_file new_contents in
+ Log.info (fun m ->
+ m "Rewrote .opam-switch/environment prefix paths")));
+ (* 5. Snapshot the prefix before the build. *)
+ let before = Snapshot.take env temp_switch in
+ Log.info (fun m -> m "Snapshot before: %d files" (Snapshot.size before));
+ (* 6. Run opam-build. Build a stripped-down env so host opam
state doesn't bleed in (OPAM_SWITCH_PREFIX, CAML_LD_LIBRARY_PATH,
etc. would otherwise make opam-build think the compiler is
already installed). *)
- let opam_build_bin_dir =
- let candidates = [
- Fpath.(v (Sys.getenv "HOME") / ".day11" / "cache" / "opam-build-bin");
- Fpath.v "/usr/local/bin/opam-build";
- ] in
- List.find_map (fun p ->
- if Bos.OS.File.exists p |> Result.value ~default:false then begin
- (* If the cached binary is a single file (not directory),
+ let opam_build_bin_dir =
+ let candidates =
+ [
+ Fpath.(
+ v (Sys.getenv "HOME") / ".day11" / "cache" / "opam-build-bin");
+ Fpath.v "/usr/local/bin/opam-build";
+ ]
+ in
+ List.find_map
+ (fun p ->
+ if Bos.OS.File.exists p |> Result.value ~default:false then (
+ (* If the cached binary is a single file (not directory),
symlink it into temp_dir/bin so we have a dir to prepend
to PATH. *)
- let fname = Fpath.basename p in
- let dir = Fpath.(temp_dir / "bin") in
- mkdir dir;
- let target = Fpath.(dir / "opam-build") in
- (try Unix.unlink (Fpath.to_string target)
- with Unix.Unix_error _ -> ());
- (try Unix.symlink (Fpath.to_string p) (Fpath.to_string target)
- with Unix.Unix_error _ -> ());
- Log.info (fun m -> m "Found opam-build at %a (as %s)"
- Fpath.pp p fname);
- Some dir
- end else None
- ) candidates
- in
- let path =
- let base =
- "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"
+ let fname = Fpath.basename p in
+ let dir = Fpath.(temp_dir / "bin") in
+ mkdir dir;
+ let target = Fpath.(dir / "opam-build") in
+ (try Unix.unlink (Fpath.to_string target)
+ with Unix.Unix_error _ -> ());
+ (try Unix.symlink (Fpath.to_string p) (Fpath.to_string target)
+ with Unix.Unix_error _ -> ());
+ Log.info (fun m ->
+ m "Found opam-build at %a (as %s)" Fpath.pp p fname);
+ Some dir)
+ else None)
+ candidates
+ in
+ let path =
+ let base =
+ "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"
+ in
+ match opam_build_bin_dir with
+ | Some d -> Fpath.to_string d ^ ":" ^ base
+ | None -> base
in
- match opam_build_bin_dir with
- | Some d -> Fpath.to_string d ^ ":" ^ base
- | None -> base
- in
- let environ = [
- ("HOME", Fpath.to_string temp_home);
- ("OPAMROOT", Fpath.to_string temp_opamroot);
- ("OPAMYES", "true");
- ("OPAMNOCHECKSUMS", "false");
- ("PATH", path);
- (* Tools built in prior native builds (ocamlfind, js_of_ocaml,
+ let environ =
+ [
+ ("HOME", Fpath.to_string temp_home);
+ ("OPAMROOT", Fpath.to_string temp_opamroot);
+ ("OPAMYES", "true");
+ ("OPAMNOCHECKSUMS", "false");
+ ("PATH", path);
+ (* Tools built in prior native builds (ocamlfind, js_of_ocaml,
etc.) bake their build-time prefix into their binaries as the
default [findlib.conf] lookup path. Setting OCAMLFIND_CONF
here overrides that baked-in default so they find the
current prefix's config instead. [findlib.conf] itself is
relocatable ([destdir="."] etc.) so no rewriting needed. *)
- ("OCAMLFIND_CONF",
- Fpath.to_string Fpath.(temp_switch / "lib" / "findlib.conf"));
- ("OCAMLPATH",
- Fpath.to_string Fpath.(temp_switch / "lib") ^ ":" ^
- Fpath.to_string Fpath.(temp_switch / "lib" / "ocaml"));
- (* Preserve just enough of the outer env that builds need. *)
- ("LANG", try Sys.getenv "LANG" with Not_found -> "C.UTF-8");
- ("TERM", try Sys.getenv "TERM" with Not_found -> "dumb");
- ] in
- let cmd = [ "bash"; "-c"; strategy.Types.cmd ] in
- let run = run_with_env env ~cmd ~environ in
- (* 7. Apply strategy.cleanup so transient files aren't captured.
+ ( "OCAMLFIND_CONF",
+ Fpath.to_string Fpath.(temp_switch / "lib" / "findlib.conf") );
+ ( "OCAMLPATH",
+ Fpath.to_string Fpath.(temp_switch / "lib")
+ ^ ":"
+ ^ Fpath.to_string Fpath.(temp_switch / "lib" / "ocaml") );
+ (* Preserve just enough of the outer env that builds need. *)
+ ("LANG", try Sys.getenv "LANG" with Not_found -> "C.UTF-8");
+ ("TERM", try Sys.getenv "TERM" with Not_found -> "dumb");
+ ]
+ in
+ let cmd = [ "bash"; "-c"; strategy.Types.cmd ] in
+ let run = run_with_env env ~cmd ~environ in
+ (* 7. Apply strategy.cleanup so transient files aren't captured.
The cleanup paths use [upper/home/opam/.opam/...] — temp_dir
plays the role of [upper] in native mode. *)
- strategy.cleanup ~sw env temp_dir;
- (* 8. Diff: list files new or modified under temp_switch. *)
- let changed = Snapshot.diff env ~before temp_switch in
- Log.info (fun m -> m "Build %s: %d changed files" pkg_str
- (List.length changed));
- (* 9. Place changed files into target_fs under the same
+ strategy.cleanup ~sw env temp_dir;
+ (* 8. Diff: list files new or modified under temp_switch. *)
+ let changed = Snapshot.diff env ~before temp_switch in
+ Log.info (fun m ->
+ m "Build %s: %d changed files" pkg_str (List.length changed));
+ (* 9. Place changed files into target_fs under the same
home/opam/.opam/default/<rel> layout that container layers use. *)
- let target_switch = Fpath.(target_fs // switch_rel) in
- place_changed_files ~src_root:temp_switch ~dst_root:target_switch changed;
- mkdir target_fs;
- let timing = [ "total", run.time ] in
- cleanup_temp ();
- Ok (run, timing)
+ let target_switch = Fpath.(target_fs // switch_rel) in
+ place_changed_files ~src_root:temp_switch ~dst_root:target_switch changed;
+ mkdir target_fs;
+ let timing = [ ("total", run.time) ] in
+ cleanup_temp ();
+ Ok (run, timing)
File "day11/opam_build/native_backend.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/native_backend.mli b/_build/default/day11/opam_build/.formatted/native_backend.mli
index 49315f3..46d198b 100644
--- a/_build/default/day11/opam_build/native_backend.mli
+++ b/_build/default/day11/opam_build/.formatted/native_backend.mli
@@ -1,29 +1,27 @@
(** Native (host-side) build backend.
- Runs [opam-build] directly on the host with a temporary
- [OPAMROOT] instead of inside a runc container. No sudo required.
- Deps are hardlinked into the temp prefix via
- {!Day11_layer.Stack.merge_no_sudo}; captured files are
+ Runs [opam-build] directly on the host with a temporary [OPAMROOT] instead
+ of inside a runc container. No sudo required. Deps are hardlinked into the
+ temp prefix via {!Day11_layer.Stack.merge_no_sudo}; captured files are
identified by {!Day11_layer.Snapshot} diff.
Use when:
- The deps you need are already native-built (user-owned), OR
- The host has a working opam root that can seed a temp switch.
- Container-specific parameters ([mounts], [prep_upper]) are
- accepted for interface compatibility but ignored. The strategy's
- [cmd] is still honoured — it runs as a subprocess. [strategy.cleanup]
- is applied to the temp prefix before the diff is computed so
- build/source directories don't leak into the captured layer.
+ Container-specific parameters ([mounts], [prep_upper]) are accepted for
+ interface compatibility but ignored. The strategy's [cmd] is still honoured
+ — it runs as a subprocess. [strategy.cleanup] is applied to the temp prefix
+ before the diff is computed so build/source directories don't leak into the
+ captured layer.
{1 Limitations}
- This backend is a work in progress. The exact opam-build
- invocation env (OPAMROOT, HOME, OPAMSWITCH) matches what the
- container backend sets up, but bootstrapping an OPAMROOT from
- scratch is left to the caller — the backend only merges dep
- layers into the temp prefix and runs the build. Callers that
- want to build the first compiler layer must seed the temp
- prefix themselves via a custom prep step (not yet exposed). *)
+ This backend is a work in progress. The exact opam-build invocation env
+ (OPAMROOT, HOME, OPAMSWITCH) matches what the container backend sets up, but
+ bootstrapping an OPAMROOT from scratch is left to the caller — the backend
+ only merges dep layers into the temp prefix and runs the build. Callers that
+ want to build the first compiler layer must seed the temp prefix themselves
+ via a custom prep step (not yet exposed). *)
include Backend.S
File "day11/opam_build/opam_init_base.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/opam_init_base.ml b/_build/default/day11/opam_build/.formatted/opam_init_base.ml
index 5516369..76e38d4 100644
--- a/_build/default/day11/opam_build/opam_init_base.ml
+++ b/_build/default/day11/opam_build/.formatted/opam_init_base.ml
@@ -1,17 +1,18 @@
-let src = Logs.Src.create "day11.build.opam_init_base"
- ~doc:"opam-init seed layer for native builds"
-module Log = (val Logs.src_log src)
+let src =
+ Logs.Src.create "day11.build.opam_init_base"
+ ~doc:"opam-init seed layer for native builds"
+module Log = (val Logs.src_log src)
module Layer = Day11_layer.Layer
-let mkdir path =
- Bos.OS.Dir.create ~path:true path |> ignore
+let mkdir path = Bos.OS.Dir.create ~path:true path |> ignore
(* -- Hash computation ---------------------------------------------------- *)
let opam_version () =
- match Bos.OS.Cmd.run_out Bos.Cmd.(v "opam" % "--version")
- |> Bos.OS.Cmd.out_string with
+ match
+ Bos.OS.Cmd.run_out Bos.Cmd.(v "opam" % "--version") |> Bos.OS.Cmd.out_string
+ with
| Ok (s, _) -> String.trim s
| Error _ -> "unknown"
@@ -27,8 +28,7 @@ let compute_hash ~opam_repositories =
in
Day11_layer.Hash.of_strings inputs
-let layer_dir_name hash =
- "opam-init-" ^ Day11_layer.Dir.name hash
+let layer_dir_name hash = "opam-init-" ^ Day11_layer.Dir.name hash
(* -- Build the layer ----------------------------------------------------- *)
@@ -39,50 +39,52 @@ let run_host_cmd ~sw env cmd =
match run.status with
| `Exited 0 -> Ok ()
| `Exited n ->
- Rresult.R.error_msgf "%s exited %d\n%s\n%s" s n run.output run.errors
- | `Signaled n ->
- Rresult.R.error_msgf "%s signaled %d" s n
+ Rresult.R.error_msgf "%s exited %d\n%s\n%s" s n run.output run.errors
+ | `Signaled n -> Rresult.R.error_msgf "%s signaled %d" s n
let ( let* ) r f = match r with Ok v -> f v | Error _ as e -> e
(* Write the generic layer.json so Layer.exists returns true after build. *)
let write_layer_meta env ~layer ~hash =
let uid = Unix.getuid () and gid = Unix.getgid () in
- let disk_usage = match Day11_sys.Util.dir_size (Layer.dir layer) with
+ let disk_usage =
+ match Day11_sys.Util.dir_size (Layer.dir layer) with
| Ok n -> n
| Error _ -> 0
in
- let meta : Day11_layer.Meta.t = {
- exit_status = 0;
- parent_hashes = [];
- uid; gid;
- base_hash = "opam-init";
- disk_usage;
- timing = Day11_layer.Meta.empty_timing;
- created_at = "";
- failed_dep = None;
- } in
+ let meta : Day11_layer.Meta.t =
+ {
+ exit_status = 0;
+ parent_hashes = [];
+ uid;
+ gid;
+ base_hash = "opam-init";
+ disk_usage;
+ timing = Day11_layer.Meta.empty_timing;
+ created_at = "";
+ failed_dep = None;
+ }
+ in
let _ = Day11_layer.Meta.save env (Layer.meta_path layer) meta in
- let _ = Bos.OS.File.write (Layer.log_path layer)
- (Printf.sprintf "opam-init base layer hash=%s\n" hash)
- in ()
+ let _ =
+ Bos.OS.File.write (Layer.log_path layer)
+ (Printf.sprintf "opam-init base layer hash=%s\n" hash)
+ in
+ ()
let build ~sw env ~os_dir ~opam_repositories =
let hash = compute_hash ~opam_repositories in
let layer_dir = Fpath.(os_dir / layer_dir_name hash) in
let layer : Layer.t = { hash; dir = layer_dir } in
if Layer.exists env layer then Ok layer
- else begin
+ else (
Log.info (fun m -> m "Building opam-init base layer %s" hash);
- let temp_dir = Bos.OS.Dir.tmp "day11_opam_init_%s"
- |> Result.get_ok in
+ let temp_dir = Bos.OS.Dir.tmp "day11_opam_init_%s" |> Result.get_ok in
let home = Fpath.(temp_dir / "home" / "opam") in
let opamroot = Fpath.(home / ".opam") in
mkdir home;
let root_flag = [ "--root"; Fpath.to_string opamroot ] in
- let add_args base args =
- List.fold_left Bos.Cmd.(%) base args
- in
+ let add_args base args = List.fold_left Bos.Cmd.( % ) base args in
(* 1. opam init --bare: creates the global root. NAME and ADDRESS
are positional in opam init; we always name the repo 'default'
so it matches container-build convention. When no repos are
@@ -90,39 +92,44 @@ let build ~sw env ~os_dir ~opam_repositories =
default. *)
let init_base =
add_args
- Bos.Cmd.(v "opam" % "init" % "--bare" % "--no-setup"
- % "--disable-sandboxing" % "-y")
+ Bos.Cmd.(
+ v "opam"
+ % "init"
+ % "--bare"
+ % "--no-setup"
+ % "--disable-sandboxing"
+ % "-y")
root_flag
in
let init_args =
match opam_repositories with
| [] -> init_base
| first :: _ ->
- (* "-k local default <path>" *)
- Bos.Cmd.(init_base % "-k" % "local" % "default"
- % Fpath.to_string first)
+ (* "-k local default <path>" *)
+ Bos.Cmd.(
+ init_base % "-k" % "local" % "default" % Fpath.to_string first)
in
let* () = run_host_cmd ~sw env init_args in
(* 2. Create an empty 'default' switch inside this root. *)
let switch_args =
add_args
- Bos.Cmd.(v "opam" % "switch" % "create" % "default" % "--empty"
- % "-y")
+ Bos.Cmd.(v "opam" % "switch" % "create" % "default" % "--empty" % "-y")
root_flag
in
let* () = run_host_cmd ~sw env switch_args in
(* 3. Move the populated temp home into the layer's fs/. *)
mkdir layer_dir;
let fs_dir = Layer.fs layer in
- let _ = Sys.command (Printf.sprintf "mv %s %s"
- (Filename.quote (Fpath.to_string temp_dir))
- (Filename.quote (Fpath.to_string fs_dir))) in
+ let _ =
+ Sys.command
+ (Printf.sprintf "mv %s %s"
+ (Filename.quote (Fpath.to_string temp_dir))
+ (Filename.quote (Fpath.to_string fs_dir)))
+ in
write_layer_meta env ~layer ~hash;
ignore (Bos.OS.Path.delete ~recurse:true temp_dir);
- Log.info (fun m -> m "opam-init base layer written: %a"
- Fpath.pp layer_dir);
- Ok layer
- end
+ Log.info (fun m -> m "opam-init base layer written: %a" Fpath.pp layer_dir);
+ Ok layer)
let ensure ~sw env ~os_dir ?(opam_repositories = []) () =
build ~sw env ~os_dir ~opam_repositories
File "day11/opam_build/opam_init_base.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/opam_init_base.mli b/_build/default/day11/opam_build/.formatted/opam_init_base.mli
index 76e8af1..b829e3b 100644
--- a/_build/default/day11/opam_build/opam_init_base.mli
+++ b/_build/default/day11/opam_build/.formatted/opam_init_base.mli
@@ -1,15 +1,15 @@
(** opam-init seed layer for the native backend.
Native builds need an [OPAMROOT] with at least one switch before
- [opam-build] will agree to run. This module produces such a root
- once and caches it as a {!Day11_layer.Layer.t}, so every native
- build can stack it as an implicit bottom dep.
+ [opam-build] will agree to run. This module produces such a root once and
+ caches it as a {!Day11_layer.Layer.t}, so every native build can stack it as
+ an implicit bottom dep.
The layer contains [fs/home/opam/.opam/] populated by running
[opam init --bare --no-setup --disable-sandboxing] and
- [opam switch create default --empty]. The resulting tree matches
- the path convention day11 container layers use, so the same
- [Stack.merge] + [.opam-switch/packages]-scanning code applies. *)
+ [opam switch create default --empty]. The resulting tree matches the path
+ convention day11 container layers use, so the same [Stack.merge] +
+ [.opam-switch/packages]-scanning code applies. *)
val ensure :
sw:Eio.Switch.t ->
@@ -18,8 +18,8 @@ val ensure :
?opam_repositories:Fpath.t list ->
unit ->
(Day11_layer.Layer.t, [> Rresult.R.msg ]) result
-(** [ensure ~sw env ~os_dir ?opam_repositories ()] returns the opam-init
- layer, building it if not already cached. The layer's hash is
- derived deterministically from the [opam --version], the init
- flags, and the list of opam repositories (by name — not commit
- SHA, so repo-content changes do not invalidate the init layer). *)
+(** [ensure ~sw env ~os_dir ?opam_repositories ()] returns the opam-init layer,
+ building it if not already cached. The layer's hash is derived
+ deterministically from the [opam --version], the init flags, and the list of
+ opam repositories (by name — not commit SHA, so repo-content changes do not
+ invalidate the init layer). *)
File "day11/opam_build/patches.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/patches.ml b/_build/default/day11/opam_build/.formatted/patches.ml
index 8a0e31f..3126085 100644
--- a/_build/default/day11/opam_build/patches.ml
+++ b/_build/default/day11/opam_build/.formatted/patches.ml
@@ -14,49 +14,51 @@ let patches_for t pkg =
match Hashtbl.find_opt t.cache key with
| Some ps -> ps
| None ->
- let pkg_dir = Fpath.(t.dir / key) in
- let patches =
- if Bos.OS.Dir.exists pkg_dir |> Result.get_ok then
- match Bos.OS.Dir.contents pkg_dir with
- | Ok entries ->
- entries
- |> List.filter (fun p ->
- Fpath.has_ext ".patch" p || Fpath.has_ext ".diff" p)
- |> List.map Fpath.to_string
- |> List.sort String.compare
- | Error _ -> []
- else []
- in
- Hashtbl.replace t.cache key patches;
- patches
+ let pkg_dir = Fpath.(t.dir / key) in
+ let patches =
+ if Bos.OS.Dir.exists pkg_dir |> Result.get_ok then
+ match Bos.OS.Dir.contents pkg_dir with
+ | Ok entries ->
+ entries
+ |> List.filter (fun p ->
+ Fpath.has_ext ".patch" p || Fpath.has_ext ".diff" p)
+ |> List.map Fpath.to_string
+ |> List.sort String.compare
+ | Error _ -> []
+ else []
+ in
+ Hashtbl.replace t.cache key patches;
+ patches
let hash_for t pkg =
let key = OpamPackage.to_string pkg in
match Hashtbl.find_opt t.hash_cache key with
| Some h -> h
| None ->
- let patches = patches_for t pkg in
- let h = match patches with
- | [] -> ""
- | ps ->
- let contents = List.map (fun p ->
- match Bos.OS.File.read (Fpath.v p) with
- | Ok s -> s
- | Error _ -> ""
- ) ps in
- Digest.string (String.concat "\n" contents) |> Digest.to_hex
- in
- Hashtbl.replace t.hash_cache key h;
- h
+ let patches = patches_for t pkg in
+ let h =
+ match patches with
+ | [] -> ""
+ | ps ->
+ let contents =
+ List.map
+ (fun p ->
+ match Bos.OS.File.read (Fpath.v p) with
+ | Ok s -> s
+ | Error _ -> "")
+ ps
+ in
+ Digest.string (String.concat "\n" contents) |> Digest.to_hex
+ in
+ Hashtbl.replace t.hash_cache key h;
+ h
-let has_patches t pkg =
- patches_for t pkg <> []
+let has_patches t pkg = patches_for t pkg <> []
let patch_args t pkg =
- List.mapi (fun i _p ->
- Printf.sprintf "--patch /patches/%03d.patch" i
- ) (patches_for t pkg)
+ List.mapi
+ (fun i _p -> Printf.sprintf "--patch /patches/%03d.patch" i)
+ (patches_for t pkg)
|> String.concat " "
-let patch_filenames t pkg =
- List.map Filename.basename (patches_for t pkg)
+let patch_filenames t pkg = List.map Filename.basename (patches_for t pkg)
File "day11/opam_build/patches.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/patches.mli b/_build/default/day11/opam_build/.formatted/patches.mli
index b099f96..db3395a 100644
--- a/_build/default/day11/opam_build/patches.mli
+++ b/_build/default/day11/opam_build/.formatted/patches.mli
@@ -1,14 +1,14 @@
(** Package patches: load, hash, and apply via opam-build --patch.
- Patches are stored in a directory tree keyed by package name
- and version. When present, they are bind-mounted into the build
- container and passed to opam-build as [--patch] arguments. *)
+ Patches are stored in a directory tree keyed by package name and version.
+ When present, they are bind-mounted into the build container and passed to
+ opam-build as [--patch] arguments. *)
type t
val create : Fpath.t -> t
-(** [create dir] creates a patch set rooted at [dir]. Patches for
- package [name.version] are expected at [dir/name/version/*.patch]. *)
+(** [create dir] creates a patch set rooted at [dir]. Patches for package
+ [name.version] are expected at [dir/name/version/*.patch]. *)
val has_patches : t -> OpamPackage.t -> bool
(** [has_patches t pkg] returns true if any patches exist for [pkg]. *)
@@ -17,13 +17,13 @@ val patches_for : t -> OpamPackage.t -> string list
(** [patches_for t pkg] returns the list of patch file paths for [pkg]. *)
val hash_for : t -> OpamPackage.t -> string
-(** [hash_for t pkg] returns a content hash of all patches for [pkg],
- used to include patches in layer hash computation. *)
+(** [hash_for t pkg] returns a content hash of all patches for [pkg], used to
+ include patches in layer hash computation. *)
val patch_args : t -> OpamPackage.t -> string
-(** [patch_args t pkg] returns the [--patch] arguments for
- opam-build's command line as a single string. *)
+(** [patch_args t pkg] returns the [--patch] arguments for opam-build's command
+ line as a single string. *)
val patch_filenames : t -> OpamPackage.t -> string list
-(** [patch_filenames t pkg] returns just the patch filenames
- (without directory path). *)
+(** [patch_filenames t pkg] returns just the patch filenames (without directory
+ path). *)
File "day11/opam_build/tools.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/tools.ml b/_build/default/day11/opam_build/.formatted/tools.ml
index 3461755..f5bcbf8 100644
--- a/_build/default/day11/opam_build/tools.ml
+++ b/_build/default/day11/opam_build/.formatted/tools.ml
@@ -1,84 +1,84 @@
let src = Logs.Src.create "day11.build.tools" ~doc:"Tool building"
-module Log = (val Logs.src_log src)
+module Log = (val Logs.src_log src)
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
+
type build = Build.t
let read_pins_from_dir dir =
- let opam_files = Sys.readdir dir |> Array.to_list
- |> List.filter (fun f -> Filename.check_suffix f ".opam") in
- List.fold_left (fun acc filename ->
- let name = Filename.chop_suffix filename ".opam" in
- let path = Filename.concat dir filename in
- try
- let opam = OpamFile.OPAM.read
- (OpamFile.make (OpamFilename.raw path)) in
- OpamPackage.Name.Map.add
- (OpamPackage.Name.of_string name)
- (OpamPackage.Version.of_string "dev", opam) acc
- with _ -> acc
- ) OpamPackage.Name.Map.empty opam_files
+ let opam_files =
+ Sys.readdir dir
+ |> Array.to_list
+ |> List.filter (fun f -> Filename.check_suffix f ".opam")
+ in
+ List.fold_left
+ (fun acc filename ->
+ let name = Filename.chop_suffix filename ".opam" in
+ let path = Filename.concat dir filename in
+ try
+ let opam = OpamFile.OPAM.read (OpamFile.make (OpamFilename.raw path)) in
+ OpamPackage.Name.Map.add
+ (OpamPackage.Name.of_string name)
+ (OpamPackage.Version.of_string "dev", opam)
+ acc
+ with _ -> acc)
+ OpamPackage.Name.Map.empty opam_files
let source_dir_strategy pkg =
let pkg_str = OpamPackage.to_string pkg in
- { Types.cmd = Printf.sprintf
- "opam-build -v %s --source-dir /home/opam/src"
- pkg_str;
- cleanup = Build_layer.opam_build_cleanup }
+ {
+ Types.cmd =
+ Printf.sprintf "opam-build -v %s --source-dir /home/opam/src" pkg_str;
+ cleanup = Build_layer.opam_build_cleanup;
+ }
let plan_tool ~sw env (benv : Types.build_env) ~packages ~repos
- ?(constraints = [])
- ?(pin_dirs = [])
- ?(doc = true)
- ?ocaml_version
- ?(source_dirs = OpamPackage.Name.Map.empty)
- ?cache
- target =
+ ?(constraints = []) ?(pin_dirs = []) ?(doc = true) ?ocaml_version
+ ?(source_dirs = OpamPackage.Name.Map.empty) ?cache target =
let pkg_str = OpamPackage.to_string target in
Log.info (fun m -> m "Planning tool %s" pkg_str);
- let results = Day11_solver_pool.Solver_pool.solve_many ~sw env
- ~pin_dirs ~constraints ~doc ?ocaml_version
- ~np:1 ~repos [ target ] in
+ let results =
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ~pin_dirs ~constraints ~doc
+ ?ocaml_version ~np:1 ~repos [ target ]
+ in
match List.assoc_opt target results with
- | None ->
- Rresult.R.error_msgf "Cannot solve %s: no result" pkg_str
+ | None -> Rresult.R.error_msgf "Cannot solve %s: no result" pkg_str
| Some (Error (diag, _examined)) ->
Rresult.R.error_msgf "Cannot solve %s: %s" pkg_str diag
| Some (Ok result) ->
let solution = result.Day11_solution.Solve_result.build_deps in
let doc_solution = result.Day11_solution.Solve_result.doc_deps in
- let cache = match cache with
+ let cache =
+ match cache with
| Some c -> c
| None ->
- let find_opam = Day11_opam.Git_packages.find_package packages in
- Hash_cache.create ~find_opam ()
+ let find_opam = Day11_opam.Git_packages.find_package packages in
+ Hash_cache.create ~find_opam ()
+ in
+ let nodes =
+ Dag.build_dag cache ~base_hash:benv.base.hash
+ [ (target, solution, doc_solution) ]
+ in
+ let last =
+ List.find (fun (n : build) -> OpamPackage.equal n.pkg target) nodes
in
- let nodes = Dag.build_dag cache ~base_hash:benv.base.hash
- [ (target, solution, doc_solution) ] in
- let last = List.find (fun (n : build) ->
- OpamPackage.equal n.pkg target) nodes in
let tool_dir = Build.dir ~os_dir:benv.os_dir last in
- Log.info (fun m -> m "Tool %s: %d nodes in DAG"
- pkg_str (List.length nodes));
- Ok ({ Tool.hash = last.hash; dir = tool_dir;
- builds = nodes },
- source_dirs)
+ Log.info (fun m ->
+ m "Tool %s: %d nodes in DAG" pkg_str (List.length nodes));
+ Ok ({ Tool.hash = last.hash; dir = tool_dir; builds = nodes }, source_dirs)
let build_tool ~sw env (benv : Types.build_env) ?(np = 4) ~packages ~repos
- ?(onstraints = [])
- ?(pin_dirs = [])
- ?(doc = true)
- ?ocaml_version
- ?(source_dirs = OpamPackage.Name.Map.empty)
- ?(mounts = []) target =
+ ?(constraints = []) ?(pin_dirs = []) ?(doc = true) ?ocaml_version
+ ?(source_dirs = OpamPackage.Name.Map.empty) ?(mounts = []) target =
let pkg_str = OpamPackage.to_string target in
Log.info (fun m -> m "Building tool %s" pkg_str);
- match plan_tool ~sw env benv ~packages ~repos
- ~constraints ~pin_dirs ~doc ?ocaml_version
- ~source_dirs target with
+ match
+ plan_tool ~sw env benv ~packages ~repos ~constraints ~pin_dirs ~doc
+ ?ocaml_version ~source_dirs target
+ with
| Error _ as e -> e
- | Ok (tool, source_dirs) ->
+ | Ok (tool, source_dirs) -> (
let nodes = tool.builds in
(* Repo source paths for the per-package slice. [Build_layer.build]
(via [Container_backend]) extracts just [node.pkg] from these
@@ -89,63 +89,74 @@ let build_tool ~sw env (benv : Types.build_env) ?(np = 4) ~packages ~repos
tool nodes previously didn't, hence the slow tool jobs. *)
let opam_repositories = List.map (fun (p, _sha) -> Fpath.v p) repos in
Printf.printf " Solution packages:\n%!";
- List.iter (fun (node : Day11_opam_layer.Build.t) ->
- Printf.printf " %s (%d deps)\n%!"
- (OpamPackage.to_string node.pkg) (List.length node.deps)
- ) nodes;
+ List.iter
+ (fun (node : Day11_opam_layer.Build.t) ->
+ Printf.printf " %s (%d deps)\n%!"
+ (OpamPackage.to_string node.pkg)
+ (List.length node.deps))
+ nodes;
let failed = ref None in
Dag_executor.execute env ~np
~on_complete:(fun ~stats ~cached:_ node success ->
- Printf.printf " [%d/%d, %d ok, %d failed] %s: %s\n%!"
- stats.completed stats.total stats.ok stats.failed
+ Printf.printf " [%d/%d, %d ok, %d failed] %s: %s\n%!" stats.completed
+ stats.total stats.ok stats.failed
(OpamPackage.to_string node.pkg)
(if success then "OK" else "FAIL");
- if not success && !failed = None then
+ if (not success) && !failed = None then
failed := Some (OpamPackage.to_string node.pkg))
~on_cascade:(fun ~failed:f ~failed_dep ->
Printf.printf " CASCADE: %s (dep %s failed)\n%!"
(OpamPackage.to_string f.pkg)
(OpamPackage.to_string failed_dep.pkg);
- if !failed = None then
- failed := Some (OpamPackage.to_string f.pkg))
+ if !failed = None then failed := Some (OpamPackage.to_string f.pkg))
nodes
(fun node ->
let name = OpamPackage.name node.pkg in
match OpamPackage.Name.Map.find_opt name source_dirs with
- | Some dir ->
- let src_mount = Day11_container.Mount.bind_ro
- ~src:dir "/home/opam/src" in
- let strategy = source_dir_strategy node.pkg in
- (match Build_layer.build ~sw env benv
- ~mounts:(src_mount :: mounts) ~opam_repositories node
- ~strategy () with
- | Types.Success _ -> true
- | _ -> false)
- | None ->
- (match Build_layer.build ~sw env benv ~mounts ~opam_repositories node () with
- | Types.Success _ -> true
- | _ -> false));
+ | Some dir -> (
+ let src_mount =
+ Day11_container.Mount.bind_ro ~src:dir "/home/opam/src"
+ in
+ let strategy = source_dir_strategy node.pkg in
+ match
+ Build_layer.build ~sw env benv ~mounts:(src_mount :: mounts)
+ ~opam_repositories node ~strategy ()
+ with
+ | Types.Success _ -> true
+ | _ -> false)
+ | None -> (
+ match
+ Build_layer.build ~sw env benv ~mounts ~opam_repositories node
+ ()
+ with
+ | Types.Success _ -> true
+ | _ -> false));
match !failed with
- | Some name ->
- Rresult.R.error_msgf "Build failed for %s" name
- | None -> Ok tool
+ | Some name -> Rresult.R.error_msgf "Build failed for %s" name
+ | None -> Ok tool)
-let build_tool_from_repo ~sw env benv ?(np = 4) ~packages ~repos
- ?ocaml_version ?(mounts = []) ?(extra_repo_dirs = [])
- ?(extra_target_names = [])
- ~repo_dir ~target_name () =
+let build_tool_from_repo ~sw env benv ?(np = 4) ~packages ~repos ?ocaml_version
+ ?(mounts = []) ?(extra_repo_dirs = []) ?(extra_target_names = []) ~repo_dir
+ ~target_name () =
let all_dirs = repo_dir :: extra_repo_dirs in
- let source_dirs = List.fold_right (fun dir acc ->
- let opam_files = Sys.readdir dir |> Array.to_list
- |> List.filter (fun f -> Filename.check_suffix f ".opam") in
- List.fold_left (fun acc filename ->
- let name = Filename.chop_suffix filename ".opam" in
- OpamPackage.Name.Map.add
- (OpamPackage.Name.of_string name) dir acc
- ) acc opam_files
- ) all_dirs OpamPackage.Name.Map.empty in
+ let source_dirs =
+ List.fold_right
+ (fun dir acc ->
+ let opam_files =
+ Sys.readdir dir
+ |> Array.to_list
+ |> List.filter (fun f -> Filename.check_suffix f ".opam")
+ in
+ List.fold_left
+ (fun acc filename ->
+ let name = Filename.chop_suffix filename ".opam" in
+ OpamPackage.Name.Map.add (OpamPackage.Name.of_string name) dir acc)
+ acc opam_files)
+ all_dirs OpamPackage.Name.Map.empty
+ in
let target = OpamPackage.of_string (target_name ^ ".dev") in
- let constraints = List.map (fun n ->
- OpamPackage.of_string (n ^ ".dev")) extra_target_names in
- build_tool ~sw env benv ~np ~packages ~repos ~pin_dirs:all_dirs
- ~constraints ~source_dirs ~doc:false ?ocaml_version ~mounts target
+ let constraints =
+ List.map (fun n -> OpamPackage.of_string (n ^ ".dev")) extra_target_names
+ in
+ build_tool ~sw env benv ~np ~packages ~repos ~pin_dirs:all_dirs ~constraints
+ ~source_dirs ~doc:false ?ocaml_version ~mounts target
File "day11/opam_build/tools.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/tools.mli b/_build/default/day11/opam_build/.formatted/tools.mli
index f6e91ce..95b477f 100644
--- a/_build/default/day11/opam_build/tools.mli
+++ b/_build/default/day11/opam_build/.formatted/tools.mli
@@ -1,9 +1,8 @@
(** Build tool packages from source. *)
-val source_dir_strategy :
- OpamPackage.t -> Types.build_strategy
-(** Build strategy for packages with a local source directory mounted
- at [/home/opam/src]. *)
+val source_dir_strategy : OpamPackage.t -> Types.build_strategy
+(** Build strategy for packages with a local source directory mounted at
+ [/home/opam/src]. *)
val plan_tool :
sw:Eio.Switch.t ->
@@ -18,14 +17,15 @@ val plan_tool :
?source_dirs:string OpamPackage.Name.Map.t ->
?cache:Hash_cache.t ->
OpamPackage.t ->
- (Day11_opam_layer.Tool.t * string OpamPackage.Name.Map.t,
- [> Rresult.R.msg ]) result
-(** [plan_tool ~sw env benv ~packages ~repos ?cache target] solves [target]
- via solver_worker and creates DAG nodes without building.
- [pin_dirs] are directories of [.opam] files pinned at version [dev].
- [constraints] pins packages at exact versions.
- When [cache] is provided, shares hash computation with the main
- build DAG. Returns the tool plan and source_dirs for pinned packages. *)
+ ( Day11_opam_layer.Tool.t * string OpamPackage.Name.Map.t,
+ [> Rresult.R.msg ] )
+ result
+(** [plan_tool ~sw env benv ~packages ~repos ?cache target] solves [target] via
+ solver_worker and creates DAG nodes without building. [pin_dirs] are
+ directories of [.opam] files pinned at version [dev]. [constraints] pins
+ packages at exact versions. When [cache] is provided, shares hash
+ computation with the main build DAG. Returns the tool plan and source_dirs
+ for pinned packages. *)
val build_tool :
sw:Eio.Switch.t ->
@@ -43,17 +43,15 @@ val build_tool :
OpamPackage.t ->
(Day11_opam_layer.Tool.t, [> Rresult.R.msg ]) result
(** [build_tool ~sw env benv ?np ~packages ~repos target] solves and builds
- [target] and all its dependencies via solver_worker subprocesses.
- [pin_dirs] are directories of [.opam] files pinned at version [dev].
- [constraints] pins packages at exact versions.
- [source_dirs] maps pinned package names to local source directories
- that are mounted into the build container. *)
+ [target] and all its dependencies via solver_worker subprocesses. [pin_dirs]
+ are directories of [.opam] files pinned at version [dev]. [constraints] pins
+ packages at exact versions. [source_dirs] maps pinned package names to local
+ source directories that are mounted into the build container. *)
val read_pins_from_dir :
- string ->
- (OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t
-(** [read_pins_from_dir dir] reads all [.opam] files from [dir] and
- returns a pins map with version ["dev"]. *)
+ string -> (OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t
+(** [read_pins_from_dir dir] reads all [.opam] files from [dir] and returns a
+ pins map with version ["dev"]. *)
val build_tool_from_repo :
sw:Eio.Switch.t ->
@@ -71,7 +69,7 @@ val build_tool_from_repo :
unit ->
(Day11_opam_layer.Tool.t, [> Rresult.R.msg ]) result
(** [build_tool_from_repo ~sw env benv ~packages ~repos ~repo_dir
- ?extra_repo_dirs ~target_name ()] reads [.opam] files from
- [repo_dir] and each [extra_repo_dirs], pins all packages found
- to dev, and builds [target_name.dev] with [~doc:false].
- Use for tool builds from local checkouts. *)
+ ?extra_repo_dirs ~target_name ()] reads [.opam] files from [repo_dir] and
+ each [extra_repo_dirs], pins all packages found to dev, and builds
+ [target_name.dev] with [~doc:false]. Use for tool builds from local
+ checkouts. *)
File "day11/opam_build/types.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/types.ml b/_build/default/day11/opam_build/.formatted/types.ml
index ca43882..f11f8ec 100644
--- a/_build/default/day11/opam_build/types.ml
+++ b/_build/default/day11/opam_build/.formatted/types.ml
@@ -1,5 +1,6 @@
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
+
type build = Build.t
type tool = Tool.t
@@ -9,10 +10,9 @@ type build_env = {
uid : int;
gid : int;
cpu_slots : Day11_runner.Cpu_slots.t option;
- (** Optional NUMA-aware cpuset pool. When [Some], every container
- launch acquires a slot and passes its [(cpuset, numa_mems)]
- into the OCI spec. [None] leaves containers unconstrained
- (legacy behaviour). *)
+ (** Optional NUMA-aware cpuset pool. When [Some], every container launch
+ acquires a slot and passes its [(cpuset, numa_mems)] into the OCI
+ spec. [None] leaves containers unconstrained (legacy behaviour). *)
}
let make_build_env ~base ~os_dir ?(uid = Unix.getuid ()) ?(gid = Unix.getgid ())
File "day11/opam_build/types.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/types.mli b/_build/default/day11/opam_build/.formatted/types.mli
index 43299c3..8d8469b 100644
--- a/_build/default/day11/opam_build/types.mli
+++ b/_build/default/day11/opam_build/.formatted/types.mli
@@ -1,58 +1,62 @@
(** Build types.
- Core type definitions shared across the opam-build pipeline:
- environment configuration, result variants, and build strategies. *)
+ Core type definitions shared across the opam-build pipeline: environment
+ configuration, result variants, and build strategies. *)
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
-(** Alias for {!Day11_opam_layer.Build.t}. *)
type build = Build.t
+(** Alias for {!Day11_opam_layer.Build.t}. *)
-(** Alias for {!Day11_opam_layer.Tool.t}. *)
type tool = Tool.t
+(** Alias for {!Day11_opam_layer.Tool.t}. *)
-(** Invariant build parameters for a batch run.
- The opam switch is always ["default"]. *)
type build_env = {
base : Day11_layer.Base.t; (** Root filesystem layer. *)
- os_dir : Fpath.t; (** Per-OS cache directory. *)
- uid : int; (** UID of the non-root user in the container. *)
- gid : int; (** GID of the non-root user in the container. *)
+ os_dir : Fpath.t; (** Per-OS cache directory. *)
+ uid : int; (** UID of the non-root user in the container. *)
+ gid : int; (** GID of the non-root user in the container. *)
cpu_slots : Day11_runner.Cpu_slots.t option;
- (** Optional NUMA-aware cpu slot pool. When [Some], every
- container launch acquires a slot and pins its cpuset / NUMA
- memory node; [None] leaves containers unconstrained. *)
+ (** Optional NUMA-aware cpu slot pool. When [Some], every container launch
+ acquires a slot and pins its cpuset / NUMA memory node; [None] leaves
+ containers unconstrained. *)
}
+(** Invariant build parameters for a batch run. The opam switch is always
+ ["default"]. *)
-(** Create a {!type:build_env}. [uid] and [gid] default to the current
- process's UID/GID. *)
val make_build_env :
- base:Day11_layer.Base.t -> os_dir:Fpath.t ->
- ?uid:int -> ?gid:int ->
+ base:Day11_layer.Base.t ->
+ os_dir:Fpath.t ->
+ ?uid:int ->
+ ?gid:int ->
?cpu_slots:Day11_runner.Cpu_slots.t ->
- unit -> build_env
+ unit ->
+ build_env
+(** Create a {!type:build_env}. [uid] and [gid] default to the current process's
+ UID/GID. *)
-(** Return the [packages/] subdirectory of {!field:build_env.os_dir}. *)
val packages_dir : build_env -> Fpath.t
+(** Return the [packages/] subdirectory of {!field:build_env.os_dir}. *)
-(** Create [os_dir] and [packages/] if they do not exist. *)
val ensure_dirs : build_env -> unit
+(** Create [os_dir] and [packages/] if they do not exist. *)
-(** The opam switch name used in all builds (["default"]). *)
val switch : string
+(** The opam switch name used in all builds (["default"]). *)
(** Outcome of a build or solve step. *)
type build_result =
| Success of Day11_opam_layer.Build.t (** Build completed successfully. *)
- | Failure of string (** Build failed with an error message. *)
- | Dependency_failed (** A dependency's build failed. *)
- | No_solution of string (** Solver could not find a solution. *)
- | Solution of Day11_solution.Deps.t (** Solver produced a solution (not yet built). *)
+ | Failure of string (** Build failed with an error message. *)
+ | Dependency_failed (** A dependency's build failed. *)
+ | No_solution of string (** Solver could not find a solution. *)
+ | Solution of Day11_solution.Deps.t
+ (** Solver produced a solution (not yet built). *)
-(** A build strategy: the command to run inside the container,
- and a cleanup function applied to the upper dir after the build. *)
type build_strategy = {
cmd : string;
cleanup : sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> Fpath.t -> unit;
}
+(** A build strategy: the command to run inside the container, and a cleanup
+ function applied to the upper dir after the build. *)
File "day11/sys/helper/fork_helper.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/sys/helper/fork_helper.ml b/_build/default/day11/sys/helper/.formatted/fork_helper.ml
index 629abd9..8c1e10e 100644
--- a/_build/default/day11/sys/helper/fork_helper.ml
+++ b/_build/default/day11/sys/helper/.formatted/fork_helper.ml
@@ -23,10 +23,10 @@
let read_exactly fd buf off len =
let rec loop off remaining =
- if remaining > 0 then
+ if remaining > 0 then (
let n = Unix.read fd buf off remaining in
if n = 0 then raise End_of_file;
- loop (off + n) (remaining - n)
+ loop (off + n) (remaining - n))
in
loop off len
@@ -79,9 +79,15 @@ let read_request fd =
let write_response fd status stdout stderr =
(match status with
- | Unix.WEXITED n -> write_u8 fd 0; write_u32 fd n
- | Unix.WSIGNALED n -> write_u8 fd 1; write_u32 fd n
- | Unix.WSTOPPED n -> write_u8 fd 1; write_u32 fd n);
+ | Unix.WEXITED n ->
+ write_u8 fd 0;
+ write_u32 fd n
+ | Unix.WSIGNALED n ->
+ write_u8 fd 1;
+ write_u32 fd n
+ | Unix.WSTOPPED n ->
+ write_u8 fd 1;
+ write_u32 fd n);
write_str fd stdout;
write_str fd stderr
@@ -97,20 +103,21 @@ let read_pipes ?(on_idle = fun () -> ()) r_out r_err =
let fds = ref [ r_out; r_err ] in
while !fds <> [] do
let readable =
- try let r, _, _ = Unix.select !fds [] [] 1.0 in r
- with Unix.Unix_error (Unix.EINTR, _, _) -> [] in
- (match readable with
- | [] -> on_idle ()
- | _ ->
- List.iter (fun fd ->
- let n = Unix.read fd chunk 0 65536 in
- if n = 0 then
- fds := List.filter (fun f -> f <> fd) !fds
- else if fd = r_out then
- Buffer.add_subbytes stdout_buf chunk 0 n
- else
- Buffer.add_subbytes stderr_buf chunk 0 n
- ) readable)
+ try
+ let r, _, _ = Unix.select !fds [] [] 1.0 in
+ r
+ with Unix.Unix_error (Unix.EINTR, _, _) -> []
+ in
+ match readable with
+ | [] -> on_idle ()
+ | _ ->
+ List.iter
+ (fun fd ->
+ let n = Unix.read fd chunk 0 65536 in
+ if n = 0 then fds := List.filter (fun f -> f <> fd) !fds
+ else if fd = r_out then Buffer.add_subbytes stdout_buf chunk 0 n
+ else Buffer.add_subbytes stderr_buf chunk 0 n)
+ readable
done;
Unix.close r_out;
Unix.close r_err;
@@ -135,17 +142,14 @@ let wait_with_watchdog ~orig_ppid worker_pid =
let rec loop delay =
match Unix.waitpid [ WNOHANG ] worker_pid with
| 0, _ ->
- if Unix.getppid () <> orig_ppid then begin
- (try Unix.kill worker_pid Sys.sigkill with _ -> ());
- (try ignore (Unix.waitpid [] worker_pid) with _ -> ());
- exit 0
- end;
- (try Unix.sleepf delay
- with Unix.Unix_error (Unix.EINTR, _, _) -> ());
- loop (Float.min 0.5 (delay *. 2.))
+ if Unix.getppid () <> orig_ppid then (
+ (try Unix.kill worker_pid Sys.sigkill with _ -> ());
+ (try ignore (Unix.waitpid [] worker_pid) with _ -> ());
+ exit 0);
+ (try Unix.sleepf delay with Unix.Unix_error (Unix.EINTR, _, _) -> ());
+ loop (Float.min 0.5 (delay *. 2.))
| _pid, status -> status
- | exception Unix.Unix_error (Unix.ECHILD, _, _) ->
- Unix.WEXITED 127
+ | exception Unix.Unix_error (Unix.ECHILD, _, _) -> Unix.WEXITED 127
in
loop 0.005
@@ -156,34 +160,37 @@ let handle_connection fd =
try
match output_file with
| Some path ->
- let out_fd = Unix.openfile path
- [ O_WRONLY; O_CREAT; O_TRUNC ] 0o644 in
- let pid = Unix.create_process_env
- argv.(0) argv env Unix.stdin out_fd out_fd in
- Unix.close out_fd;
- let status = wait_with_watchdog ~orig_ppid pid in
- let output =
- try In_channel.with_open_text path In_channel.input_all
- with _ -> "" in
- (status, output, "")
+ let out_fd =
+ Unix.openfile path [ O_WRONLY; O_CREAT; O_TRUNC ] 0o644
+ in
+ let pid =
+ Unix.create_process_env argv.(0) argv env Unix.stdin out_fd out_fd
+ in
+ Unix.close out_fd;
+ let status = wait_with_watchdog ~orig_ppid pid in
+ let output =
+ try In_channel.with_open_text path In_channel.input_all
+ with _ -> ""
+ in
+ (status, output, "")
| None ->
- let r_out, w_out = Unix.pipe () in
- let r_err, w_err = Unix.pipe () in
- let pid = Unix.create_process_env
- argv.(0) argv env Unix.stdin w_out w_err in
- Unix.close w_out;
- Unix.close w_err;
- let on_idle () =
- if Unix.getppid () <> orig_ppid then begin
- (try Unix.kill pid Sys.sigkill with _ -> ());
- (try ignore (Unix.waitpid [] pid) with _ -> ());
- exit 0
- end in
- let stdout, stderr = read_pipes ~on_idle r_out r_err in
- let status = wait_with_watchdog ~orig_ppid pid in
- (status, stdout, stderr)
- with exn ->
- (Unix.WEXITED 127, "", Printexc.to_string exn)
+ let r_out, w_out = Unix.pipe () in
+ let r_err, w_err = Unix.pipe () in
+ let pid =
+ Unix.create_process_env argv.(0) argv env Unix.stdin w_out w_err
+ in
+ Unix.close w_out;
+ Unix.close w_err;
+ let on_idle () =
+ if Unix.getppid () <> orig_ppid then (
+ (try Unix.kill pid Sys.sigkill with _ -> ());
+ (try ignore (Unix.waitpid [] pid) with _ -> ());
+ exit 0)
+ in
+ let stdout, stderr = read_pipes ~on_idle r_out r_err in
+ let status = wait_with_watchdog ~orig_ppid pid in
+ (status, stdout, stderr)
+ with exn -> (Unix.WEXITED 127, "", Printexc.to_string exn)
in
write_response fd status stdout stderr;
Unix.close fd
@@ -191,7 +198,7 @@ let handle_connection fd =
let reap_handlers () =
let rec loop () =
match Unix.waitpid [ WNOHANG ] (-1) with
- | 0, _ | exception Unix.Unix_error (ECHILD, _, _) -> ()
+ | 0, _ | (exception Unix.Unix_error (ECHILD, _, _)) -> ()
| _ -> loop ()
in
loop ()
@@ -217,26 +224,25 @@ let () =
if Unix.getppid () <> orig_ppid then exit 0;
let readable =
try
- let r, _, _ = Unix.select [ sock ] [] [] 1.0 in r
- with Unix.Unix_error (EINTR, _, _) -> [] in
+ let r, _, _ = Unix.select [ sock ] [] [] 1.0 in
+ r
+ with Unix.Unix_error (EINTR, _, _) -> []
+ in
match readable with
- | [] -> () (* timeout — loop back to the watchdog check *)
- | _ ->
- match Unix.accept sock with
- | exception Unix.Unix_error (EINTR, _, _) -> ()
- | fd, _ ->
- begin
- let pid = Unix.fork () in
- if pid = 0 then begin
- (* Handler child *)
- Unix.close sock;
- (* Reset SIGCHLD so waitpid works for command children *)
- Sys.set_signal Sys.sigchld Sys.Signal_default;
- (try handle_connection fd
- with e ->
- Printf.eprintf "fork_helper: %s\n%!" (Printexc.to_string e));
- exit 0
- end else
- Unix.close fd
- end
+ | [] -> () (* timeout — loop back to the watchdog check *)
+ | _ -> (
+ match Unix.accept sock with
+ | exception Unix.Unix_error (EINTR, _, _) -> ()
+ | fd, _ ->
+ let pid = Unix.fork () in
+ if pid = 0 then (
+ (* Handler child *)
+ Unix.close sock;
+ (* Reset SIGCHLD so waitpid works for command children *)
+ Sys.set_signal Sys.sigchld Sys.Signal_default;
+ (try handle_connection fd
+ with e ->
+ Printf.eprintf "fork_helper: %s\n%!" (Printexc.to_string e));
+ exit 0)
+ else Unix.close fd)
done
File "day11/opam_build/test/test_build.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/test/test_build.ml b/_build/default/day11/opam_build/test/.formatted/test_build.ml
index d09ff73..0b2ddb2 100644
--- a/_build/default/day11/opam_build/test/test_build.ml
+++ b/_build/default/day11/opam_build/test/.formatted/test_build.ml
@@ -9,8 +9,15 @@ let pkg s = OpamPackage.of_string s
(* ── Types tests ─────────────────────────────────────────────────── *)
let test_build_result_variants () =
- let _s = Types.Success
- { hash = "build-abc"; pkg = pkg "x.1"; deps = []; universe = Day11_solution.Universe.dummy } in
+ let _s =
+ Types.Success
+ {
+ hash = "build-abc";
+ pkg = pkg "x.1";
+ deps = [];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
let _f = Types.Failure "build-abc123" in
let _d = Types.Dependency_failed in
let _n = Types.No_solution "unsatisfiable" in
@@ -18,16 +25,24 @@ let test_build_result_variants () =
()
let test_build_node () =
- let node : Day11_opam_layer.Build.t = {
- hash = "build-abc123";
- pkg = pkg "yojson.2.2.2";
- deps = [{ hash = "build-def456"; pkg = pkg "dune.3.0"; deps = []; universe = Day11_solution.Universe.dummy }];
- universe = Day11_solution.Universe.dummy;
- } in
- Alcotest.(check string) "pkg"
- "yojson.2.2.2" (OpamPackage.to_string node.pkg);
- Alcotest.(check string) "hash"
- "build-abc123" node.hash
+ let node : Day11_opam_layer.Build.t =
+ {
+ hash = "build-abc123";
+ pkg = pkg "yojson.2.2.2";
+ deps =
+ [
+ {
+ hash = "build-def456";
+ pkg = pkg "dune.3.0";
+ deps = [];
+ universe = Day11_solution.Universe.dummy;
+ };
+ ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ Alcotest.(check string) "pkg" "yojson.2.2.2" (OpamPackage.to_string node.pkg);
+ Alcotest.(check string) "hash" "build-abc123" node.hash
(* ── Hash_cache tests ────────────────────────────────────────────── *)
@@ -49,23 +64,25 @@ depends: ["ocaml"]|} in
(* Different opam content → different hash *)
let find_opam2 p =
make_find_opam {|opam-version: "2.0"
-depends: ["ocaml" "fmt"]|} p in
+depends: ["ocaml" "fmt"]|} p
+ in
let cache2 = Hash_cache.create ~find_opam:find_opam2 () in
- let h3 = Hash_cache.pkg_opam_hash cache2
- (pkg "astring.0.8.5") in
+ let h3 = Hash_cache.pkg_opam_hash cache2 (pkg "astring.0.8.5") in
Alcotest.(check bool) "varies with content" true (h1 <> h3)
let test_hash_cache_layer () =
- let find_opam p =
- make_find_opam {|opam-version: "2.0"|} p in
+ let find_opam p = make_find_opam {|opam-version: "2.0"|} p in
let cache = Hash_cache.create ~find_opam () in
- let h1 = Hash_cache.layer_hash cache
- ~base_hash:"base1" [ pkg "astring.0.8.5" ] in
- let h2 = Hash_cache.layer_hash cache
- ~base_hash:"base1" [ pkg "astring.0.8.5" ] in
+ let h1 =
+ Hash_cache.layer_hash cache ~base_hash:"base1" [ pkg "astring.0.8.5" ]
+ in
+ let h2 =
+ Hash_cache.layer_hash cache ~base_hash:"base1" [ pkg "astring.0.8.5" ]
+ in
Alcotest.(check string) "deterministic" h1 h2;
- let h3 = Hash_cache.layer_hash cache
- ~base_hash:"base2" [ pkg "astring.0.8.5" ] in
+ let h3 =
+ Hash_cache.layer_hash cache ~base_hash:"base2" [ pkg "astring.0.8.5" ]
+ in
Alcotest.(check bool) "varies with base" true (h1 <> h3)
(* ── Base tests ──────────────────────────────────────────────────── *)
@@ -85,105 +102,117 @@ let test_base_hash_varies () =
let test_dag_empty () =
let find_opam _p = None in
let cache = Hash_cache.create ~find_opam () in
- let nodes = Dag.build_dag cache
- ~base_hash:"base" [] in
+ let nodes = Dag.build_dag cache ~base_hash:"base" [] in
Alcotest.(check int) "empty" 0 (List.length nodes)
let test_dag_single_solution () =
- let find_opam p =
- make_find_opam {|opam-version: "2.0"|} p in
+ let find_opam p = make_find_opam {|opam-version: "2.0"|} p in
let solution =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "c.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "b.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "b.1") (OpamPackage.Set.singleton (pkg "c.1"))
in
let cache = Hash_cache.create ~find_opam () in
- let nodes = Dag.build_dag cache
- ~base_hash:"base"
- [ (pkg "b.1", solution, solution) ] in
+ let nodes =
+ Dag.build_dag cache ~base_hash:"base" [ (pkg "b.1", solution, solution) ]
+ in
Alcotest.(check int) "2 nodes" 2 (List.length nodes);
- let names = List.map (fun (n : Day11_opam_layer.Build.t) ->
- OpamPackage.to_string n.pkg) nodes in
+ let names =
+ List.map
+ (fun (n : Day11_opam_layer.Build.t) -> OpamPackage.to_string n.pkg)
+ nodes
+ in
Alcotest.(check (list string)) "topo order" [ "c.1"; "b.1" ] names
let test_dag_dedup_across_solutions () =
(* c.1 appears in both solutions with the same deps — should be
deduplicated to one node *)
- let find_opam p =
- make_find_opam {|opam-version: "2.0"|} p in
+ let find_opam p = make_find_opam {|opam-version: "2.0"|} p in
let sol1 =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "c.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "a.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "a.1") (OpamPackage.Set.singleton (pkg "c.1"))
in
let sol2 =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "c.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "b.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "b.1") (OpamPackage.Set.singleton (pkg "c.1"))
in
let cache = Hash_cache.create ~find_opam () in
- let nodes = Dag.build_dag cache ~base_hash:"base"
- [ (pkg "a.1", sol1, sol1); (pkg "b.1", sol2, sol2) ] in
+ let nodes =
+ Dag.build_dag cache ~base_hash:"base"
+ [ (pkg "a.1", sol1, sol1); (pkg "b.1", sol2, sol2) ]
+ in
(* c.1, a.1, b.1 — c.1 appears once despite being in 2 solutions *)
Alcotest.(check int) "3 nodes (c deduplicated)" 3 (List.length nodes);
- let c_nodes = List.filter (fun (n : Day11_opam_layer.Build.t) ->
- OpamPackage.to_string n.pkg = "c.1") nodes in
+ let c_nodes =
+ List.filter
+ (fun (n : Day11_opam_layer.Build.t) ->
+ OpamPackage.to_string n.pkg = "c.1")
+ nodes
+ in
Alcotest.(check int) "1 c node" 1 (List.length c_nodes)
let test_dag_different_universes () =
(* c.1 in two solutions with different deps — NOT deduplicated *)
- let find_opam p =
- make_find_opam {|opam-version: "2.0"|} p in
+ let find_opam p = make_find_opam {|opam-version: "2.0"|} p in
let sol1 =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "d.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "c.1")
- (OpamPackage.Set.singleton (pkg "d.1"))
+ |> OpamPackage.Map.add (pkg "c.1") (OpamPackage.Set.singleton (pkg "d.1"))
in
let sol2 =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "e.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "c.1")
- (OpamPackage.Set.singleton (pkg "e.1"))
+ |> OpamPackage.Map.add (pkg "c.1") (OpamPackage.Set.singleton (pkg "e.1"))
in
let cache = Hash_cache.create ~find_opam () in
- let nodes = Dag.build_dag cache ~base_hash:"base"
- [ (pkg "c.1", sol1, sol1); (pkg "c.1", sol2, sol2) ] in
- let c_nodes = List.filter (fun (n : Day11_opam_layer.Build.t) ->
- OpamPackage.to_string n.pkg = "c.1") nodes in
+ let nodes =
+ Dag.build_dag cache ~base_hash:"base"
+ [ (pkg "c.1", sol1, sol1); (pkg "c.1", sol2, sol2) ]
+ in
+ let c_nodes =
+ List.filter
+ (fun (n : Day11_opam_layer.Build.t) ->
+ OpamPackage.to_string n.pkg = "c.1")
+ nodes
+ in
(* c.1 with dep d.1 vs c.1 with dep e.1 — different universes *)
Alcotest.(check int) "2 c nodes (different universes)" 2 (List.length c_nodes);
(* Universes should differ *)
let u1 = (List.nth c_nodes 0).universe in
let u2 = (List.nth c_nodes 1).universe in
- Alcotest.(check bool) "different universes"
- false (Day11_solution.Universe.equal u1 u2)
+ Alcotest.(check bool)
+ "different universes" false
+ (Day11_solution.Universe.equal u1 u2)
let test_dag_universe_set () =
(* Check universe is computed from transitive deps *)
- let find_opam p =
- make_find_opam {|opam-version: "2.0"|} p in
+ let find_opam p = make_find_opam {|opam-version: "2.0"|} p in
let solution =
OpamPackage.Map.empty
|> OpamPackage.Map.add (pkg "d.1") OpamPackage.Set.empty
- |> OpamPackage.Map.add (pkg "c.1")
- (OpamPackage.Set.singleton (pkg "d.1"))
- |> OpamPackage.Map.add (pkg "b.1")
- (OpamPackage.Set.singleton (pkg "c.1"))
+ |> OpamPackage.Map.add (pkg "c.1") (OpamPackage.Set.singleton (pkg "d.1"))
+ |> OpamPackage.Map.add (pkg "b.1") (OpamPackage.Set.singleton (pkg "c.1"))
in
let cache = Hash_cache.create ~find_opam () in
- let nodes = Dag.build_dag cache ~base_hash:"base"
- [ (pkg "b.1", solution, solution) ] in
- let b_node = List.find (fun (n : Day11_opam_layer.Build.t) ->
- OpamPackage.to_string n.pkg = "b.1") nodes in
+ let nodes =
+ Dag.build_dag cache ~base_hash:"base" [ (pkg "b.1", solution, solution) ]
+ in
+ let b_node =
+ List.find
+ (fun (n : Day11_opam_layer.Build.t) ->
+ OpamPackage.to_string n.pkg = "b.1")
+ nodes
+ in
(* b.1's universe should include c.1 and d.1 (transitive deps) *)
- let expected = Day11_solution.Universe.of_deps
- (OpamPackage.Set.of_list [ pkg "c.1"; pkg "d.1" ]) in
- Alcotest.(check bool) "universe includes transitive deps"
- true (Day11_solution.Universe.equal b_node.universe expected)
+ let expected =
+ Day11_solution.Universe.of_deps
+ (OpamPackage.Set.of_list [ pkg "c.1"; pkg "d.1" ])
+ in
+ Alcotest.(check bool)
+ "universe includes transitive deps" true
+ (Day11_solution.Universe.equal b_node.universe expected)
(* ── Test registration ───────────────────────────────────────────── *)
@@ -206,19 +235,25 @@ let () =
Alcotest.test_case "hash deterministic" `Quick
test_base_hash_deterministic;
Alcotest.test_case "hash varies" `Quick test_base_hash_varies;
- Alcotest.test_case "build_hash deterministic" `Quick
- (fun () ->
- let h1 = Base.build_hash ~os_distribution:"debian"
- ~os_version:"bookworm" ~arch:"x86_64" () in
- let h2 = Base.build_hash ~os_distribution:"debian"
- ~os_version:"bookworm" ~arch:"x86_64" () in
+ Alcotest.test_case "build_hash deterministic" `Quick (fun () ->
+ let h1 =
+ Base.build_hash ~os_distribution:"debian" ~os_version:"bookworm"
+ ~arch:"x86_64" ()
+ in
+ let h2 =
+ Base.build_hash ~os_distribution:"debian" ~os_version:"bookworm"
+ ~arch:"x86_64" ()
+ in
Alcotest.(check string) "same" h1 h2);
- Alcotest.test_case "build_hash varies" `Quick
- (fun () ->
- let h1 = Base.build_hash ~os_distribution:"debian"
- ~os_version:"bookworm" ~arch:"x86_64" () in
- let h2 = Base.build_hash ~os_distribution:"ubuntu"
- ~os_version:"24.04" ~arch:"x86_64" () in
+ Alcotest.test_case "build_hash varies" `Quick (fun () ->
+ let h1 =
+ Base.build_hash ~os_distribution:"debian" ~os_version:"bookworm"
+ ~arch:"x86_64" ()
+ in
+ let h2 =
+ Base.build_hash ~os_distribution:"ubuntu" ~os_version:"24.04"
+ ~arch:"x86_64" ()
+ in
Alcotest.(check bool) "different" true (h1 <> h2));
] );
( "Dag",
File "day11/opam_build/test/test_build_integration.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/test/test_build_integration.ml b/_build/default/day11/opam_build/test/.formatted/test_build_integration.ml
index 6925b64..3fd8cec 100644
--- a/_build/default/day11/opam_build/test/test_build_integration.ml
+++ b/_build/default/day11/opam_build/test/.formatted/test_build_integration.ml
@@ -8,64 +8,86 @@ open Day11_test_util.Test_util
let base_image = "ocaml/opam:debian-ocaml-5.2"
-let test_build_astring () = with_eio @@ fun ~sw env ->
+let test_build_astring () =
+ with_eio @@ fun ~sw env ->
let cache_dir = Fpath.v "/tmp/day11-build-cache" in
mkdir cache_dir;
let os_dir = Fpath.(cache_dir / "linux-x86_64") in
mkdir os_dir;
- let base = Base.ensure ~sw env ~cache_dir ~image:base_image
- |> ok_or_fail "base" in
+ let base =
+ Base.ensure ~sw env ~cache_dir ~image:base_image |> ok_or_fail "base"
+ in
Printf.printf "Base: %s\n%!" (Fpath.to_string base.dir);
let benv : Types.build_env =
- { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None } in
+ { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None }
+ in
let pkg = OpamPackage.of_string "astring.0.8.5" in
- let layer_hash = Day11_layer.Hash.of_strings
- [ "build"; base.hash; "astring.0.8.5" ] in
+ let layer_hash =
+ Day11_layer.Hash.of_strings [ "build"; base.hash; "astring.0.8.5" ]
+ in
let node : Day11_opam_layer.Build.t =
- { hash = layer_hash; pkg; deps = []; universe = Day11_solution.Universe.dummy } in
+ {
+ hash = layer_hash;
+ pkg;
+ deps = [];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
let result =
- Build_layer.build ~sw env benv
- ~opam_repositories:[]
- node
- ~strategy:{ cmd = Printf.sprintf "opam install -y %s"
- (OpamPackage.to_string pkg);
- cleanup = fun ~sw:_ _ _ -> () }
+ Build_layer.build ~sw env benv ~opam_repositories:[] node
+ ~strategy:
+ {
+ cmd = Printf.sprintf "opam install -y %s" (OpamPackage.to_string pkg);
+ cleanup = (fun ~sw:_ _ _ -> ());
+ }
()
in
- (match result with
- | Types.Success bl ->
- Printf.printf "SUCCESS: %s\n%!" bl.hash;
- let installed = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:(Day11_opam_layer.Build.dir ~os_dir:benv.os_dir bl) in
- Printf.printf "Installed: %d lib files\n%!" (List.length installed);
- Alcotest.(check bool) "has astring"
- true (List.exists (fun f ->
- Astring.String.is_prefix ~affix:"astring" f) installed)
- | Types.Failure name ->
- Alcotest.fail (Printf.sprintf "Build failed: %s" name)
- | _ ->
- Alcotest.fail "Unexpected build result")
+ match result with
+ | Types.Success bl ->
+ Printf.printf "SUCCESS: %s\n%!" bl.hash;
+ let installed =
+ Day11_opam_layer.Installed_files.scan_libs
+ ~layer_dir:(Day11_opam_layer.Build.dir ~os_dir:benv.os_dir bl)
+ in
+ Printf.printf "Installed: %d lib files\n%!" (List.length installed);
+ Alcotest.(check bool)
+ "has astring" true
+ (List.exists
+ (fun f -> Astring.String.is_prefix ~affix:"astring" f)
+ installed)
+ | Types.Failure name -> Alcotest.fail (Printf.sprintf "Build failed: %s" name)
+ | _ -> Alcotest.fail "Unexpected build result"
-let test_build_cached () = with_eio @@ fun ~sw env ->
+let test_build_cached () =
+ with_eio @@ fun ~sw env ->
let cache_dir = Fpath.v "/tmp/day11-build-cache" in
let os_dir = Fpath.(cache_dir / "linux-x86_64") in
- let base = Base.ensure ~sw env ~cache_dir ~image:base_image
- |> ok_or_fail "base" in
+ let base =
+ Base.ensure ~sw env ~cache_dir ~image:base_image |> ok_or_fail "base"
+ in
let benv : Types.build_env =
- { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None } in
+ { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None }
+ in
let pkg = OpamPackage.of_string "astring.0.8.5" in
- let layer_hash = Day11_layer.Hash.of_strings
- [ "build"; base.hash; "astring.0.8.5" ] in
+ let layer_hash =
+ Day11_layer.Hash.of_strings [ "build"; base.hash; "astring.0.8.5" ]
+ in
let node : Day11_opam_layer.Build.t =
- { hash = layer_hash; pkg; deps = []; universe = Day11_solution.Universe.dummy } in
+ {
+ hash = layer_hash;
+ pkg;
+ deps = [];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
let t0 = Unix.gettimeofday () in
let result =
- Build_layer.build ~sw env benv
- ~opam_repositories:[]
- node
- ~strategy:{ cmd = Printf.sprintf "opam install -y %s"
- (OpamPackage.to_string pkg);
- cleanup = fun ~sw:_ _ _ -> () }
+ Build_layer.build ~sw env benv ~opam_repositories:[] node
+ ~strategy:
+ {
+ cmd = Printf.sprintf "opam install -y %s" (OpamPackage.to_string pkg);
+ cleanup = (fun ~sw:_ _ _ -> ());
+ }
()
in
let elapsed = Unix.gettimeofday () -. t0 in
File "day11/opam_build/test/test_from_scratch.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/test/test_from_scratch.ml b/_build/default/day11/opam_build/test/.formatted/test_from_scratch.ml
index a8eb2a2..627bf72 100644
--- a/_build/default/day11/opam_build/test/test_from_scratch.ml
+++ b/_build/default/day11/opam_build/test/.formatted/test_from_scratch.ml
@@ -9,7 +9,9 @@ open Day11_test_util.Test_util
let os_distribution = "debian"
let os_version = "bookworm"
let arch = "x86_64"
-let test_from_scratch () = with_eio @@ fun ~sw env ->
+
+let test_from_scratch () =
+ with_eio @@ fun ~sw env ->
let opam_repository = opam_repository () in
let cache_dir = Fpath.v "/tmp/day11-scratch-cache" in
mkdir cache_dir;
@@ -17,55 +19,71 @@ let test_from_scratch () = with_eio @@ fun ~sw env ->
mkdir os_dir;
Printf.printf "Solving astring.0.8.5...\n%!";
let git_packages, _store, _commit =
- Day11_opam.Git_packages.of_opam_repository opam_repository in
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch ~os:"linux" ~os_distribution ~os_family:"debian"
- ~os_version:"12" () in
+ Day11_opam.Git_packages.of_opam_repository opam_repository
+ in
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch ~os:"linux" ~os_distribution
+ ~os_family:"debian" ~os_version:"12" ()
+ in
let solution =
- match Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
- (OpamPackage.of_string "astring.0.8.5") with
+ match
+ Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
+ (OpamPackage.of_string "astring.0.8.5")
+ with
| Ok result -> result
| Error (diag, _) -> Alcotest.fail ("Solve failed: " ^ diag)
in
- let pkgs = OpamPackage.Map.keys solution.Day11_solution.Solve_result.build_deps in
+ let pkgs =
+ OpamPackage.Map.keys solution.Day11_solution.Solve_result.build_deps
+ in
Printf.printf "Solved: %d packages\n%!" (List.length pkgs);
- Printf.printf "\nBuilding base image from %s:%s...\n%!"
- os_distribution os_version;
- let base = Base.build ~sw env ~cache_dir
- ~os_distribution ~os_version ~arch
- ~uid:1000 ~gid:1000 ()
- |> ok_or_fail "base build" in
+ Printf.printf "\nBuilding base image from %s:%s...\n%!" os_distribution
+ os_version;
+ let base =
+ Base.build ~sw env ~cache_dir ~os_distribution ~os_version ~arch ~uid:1000
+ ~gid:1000 ()
+ |> ok_or_fail "base build"
+ in
Printf.printf "Base: %s\n%!" (Fpath.to_string base.dir);
let find_opam = Day11_opam.Git_packages.find_package git_packages in
let cache = Hash_cache.create ~find_opam () in
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
let _final =
- List.fold_left (fun (deps : Day11_opam_layer.Build.t list) pkg ->
- let pkg_str = OpamPackage.to_string pkg in
- let all_pkgs = [ pkg ] in
- let layer_hash =
- Hash_cache.layer_hash cache ~base_hash:base.hash all_pkgs in
- let node : Day11_opam_layer.Build.t =
- { hash = layer_hash; pkg; deps; universe = Day11_solution.Universe.dummy } in
- Printf.printf "\n--- Building %s (layer: %s, deps: %d) ---\n%!"
- pkg_str (Day11_opam_layer.Build.dir_name node) (List.length deps);
- let result =
- Build_layer.build ~sw env benv
- ~opam_repositories:[]
- node ()
- in
- match result with
- | Types.Success bl ->
- Printf.printf "OK: %s → %s\n%!" pkg_str bl.hash;
- let installed = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:(Day11_opam_layer.Build.dir ~os_dir:benv.os_dir bl) in
- Printf.printf " Installed: %d lib files\n%!" (List.length installed);
- deps @ [ bl ]
- | Types.Failure name ->
- Alcotest.fail (Printf.sprintf "%s build failed: %s" pkg_str name)
- | _ ->
- Alcotest.fail (Printf.sprintf "%s unexpected" pkg_str)
- ) [] pkgs
+ List.fold_left
+ (fun (deps : Day11_opam_layer.Build.t list) pkg ->
+ let pkg_str = OpamPackage.to_string pkg in
+ let all_pkgs = [ pkg ] in
+ let layer_hash =
+ Hash_cache.layer_hash cache ~base_hash:base.hash all_pkgs
+ in
+ let node : Day11_opam_layer.Build.t =
+ {
+ hash = layer_hash;
+ pkg;
+ deps;
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ Printf.printf "\n--- Building %s (layer: %s, deps: %d) ---\n%!" pkg_str
+ (Day11_opam_layer.Build.dir_name node)
+ (List.length deps);
+ let result =
+ Build_layer.build ~sw env benv ~opam_repositories:[] node ()
+ in
+ match result with
+ | Types.Success bl ->
+ Printf.printf "OK: %s → %s\n%!" pkg_str bl.hash;
+ let installed =
+ Day11_opam_layer.Installed_files.scan_libs
+ ~layer_dir:(Day11_opam_layer.Build.dir ~os_dir:benv.os_dir bl)
+ in
+ Printf.printf " Installed: %d lib files\n%!"
+ (List.length installed);
+ deps @ [ bl ]
+ | Types.Failure name ->
+ Alcotest.fail (Printf.sprintf "%s build failed: %s" pkg_str name)
+ | _ -> Alcotest.fail (Printf.sprintf "%s unexpected" pkg_str))
+ [] pkgs
in
Printf.printf "\n=== All %d packages built successfully ===\n%!"
(List.length pkgs)
@@ -75,6 +93,10 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_from_scratch"
- [ ( "From_scratch",
- [ Alcotest.test_case "build astring from bare debian" `Slow
- test_from_scratch ] ) ]
+ [
+ ( "From_scratch",
+ [
+ Alcotest.test_case "build astring from bare debian" `Slow
+ test_from_scratch;
+ ] );
+ ]
File "day11/opam_build/test/test_layered_build.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/test/test_layered_build.ml b/_build/default/day11/opam_build/test/.formatted/test_layered_build.ml
index 38fc8b9..5cafe1e 100644
--- a/_build/default/day11/opam_build/test/test_layered_build.ml
+++ b/_build/default/day11/opam_build/test/.formatted/test_layered_build.ml
@@ -8,53 +8,67 @@ open Day11_test_util.Test_util
let base_image = "ocaml/opam:debian-ocaml-5.2"
-let packages = [
- "ocamlbuild.0.16.1";
- "ocamlfind.1.9.8";
- "topkg.1.1.1";
- "astring.0.8.5";
-]
+let packages =
+ [ "ocamlbuild.0.16.1"; "ocamlfind.1.9.8"; "topkg.1.1.1"; "astring.0.8.5" ]
-let test_layered_build () = with_eio @@ fun ~sw env ->
+let test_layered_build () =
+ with_eio @@ fun ~sw env ->
let cache_dir = Fpath.v "/tmp/day11-layered-cache" in
mkdir cache_dir;
let os_dir = Fpath.(cache_dir / "linux-x86_64") in
mkdir os_dir;
- let base = Base.ensure ~sw env ~cache_dir ~image:base_image
- |> ok_or_fail "base" in
+ let base =
+ Base.ensure ~sw env ~cache_dir ~image:base_image |> ok_or_fail "base"
+ in
Printf.printf "Base: %s\n%!" (Fpath.to_string base.dir);
let benv : Types.build_env =
- { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None } in
+ { base; os_dir; uid = 1000; gid = 1000; cpu_slots = None }
+ in
let _final =
- List.fold_left (fun (deps : Day11_opam_layer.Build.t list) pkg_str ->
- let pkg = OpamPackage.of_string pkg_str in
- let dep_hashes = List.map (fun (d : Day11_opam_layer.Build.t) -> d.hash) deps in
- let layer_hash = Day11_layer.Hash.of_strings
- ([ "build"; base.hash; pkg_str ] @ dep_hashes) in
- let node : Day11_opam_layer.Build.t =
- { hash = layer_hash; pkg; deps; universe = Day11_solution.Universe.dummy } in
- Printf.printf "\n--- Building %s (layer: %s, deps: %d) ---\n%!"
- pkg_str (Day11_opam_layer.Build.dir_name node) (List.length deps);
- let result =
- Build_layer.build ~sw env benv
- ~opam_repositories:[]
- node
- ~strategy:{ cmd = Printf.sprintf "opam install -y %s" pkg_str;
- cleanup = fun ~sw:_ _ _ -> () }
- ()
- in
- match result with
- | Types.Success bl ->
- Printf.printf "OK: %s → %s\n%!" pkg_str bl.hash;
- let installed = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:(Day11_opam_layer.Build.dir ~os_dir:benv.os_dir bl) in
- Printf.printf " Installed: %d lib files\n%!" (List.length installed);
- deps @ [ bl ]
- | Types.Failure name ->
- Alcotest.fail (Printf.sprintf "%s failed: %s" pkg_str name)
- | _ ->
- Alcotest.fail (Printf.sprintf "%s unexpected" pkg_str)
- ) [] packages
+ List.fold_left
+ (fun (deps : Day11_opam_layer.Build.t list) pkg_str ->
+ let pkg = OpamPackage.of_string pkg_str in
+ let dep_hashes =
+ List.map (fun (d : Day11_opam_layer.Build.t) -> d.hash) deps
+ in
+ let layer_hash =
+ Day11_layer.Hash.of_strings
+ ([ "build"; base.hash; pkg_str ] @ dep_hashes)
+ in
+ let node : Day11_opam_layer.Build.t =
+ {
+ hash = layer_hash;
+ pkg;
+ deps;
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ Printf.printf "\n--- Building %s (layer: %s, deps: %d) ---\n%!" pkg_str
+ (Day11_opam_layer.Build.dir_name node)
+ (List.length deps);
+ let result =
+ Build_layer.build ~sw env benv ~opam_repositories:[] node
+ ~strategy:
+ {
+ cmd = Printf.sprintf "opam install -y %s" pkg_str;
+ cleanup = (fun ~sw:_ _ _ -> ());
+ }
+ ()
+ in
+ match result with
+ | Types.Success bl ->
+ Printf.printf "OK: %s → %s\n%!" pkg_str bl.hash;
+ let installed =
+ Day11_opam_layer.Installed_files.scan_libs
+ ~layer_dir:(Day11_opam_layer.Build.dir ~os_dir:benv.os_dir bl)
+ in
+ Printf.printf " Installed: %d lib files\n%!"
+ (List.length installed);
+ deps @ [ bl ]
+ | Types.Failure name ->
+ Alcotest.fail (Printf.sprintf "%s failed: %s" pkg_str name)
+ | _ -> Alcotest.fail (Printf.sprintf "%s unexpected" pkg_str))
+ [] packages
in
Printf.printf "\n=== All %d packages built successfully ===\n%!"
(List.length packages)
@@ -64,6 +78,8 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_layered_build"
- [ ( "Layered",
- [ Alcotest.test_case "build astring deps" `Slow
- test_layered_build ] ) ]
+ [
+ ( "Layered",
+ [ Alcotest.test_case "build astring deps" `Slow test_layered_build ]
+ );
+ ]
File "day11/opam_build/test/test_tools.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/test/test_tools.ml b/_build/default/day11/opam_build/test/.formatted/test_tools.ml
index 3cbdb5f..7cfe93c 100644
--- a/_build/default/day11/opam_build/test/test_tools.ml
+++ b/_build/default/day11/opam_build/test/.formatted/test_tools.ml
@@ -9,45 +9,47 @@ open Day11_test_util.Test_util
let cache_dir = Fpath.v "/tmp/day11-scratch-cache"
let os_dir = Fpath.(cache_dir / "linux-x86_64")
+
let make_build_env () =
- match Base.load_cached ~cache_dir
- ~os_distribution:"debian" ~os_version:"bookworm" with
+ match
+ Base.load_cached ~cache_dir ~os_distribution:"debian" ~os_version:"bookworm"
+ with
| Some base -> Types.make_build_env ~base ~os_dir ()
| None -> Alcotest.skip ()
-let test_build_astring () = with_eio @@ fun ~sw env ->
+let test_build_astring () =
+ with_eio @@ fun ~sw env ->
let opam_repository = opam_repository () in
let benv = make_build_env () in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
let tool =
Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas
(OpamPackage.of_string "astring.0.8.5")
|> ok_or_fail "build_tool"
in
- Printf.printf "astring built: %d layers\n%!"
- (List.length tool.builds);
- Alcotest.(check bool) "has layers" true
- (List.length tool.builds > 0);
- let libs = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:tool.dir in
- Alcotest.(check bool) "has astring libs" true
- (List.exists (fun f ->
- Astring.String.is_prefix ~affix:"astring" f) libs)
+ Printf.printf "astring built: %d layers\n%!" (List.length tool.builds);
+ Alcotest.(check bool) "has layers" true (List.length tool.builds > 0);
+ let libs = Day11_opam_layer.Installed_files.scan_libs ~layer_dir:tool.dir in
+ Alcotest.(check bool)
+ "has astring libs" true
+ (List.exists (fun f -> Astring.String.is_prefix ~affix:"astring" f) libs)
-let test_build_odoc () = with_eio @@ fun ~sw env ->
+let test_build_odoc () =
+ with_eio @@ fun ~sw env ->
let opam_repository = opam_repository () in
let benv = make_build_env () in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
let odoc_versions =
Day11_opam.Git_packages.get_versions git_packages
- (OpamPackage.Name.of_string "odoc") in
- let odoc_pkg = match OpamPackage.Version.Map.max_binding_opt odoc_versions with
- | Some (v, _) ->
- OpamPackage.create (OpamPackage.Name.of_string "odoc") v
+ (OpamPackage.Name.of_string "odoc")
+ in
+ let odoc_pkg =
+ match OpamPackage.Version.Map.max_binding_opt odoc_versions with
+ | Some (v, _) -> OpamPackage.create (OpamPackage.Name.of_string "odoc") v
| None -> Alcotest.skip ()
in
Printf.printf "Building %s...\n%!" (OpamPackage.to_string odoc_pkg);
@@ -57,25 +59,36 @@ let test_build_odoc () = with_eio @@ fun ~sw env ->
|> ok_or_fail "build_tool"
in
Printf.printf "odoc built: %d layers\n%!" (List.length tool.builds);
- Alcotest.(check bool) "has layers" true
- (List.length tool.builds > 0);
- let odoc_bin = Fpath.(tool.dir / "fs" / "home" / "opam" / ".opam"
- / Types.switch / "bin" / "odoc") in
- Alcotest.(check bool) "odoc binary" true
+ Alcotest.(check bool) "has layers" true (List.length tool.builds > 0);
+ let odoc_bin =
+ Fpath.(
+ tool.dir
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / Types.switch
+ / "bin"
+ / "odoc")
+ in
+ Alcotest.(check bool)
+ "odoc binary" true
(Bos.OS.File.exists odoc_bin |> Result.get_ok)
-let test_build_odoc_pinned_compiler () = with_eio @@ fun ~sw env ->
+let test_build_odoc_pinned_compiler () =
+ with_eio @@ fun ~sw env ->
let opam_repository = opam_repository () in
let benv = make_build_env () in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
let odoc_versions =
Day11_opam.Git_packages.get_versions git_packages
- (OpamPackage.Name.of_string "odoc") in
- let odoc_pkg = match OpamPackage.Version.Map.max_binding_opt odoc_versions with
- | Some (v, _) ->
- OpamPackage.create (OpamPackage.Name.of_string "odoc") v
+ (OpamPackage.Name.of_string "odoc")
+ in
+ let odoc_pkg =
+ match OpamPackage.Version.Map.max_binding_opt odoc_versions with
+ | Some (v, _) -> OpamPackage.create (OpamPackage.Name.of_string "odoc") v
| None -> Alcotest.skip ()
in
let constraints = [ OpamPackage.of_string "ocaml-base-compiler.5.4.1" ] in
@@ -86,28 +99,29 @@ let test_build_odoc_pinned_compiler () = with_eio @@ fun ~sw env ->
~constraints odoc_pkg
|> ok_or_fail "build_tool"
in
- Printf.printf "odoc (pinned) built: %d layers\n%!"
- (List.length tool.builds);
- let compiler_layer = List.find_opt (fun (bl : Day11_opam_layer.Build.t) ->
- Astring.String.is_prefix ~affix:"ocaml-compiler"
- (OpamPackage.to_string bl.pkg)
- ) tool.builds in
- (match compiler_layer with
- | Some bl ->
- Printf.printf "Compiler: %s\n%!"
- (OpamPackage.to_string bl.pkg);
- Alcotest.(check bool) "uses 5.4.1"
- true (Astring.String.is_infix ~affix:"5.4.1"
- (OpamPackage.to_string bl.pkg))
- | None ->
- Printf.printf "No compiler layer found\n%!")
+ Printf.printf "odoc (pinned) built: %d layers\n%!" (List.length tool.builds);
+ let compiler_layer =
+ List.find_opt
+ (fun (bl : Day11_opam_layer.Build.t) ->
+ Astring.String.is_prefix ~affix:"ocaml-compiler"
+ (OpamPackage.to_string bl.pkg))
+ tool.builds
+ in
+ match compiler_layer with
+ | Some bl ->
+ Printf.printf "Compiler: %s\n%!" (OpamPackage.to_string bl.pkg);
+ Alcotest.(check bool)
+ "uses 5.4.1" true
+ (Astring.String.is_infix ~affix:"5.4.1" (OpamPackage.to_string bl.pkg))
+ | None -> Printf.printf "No compiler layer found\n%!"
-let test_solve_failure () = with_eio @@ fun ~sw env ->
+let test_solve_failure () =
+ with_eio @@ fun ~sw env ->
let opam_repository = opam_repository () in
let benv = make_build_env () in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
let result =
Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas
(OpamPackage.of_string "nonexistent-pkg.1.0")
@@ -119,10 +133,13 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_tools"
- [ ( "Tools",
- [ Alcotest.test_case "build astring" `Slow test_build_astring;
+ [
+ ( "Tools",
+ [
+ Alcotest.test_case "build astring" `Slow test_build_astring;
Alcotest.test_case "build odoc" `Slow test_build_odoc;
Alcotest.test_case "build odoc pinned 5.4.1" `Slow
test_build_odoc_pinned_compiler;
Alcotest.test_case "solve failure" `Quick test_solve_failure;
- ] ) ]
+ ] );
+ ]
File "day11/opam_build/test/test_tools_pinned.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/test/test_tools_pinned.ml b/_build/default/day11/opam_build/test/.formatted/test_tools_pinned.ml
index c0b71b8..d2ec8c8 100644
--- a/_build/default/day11/opam_build/test/test_tools_pinned.ml
+++ b/_build/default/day11/opam_build/test/.formatted/test_tools_pinned.ml
@@ -19,11 +19,12 @@ open Day11_opam_build
open Day11_test_util.Test_util
let cache_dir =
- Fpath.v (match Sys.getenv_opt "CACHE_DIR" with
+ Fpath.v
+ (match Sys.getenv_opt "CACHE_DIR" with
| Some d -> d
| None ->
- let home = Sys.getenv "HOME" in
- Filename.concat home "cache-day11-ox2")
+ let home = Sys.getenv "HOME" in
+ Filename.concat home "cache-day11-ox2")
let os_dir = Fpath.(cache_dir / "linux-x86_64")
@@ -31,134 +32,166 @@ let odoc_repo () =
match Sys.getenv_opt "ODOC_REPO" with
| Some path when Sys.file_exists path -> path
| _ ->
- let default = Filename.concat (Sys.getenv "HOME") "odoc" in
- if Sys.file_exists default then default
- else (Printf.printf "ODOC_REPO not set and ~/odoc doesn't exist\n%!";
- Alcotest.skip ())
+ let default = Filename.concat (Sys.getenv "HOME") "odoc" in
+ if Sys.file_exists default then default
+ else (
+ Printf.printf "ODOC_REPO not set and ~/odoc doesn't exist\n%!";
+ Alcotest.skip ())
let make_build_env () =
- match Base.load_cached ~cache_dir
- ~os_distribution:"debian" ~os_version:"bookworm" with
+ match
+ Base.load_cached ~cache_dir ~os_distribution:"debian" ~os_version:"bookworm"
+ with
| Some base -> Types.make_build_env ~base ~os_dir ()
| None ->
- Printf.printf "No cached base image at %s\n%!" (Fpath.to_string cache_dir);
- Alcotest.skip ()
+ Printf.printf "No cached base image at %s\n%!" (Fpath.to_string cache_dir);
+ Alcotest.skip ()
let read_pins dir =
- let opam_files = Sys.readdir dir |> Array.to_list
- |> List.filter (fun f -> Filename.check_suffix f ".opam") in
- List.fold_left (fun acc filename ->
- let name = Filename.chop_suffix filename ".opam" in
- let path = Filename.concat dir filename in
- try
- let opam = OpamFile.OPAM.read
- (OpamFile.make (OpamFilename.raw path)) in
- OpamPackage.Name.Map.add
- (OpamPackage.Name.of_string name)
- (OpamPackage.Version.of_string "dev", opam) acc
- with _ -> acc
- ) OpamPackage.Name.Map.empty opam_files
+ let opam_files =
+ Sys.readdir dir
+ |> Array.to_list
+ |> List.filter (fun f -> Filename.check_suffix f ".opam")
+ in
+ List.fold_left
+ (fun acc filename ->
+ let name = Filename.chop_suffix filename ".opam" in
+ let path = Filename.concat dir filename in
+ try
+ let opam = OpamFile.OPAM.read (OpamFile.make (OpamFilename.raw path)) in
+ OpamPackage.Name.Map.add
+ (OpamPackage.Name.of_string name)
+ (OpamPackage.Version.of_string "dev", opam)
+ acc
+ with _ -> acc)
+ OpamPackage.Name.Map.empty opam_files
(* Test 1: Build odoc-parser from local source *)
-let test_build_odoc_parser_from_source () = with_eio @@ fun ~sw env ->
+let test_build_odoc_parser_from_source () =
+ with_eio @@ fun ~sw env ->
let opam_repository = opam_repository () in
let odoc_dir = odoc_repo () in
let benv = make_build_env () in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
let pins = read_pins odoc_dir in
- let source_dirs = OpamPackage.Name.Map.fold (fun name _ acc ->
- OpamPackage.Name.Map.add name odoc_dir acc
- ) pins OpamPackage.Name.Map.empty in
+ let source_dirs =
+ OpamPackage.Name.Map.fold
+ (fun name _ acc -> OpamPackage.Name.Map.add name odoc_dir acc)
+ pins OpamPackage.Name.Map.empty
+ in
Printf.printf "Pins from %s: %s\n%!" odoc_dir
- (String.concat ", " (List.map OpamPackage.Name.to_string
- (OpamPackage.Name.Map.fold (fun n _ acc -> n :: acc) pins [])));
+ (String.concat ", "
+ (List.map OpamPackage.Name.to_string
+ (OpamPackage.Name.Map.fold (fun n _ acc -> n :: acc) pins [])));
let target = OpamPackage.of_string "odoc-parser.dev" in
- Printf.printf "Building %s from source...\n%!"
- (OpamPackage.to_string target);
+ Printf.printf "Building %s from source...\n%!" (OpamPackage.to_string target);
Printf.printf "Attempting build...\n%!";
- let result = Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas
- ~pin_dirs:[ odoc_dir ] ~source_dirs target in
- (match result with
- | Error (`Msg e) -> Printf.printf "Build error: %s\n%!" e
- | Ok _ -> Printf.printf "Build succeeded!\n%!");
- let tool = result |> ok_or_fail "build_tool odoc-parser.dev"
+ let result =
+ Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas
+ ~pin_dirs:[ odoc_dir ] ~source_dirs target
in
- Printf.printf "odoc-parser.dev built: %d layers\n%!"
- (List.length tool.builds);
+ (match result with
+ | Error (`Msg e) -> Printf.printf "Build error: %s\n%!" e
+ | Ok _ -> Printf.printf "Build succeeded!\n%!");
+ let tool = result |> ok_or_fail "build_tool odoc-parser.dev" in
+ Printf.printf "odoc-parser.dev built: %d layers\n%!" (List.length tool.builds);
(* Check that odoc-parser was actually installed *)
- let lib_dir = Fpath.(tool.dir / "fs" / "home" / "opam" / ".opam"
- / Types.switch / "lib" / "odoc-parser") in
+ let lib_dir =
+ Fpath.(
+ tool.dir
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / Types.switch
+ / "lib"
+ / "odoc-parser")
+ in
let has_lib = Bos.OS.Dir.exists lib_dir |> Result.get_ok in
- Printf.printf "odoc-parser lib dir exists: %b (%s)\n%!"
- has_lib (Fpath.to_string lib_dir);
+ Printf.printf "odoc-parser lib dir exists: %b (%s)\n%!" has_lib
+ (Fpath.to_string lib_dir);
Alcotest.(check bool) "odoc-parser installed" true has_lib
(* Test 2: Build odoc-driver from local source (full tool chain) *)
-let test_build_odoc_driver_from_source () = with_eio @@ fun ~sw env ->
+let test_build_odoc_driver_from_source () =
+ with_eio @@ fun ~sw env ->
let opam_repository = opam_repository () in
let odoc_dir = odoc_repo () in
let benv = make_build_env () in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
let pins = read_pins odoc_dir in
- let source_dirs = OpamPackage.Name.Map.fold (fun name _ acc ->
- OpamPackage.Name.Map.add name odoc_dir acc
- ) pins OpamPackage.Name.Map.empty in
+ let source_dirs =
+ OpamPackage.Name.Map.fold
+ (fun name _ acc -> OpamPackage.Name.Map.add name odoc_dir acc)
+ pins OpamPackage.Name.Map.empty
+ in
let target = OpamPackage.of_string "odoc-driver.dev" in
- Printf.printf "Building %s from source...\n%!"
- (OpamPackage.to_string target);
+ Printf.printf "Building %s from source...\n%!" (OpamPackage.to_string target);
let tool =
Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas
~pin_dirs:[ odoc_dir ] ~source_dirs target
|> ok_or_fail "build_tool odoc-driver.dev"
in
- Printf.printf "odoc-driver.dev built: %d layers\n%!"
- (List.length tool.builds);
+ Printf.printf "odoc-driver.dev built: %d layers\n%!" (List.length tool.builds);
(* Check that all doc binaries exist across built layers *)
let os_dir = Fpath.(cache_dir / "linux-x86_64") in
let find_binary name =
- List.exists (fun (bl : Day11_opam_layer.Build.t) ->
- let dir = Day11_opam_layer.Build.dir ~os_dir bl in
- let bin = Fpath.(dir / "fs" / "home" / "opam" / ".opam"
- / Types.switch / "bin" / name) in
- Bos.OS.File.exists bin |> Result.get_ok
- ) tool.builds
+ List.exists
+ (fun (bl : Day11_opam_layer.Build.t) ->
+ let dir = Day11_opam_layer.Build.dir ~os_dir bl in
+ let bin =
+ Fpath.(
+ dir / "fs" / "home" / "opam" / ".opam" / Types.switch / "bin" / name)
+ in
+ Bos.OS.File.exists bin |> Result.get_ok)
+ tool.builds
in
let required_binaries = [ "odoc"; "odoc-md"; "sherlodoc"; "odoc_driver" ] in
- List.iter (fun name ->
- let found = find_binary name in
- Printf.printf " %s: %b\n%!" name found;
- Alcotest.(check bool) (name ^ " binary") true found
- ) required_binaries;
+ List.iter
+ (fun name ->
+ let found = find_binary name in
+ Printf.printf " %s: %b\n%!" name found;
+ Alcotest.(check bool) (name ^ " binary") true found)
+ required_binaries;
(* Also check that pinned packages were built from source *)
- let pinned_pkgs = [ "odoc"; "odoc-parser"; "odoc-md"; "sherlodoc";
- "odoc-driver" ] in
- List.iter (fun name ->
- let found = List.exists (fun (bl : Day11_opam_layer.Build.t) ->
- let pkg_name = OpamPackage.Name.to_string (OpamPackage.name bl.pkg) in
- pkg_name = name
- ) tool.builds in
- Printf.printf " %s built: %b\n%!" name found;
- Alcotest.(check bool) (name ^ " built") true found
- ) pinned_pkgs
+ let pinned_pkgs =
+ [ "odoc"; "odoc-parser"; "odoc-md"; "sherlodoc"; "odoc-driver" ]
+ in
+ List.iter
+ (fun name ->
+ let found =
+ List.exists
+ (fun (bl : Day11_opam_layer.Build.t) ->
+ let pkg_name =
+ OpamPackage.Name.to_string (OpamPackage.name bl.pkg)
+ in
+ pkg_name = name)
+ tool.builds
+ in
+ Printf.printf " %s built: %b\n%!" name found;
+ Alcotest.(check bool) (name ^ " built") true found)
+ pinned_pkgs
(* Test 3: Build using multiple repos with overlay *)
-let test_build_with_multi_repo () = with_eio @@ fun ~sw env ->
+let test_build_with_multi_repo () =
+ with_eio @@ fun ~sw env ->
let opam_repository = opam_repository () in
let benv = make_build_env () in
(* Load from a single repo *)
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories
- [ (opam_repository, None) ] in
+ Day11_opam.Git_packages.of_repositories [ (opam_repository, None) ]
+ in
(* Build astring as a sanity check *)
let target = OpamPackage.of_string "astring.0.8.5" in
Printf.printf "Building %s via of_repositories...\n%!"
(OpamPackage.to_string target);
let tool =
- Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas target
+ Tools.build_tool ~sw env benv ~packages:git_packages ~repos:repos_with_shas
+ target
|> ok_or_fail "build_tool astring"
in
Printf.printf "astring built: %d layers\n%!" (List.length tool.builds);
@@ -170,14 +203,17 @@ let () =
Printf.printf "Skipping (set DAY11_INTEGRATION=true to run)\n"
else
Alcotest.run "day11_tools_pinned"
- [ ( "Pinned source",
- [ Alcotest.test_case "odoc-parser from source" `Slow
+ [
+ ( "Pinned source",
+ [
+ Alcotest.test_case "odoc-parser from source" `Slow
test_build_odoc_parser_from_source;
Alcotest.test_case "odoc-driver from source" `Slow
test_build_odoc_driver_from_source;
] );
( "Multi-repo",
- [ Alcotest.test_case "build with of_repositories" `Slow
+ [
+ Alcotest.test_case "build with of_repositories" `Slow
test_build_with_multi_repo;
] );
]
File "day11/batch/blessing.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/blessing.ml b/_build/default/day11/batch/.formatted/blessing.ml
index 4020ccb..a6e78b9 100644
--- a/_build/default/day11/batch/blessing.ml
+++ b/_build/default/day11/batch/.formatted/blessing.ml
@@ -9,65 +9,84 @@
let universe_hash_of_deps = Day11_solution.Universe.of_deps
-let compute_blessings
- (solutions : (OpamPackage.t * Day11_solution.Deps.t) list) =
+let compute_blessings (solutions : (OpamPackage.t * Day11_solution.Deps.t) list)
+ =
(* Expand direct deps → transitive deps for each solution *)
let solutions =
- List.map (fun (target, sol) ->
- (target, Day11_solution.Deps.transitive_deps sol)
- ) solutions
+ List.map
+ (fun (target, sol) -> (target, Day11_solution.Deps.transitive_deps sol))
+ solutions
in
(* Step 1: Compute revdeps counts across all solutions *)
let revdeps_counts : (OpamPackage.t, int) Hashtbl.t = Hashtbl.create 256 in
- List.iter (fun (_target, trans_deps) ->
- OpamPackage.Map.iter (fun _pkg deps ->
- OpamPackage.Set.iter (fun dep ->
- let c = try Hashtbl.find revdeps_counts dep with Not_found -> 0 in
- Hashtbl.replace revdeps_counts dep (c + 1)
- ) deps
- ) trans_deps
- ) solutions;
+ List.iter
+ (fun (_target, trans_deps) ->
+ OpamPackage.Map.iter
+ (fun _pkg deps ->
+ OpamPackage.Set.iter
+ (fun dep ->
+ let c =
+ try Hashtbl.find revdeps_counts dep with Not_found -> 0
+ in
+ Hashtbl.replace revdeps_counts dep (c + 1))
+ deps)
+ trans_deps)
+ solutions;
(* Step 2: For each package, collect distinct universes with metrics *)
(* Entries: (uhash, deps_count, revdeps_count, compiler_version) *)
- let compiler_names = List.map OpamPackage.Name.of_string
- [ "ocaml-base-compiler"; "ocaml-variants"; "ocaml-system" ] in
+ let compiler_names =
+ List.map OpamPackage.Name.of_string
+ [ "ocaml-base-compiler"; "ocaml-variants"; "ocaml-system" ]
+ in
let find_compiler_version solution =
- OpamPackage.Map.fold (fun pkg _deps acc ->
- match acc with
- | Some _ -> acc
- | None ->
- if List.exists (OpamPackage.Name.equal (OpamPackage.name pkg))
- compiler_names
- then Some (OpamPackage.version pkg)
- else None
- ) solution None
+ OpamPackage.Map.fold
+ (fun pkg _deps acc ->
+ match acc with
+ | Some _ -> acc
+ | None ->
+ if
+ List.exists
+ (OpamPackage.Name.equal (OpamPackage.name pkg))
+ compiler_names
+ then Some (OpamPackage.version pkg)
+ else None)
+ solution None
in
let pkg_universes :
- (OpamPackage.t, (Day11_solution.Universe.t * int * int * OpamPackage.Version.t option) list)
- Hashtbl.t = Hashtbl.create 256
+ ( OpamPackage.t,
+ (Day11_solution.Universe.t * int * int * OpamPackage.Version.t option)
+ list )
+ Hashtbl.t =
+ Hashtbl.create 256
in
- List.iter (fun (_target, trans_deps) ->
- let compiler_v = find_compiler_version trans_deps in
- OpamPackage.Map.iter (fun pkg deps ->
- let uhash = universe_hash_of_deps deps in
- let deps_count = OpamPackage.Set.cardinal deps in
- let revdeps_count =
- try Hashtbl.find revdeps_counts pkg with Not_found -> 0
- in
- let existing =
- try Hashtbl.find pkg_universes pkg with Not_found -> []
- in
- if not (List.exists (fun (h, _, _, _) -> Day11_solution.Universe.equal h uhash) existing)
- then
- Hashtbl.replace pkg_universes pkg
- ((uhash, deps_count, revdeps_count, compiler_v) :: existing)
- ) trans_deps
- ) solutions;
+ List.iter
+ (fun (_target, trans_deps) ->
+ let compiler_v = find_compiler_version trans_deps in
+ OpamPackage.Map.iter
+ (fun pkg deps ->
+ let uhash = universe_hash_of_deps deps in
+ let deps_count = OpamPackage.Set.cardinal deps in
+ let revdeps_count =
+ try Hashtbl.find revdeps_counts pkg with Not_found -> 0
+ in
+ let existing =
+ try Hashtbl.find pkg_universes pkg with Not_found -> []
+ in
+ if
+ not
+ (List.exists
+ (fun (h, _, _, _) -> Day11_solution.Universe.equal h uhash)
+ existing)
+ then
+ Hashtbl.replace pkg_universes pkg
+ ((uhash, deps_count, revdeps_count, compiler_v) :: existing))
+ trans_deps)
+ solutions;
(* Step 3: For each package, pick the best universe.
Heuristic: maximize deps_count, then revdeps_count, then
compiler version (prefer newer). *)
let compare_version a b =
- match a, b with
+ match (a, b) with
| Some va, Some vb -> OpamPackage.Version.compare va vb
| Some _, None -> 1
| None, Some _ -> -1
@@ -76,55 +95,58 @@ let compute_blessings
let blessed_universe : (OpamPackage.t, Day11_solution.Universe.t) Hashtbl.t =
Hashtbl.create 256
in
- Hashtbl.iter (fun pkg entries ->
- let best_hash, _, _, _ =
- List.fold_left
- (fun ((_, bdc, brc, bv) as best) ((_, dc, rc, v) as entry) ->
- if dc > bdc then entry
- else if dc = bdc && rc > brc then entry
- else if dc = bdc && rc = brc && compare_version v bv > 0 then entry
- else best)
- (List.hd entries) (List.tl entries)
- in
- Hashtbl.replace blessed_universe pkg best_hash
- ) pkg_universes;
+ Hashtbl.iter
+ (fun pkg entries ->
+ let best_hash, _, _, _ =
+ List.fold_left
+ (fun ((_, bdc, brc, bv) as best) ((_, dc, rc, v) as entry) ->
+ if dc > bdc then entry
+ else if dc = bdc && rc > brc then entry
+ else if dc = bdc && rc = brc && compare_version v bv > 0 then entry
+ else best)
+ (List.hd entries) (List.tl entries)
+ in
+ Hashtbl.replace blessed_universe pkg best_hash)
+ pkg_universes;
(* Step 4: Generate per-target blessing maps *)
- List.map (fun (target, trans_deps) ->
- let map =
- OpamPackage.Map.mapi (fun pkg deps ->
- let uhash = universe_hash_of_deps deps in
- let blessed_uhash = Hashtbl.find blessed_universe pkg in
- Day11_solution.Universe.equal uhash blessed_uhash
- ) trans_deps
- in
- (target, map)
- ) solutions
+ List.map
+ (fun (target, trans_deps) ->
+ let map =
+ OpamPackage.Map.mapi
+ (fun pkg deps ->
+ let uhash = universe_hash_of_deps deps in
+ let blessed_uhash = Hashtbl.find blessed_universe pkg in
+ Day11_solution.Universe.equal uhash blessed_uhash)
+ trans_deps
+ in
+ (target, map))
+ solutions
let is_blessed map pkg =
- match OpamPackage.Map.find_opt pkg map with
- | Some b -> b
- | None -> false
+ match OpamPackage.Map.find_opt pkg map with Some b -> b | None -> false
let compute_blessed_universes
(solutions : (OpamPackage.t * Day11_solution.Deps.t) list) =
(* Reuse compute_blessings logic — extract blessed universe per package *)
let blessings = compute_blessings solutions in
let trans_solutions =
- List.map (fun (target, sol) ->
- (target, Day11_solution.Deps.transitive_deps sol)
- ) solutions
+ List.map
+ (fun (target, sol) -> (target, Day11_solution.Deps.transitive_deps sol))
+ solutions
in
let blessed : (OpamPackage.t, Day11_solution.Universe.t) Hashtbl.t =
Hashtbl.create 256
in
- List.iter (fun (target, map) ->
- let trans_deps = List.assoc target trans_solutions in
- OpamPackage.Map.iter (fun pkg is_blessed ->
- if is_blessed && not (Hashtbl.mem blessed pkg) then
- match OpamPackage.Map.find_opt pkg trans_deps with
- | Some deps ->
- Hashtbl.replace blessed pkg (universe_hash_of_deps deps)
- | None -> ()
- ) map
- ) blessings;
+ List.iter
+ (fun (target, map) ->
+ let trans_deps = List.assoc target trans_solutions in
+ OpamPackage.Map.iter
+ (fun pkg is_blessed ->
+ if is_blessed && not (Hashtbl.mem blessed pkg) then
+ match OpamPackage.Map.find_opt pkg trans_deps with
+ | Some deps ->
+ Hashtbl.replace blessed pkg (universe_hash_of_deps deps)
+ | None -> ())
+ map)
+ blessings;
blessed
File "day11/batch/blessing.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/blessing.mli b/_build/default/day11/batch/.formatted/blessing.mli
index 0863f78..dab49d8 100644
--- a/_build/default/day11/batch/blessing.mli
+++ b/_build/default/day11/batch/.formatted/blessing.mli
@@ -1,21 +1,21 @@
(** Blessing — select canonical documentation per package.
- When the same package appears in multiple solutions (different
- universes), the blessing system picks the "best" universe for
- each package's canonical documentation. *)
+ When the same package appears in multiple solutions (different universes),
+ the blessing system picks the "best" universe for each package's canonical
+ documentation. *)
val compute_blessings :
(OpamPackage.t * Day11_solution.Deps.t) list ->
(OpamPackage.t * bool OpamPackage.Map.t) list
-(** [compute_blessings solutions] returns per-target blessing maps.
- Heuristic: maximize deps_count (richer docs), then revdeps_count
- (stability). A package in only one universe is always blessed. *)
+(** [compute_blessings solutions] returns per-target blessing maps. Heuristic:
+ maximize deps_count (richer docs), then revdeps_count (stability). A package
+ in only one universe is always blessed. *)
val compute_blessed_universes :
(OpamPackage.t * Day11_solution.Deps.t) list ->
(OpamPackage.t, Day11_solution.Universe.t) Hashtbl.t
-(** [compute_blessed_universes solutions] returns a map from package
- to the universe of its blessed universe. *)
+(** [compute_blessed_universes solutions] returns a map from package to the
+ universe of its blessed universe. *)
val universe_hash_of_deps : OpamPackage.Set.t -> Day11_solution.Universe.t
(** Compute a universe identifier from a dependency set. *)
File "day11/batch/incremental_solver.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/incremental_solver.ml b/_build/default/day11/batch/.formatted/incremental_solver.ml
index 2051073..75ea2ea 100644
--- a/_build/default/day11/batch/incremental_solver.ml
+++ b/_build/default/day11/batch/.formatted/incremental_solver.ml
@@ -20,19 +20,22 @@ let cache_key_of = function
| Cached_failure f -> f.cache_key
let is_cache_key_valid ~expected entry =
- match expected, cache_key_of entry with
+ match (expected, cache_key_of entry) with
| None, _ -> true
- | Some _, None -> true (* legacy entry, accept *)
+ | Some _, None -> true (* legacy entry, accept *)
| Some e, Some k -> e = k
let examined_to_json examined =
- `List (OpamPackage.Name.Set.fold (fun n acc ->
- `String (OpamPackage.Name.to_string n) :: acc
- ) examined [])
+ `List
+ (OpamPackage.Name.Set.fold
+ (fun n acc -> `String (OpamPackage.Name.to_string n) :: acc)
+ examined [])
let examined_of_json json =
let open Yojson.Safe.Util in
- json |> to_list |> List.map to_string
+ json
+ |> to_list
+ |> List.map to_string
|> List.map OpamPackage.Name.of_string
|> OpamPackage.Name.Set.of_list
@@ -40,23 +43,31 @@ let examined_of_json json =
that still parse it from the body. The [cache_key] field is
optional — only emitted when caller set it. *)
let save path entry =
- let with_key fields cache_key = match cache_key with
+ let with_key fields cache_key =
+ match cache_key with
| Some k -> ("cache_key", `String k) :: fields
| None -> fields
in
- let json = match entry with
+ let json =
+ match entry with
| Cached_solution { package; result; cache_key } ->
- `Assoc (with_key [
- ("package", `String (OpamPackage.to_string package));
- ("result", Day11_solution.Solve_result.to_json result);
- ] cache_key)
+ `Assoc
+ (with_key
+ [
+ ("package", `String (OpamPackage.to_string package));
+ ("result", Day11_solution.Solve_result.to_json result);
+ ]
+ cache_key)
| Cached_failure { package; error; examined; cache_key } ->
- `Assoc (with_key [
- ("failed", `Bool true);
- ("package", `String (OpamPackage.to_string package));
- ("error", `String error);
- ("examined", examined_to_json examined);
- ] cache_key)
+ `Assoc
+ (with_key
+ [
+ ("failed", `Bool true);
+ ("package", `String (OpamPackage.to_string package));
+ ("error", `String error);
+ ("examined", examined_to_json examined);
+ ]
+ cache_key)
in
let data = Yojson.Safe.to_string json in
Bos.OS.File.write path data
@@ -68,8 +79,8 @@ let save path entry =
let package_from_filename file_path =
let basename = Fpath.basename file_path in
let stem =
- if Filename.check_suffix basename ".json"
- then Filename.chop_suffix basename ".json"
+ if Filename.check_suffix basename ".json" then
+ Filename.chop_suffix basename ".json"
else basename
in
OpamPackage.of_string stem
@@ -77,81 +88,85 @@ let package_from_filename file_path =
let load file_path =
match Bos.OS.File.read file_path with
| Error _ as e -> e
- | Ok data ->
- try
- let json = Yojson.Safe.from_string data in
- let open Yojson.Safe.Util in
- let package =
- match json |> member "package" |> to_string_option with
- | Some s -> OpamPackage.of_string s
- | None -> package_from_filename file_path
- in
- let cache_key = json |> member "cache_key" |> to_string_option in
- match json |> member "failed" |> to_bool_option with
- | Some true ->
- let error = json |> member "error" |> to_string in
- let examined = json |> member "examined" |> examined_of_json in
- Ok (Cached_failure { package; error; examined; cache_key })
- | _ ->
- match Day11_solution.Solve_result.of_json (json |> member "result") with
- | Ok result ->
- Ok (Cached_solution { package; result; cache_key })
- | Error _ as e -> e
- with exn ->
- Error (`Msg (Printexc.to_string exn))
+ | Ok data -> (
+ try
+ let json = Yojson.Safe.from_string data in
+ let open Yojson.Safe.Util in
+ let package =
+ match json |> member "package" |> to_string_option with
+ | Some s -> OpamPackage.of_string s
+ | None -> package_from_filename file_path
+ in
+ let cache_key = json |> member "cache_key" |> to_string_option in
+ match json |> member "failed" |> to_bool_option with
+ | Some true ->
+ let error = json |> member "error" |> to_string in
+ let examined = json |> member "examined" |> examined_of_json in
+ Ok (Cached_failure { package; error; examined; cache_key })
+ | _ -> (
+ match
+ Day11_solution.Solve_result.of_json (json |> member "result")
+ with
+ | Ok result -> Ok (Cached_solution { package; result; cache_key })
+ | Error _ as e -> e)
+ with exn -> Error (`Msg (Printexc.to_string exn)))
-let reuse_solutions ~solutions_cache_dir ~previous_dir
- ~changed_packages ~packages =
+let reuse_solutions ~solutions_cache_dir ~previous_dir ~changed_packages
+ ~packages =
let reused = ref 0 in
- List.iter (fun pkg_name ->
- let cache_file = Fpath.(solutions_cache_dir / (pkg_name ^ ".json")) in
- if not (Sys.file_exists (Fpath.to_string cache_file)) then begin
- let prev_file = Fpath.(previous_dir / (pkg_name ^ ".json")) in
- if Sys.file_exists (Fpath.to_string prev_file) then
- match load prev_file with
- | Error _ -> ()
- | Ok entry ->
- let examined = match entry with
- | Cached_solution s -> s.result.examined
- | Cached_failure f -> f.examined
- in
- if OpamPackage.Name.Set.is_empty
- (OpamPackage.Name.Set.inter examined changed_packages)
- then begin
- (try
- Unix.link (Fpath.to_string prev_file)
- (Fpath.to_string cache_file);
- incr reused
- with Unix.Unix_error _ ->
- match Bos.OS.File.read prev_file with
- | Ok data ->
- (match Bos.OS.File.write cache_file data with
- | Ok () -> incr reused
- | Error _ -> ())
- | Error _ -> ())
- end
- end
- ) packages;
+ List.iter
+ (fun pkg_name ->
+ let cache_file = Fpath.(solutions_cache_dir / (pkg_name ^ ".json")) in
+ if not (Sys.file_exists (Fpath.to_string cache_file)) then
+ let prev_file = Fpath.(previous_dir / (pkg_name ^ ".json")) in
+ if Sys.file_exists (Fpath.to_string prev_file) then
+ match load prev_file with
+ | Error _ -> ()
+ | Ok entry -> (
+ let examined =
+ match entry with
+ | Cached_solution s -> s.result.examined
+ | Cached_failure f -> f.examined
+ in
+ if
+ OpamPackage.Name.Set.is_empty
+ (OpamPackage.Name.Set.inter examined changed_packages)
+ then
+ try
+ Unix.link
+ (Fpath.to_string prev_file)
+ (Fpath.to_string cache_file);
+ incr reused
+ with Unix.Unix_error _ -> (
+ match Bos.OS.File.read prev_file with
+ | Ok data -> (
+ match Bos.OS.File.write cache_file data with
+ | Ok () -> incr reused
+ | Error _ -> ())
+ | Error _ -> ())))
+ packages;
!reused
let find_previous_sha_dir base ~current_sha =
match Bos.OS.Dir.contents base with
| Error _ -> None
- | Ok entries ->
- let dirs =
- List.filter_map (fun p ->
- let name = Fpath.basename p in
- if name = current_sha then None
- else match Bos.OS.Dir.exists p with
- | Ok true ->
- let mtime =
- try (Unix.stat (Fpath.to_string p)).Unix.st_mtime
- with _ -> 0.0
- in
- Some (p, mtime)
- | _ -> None
- ) entries
- in
- match List.sort (fun (_, a) (_, b) -> compare b a) dirs with
- | (p, _) :: _ -> Some p
- | [] -> None
+ | Ok entries -> (
+ let dirs =
+ List.filter_map
+ (fun p ->
+ let name = Fpath.basename p in
+ if name = current_sha then None
+ else
+ match Bos.OS.Dir.exists p with
+ | Ok true ->
+ let mtime =
+ try (Unix.stat (Fpath.to_string p)).Unix.st_mtime
+ with _ -> 0.0
+ in
+ Some (p, mtime)
+ | _ -> None)
+ entries
+ in
+ match List.sort (fun (_, a) (_, b) -> compare b a) dirs with
+ | (p, _) :: _ -> Some p
+ | [] -> None)
File "day11/batch/incremental_solver.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/incremental_solver.mli b/_build/default/day11/batch/.formatted/incremental_solver.mli
index f8be2b9..459799a 100644
--- a/_build/default/day11/batch/incremental_solver.mli
+++ b/_build/default/day11/batch/.formatted/incremental_solver.mli
@@ -1,32 +1,31 @@
(** Incremental solver — solution caching and reuse.
- Caches solver results keyed by opam-repo SHA. When the repo
- advances, reuses solutions whose examined package set has no
- overlap with the set of changed packages.
+ Caches solver results keyed by opam-repo SHA. When the repo advances, reuses
+ solutions whose examined package set has no overlap with the set of changed
+ packages.
{1 On-disk format}
Each cache entry is a single JSON file at
- [<solutions_dir>/<pkg>.<ver>.json]. The package name+version is
- encoded in the filename, not (or not only) in the JSON body —
- this keeps the body symmetric with the [cache_key] envelope used
- by upstream consumers like ocaml-docs-ci, which write files
- without a [package] field.
+ [<solutions_dir>/<pkg>.<ver>.json]. The package name+version is encoded in
+ the filename, not (or not only) in the JSON body — this keeps the body
+ symmetric with the [cache_key] envelope used by upstream consumers like
+ ocaml-docs-ci, which write files without a [package] field.
- The optional [cache_key] field carries an opaque cache-validity
- fingerprint. day11 CLI never sets it; ocaml-docs-ci sets it to
- [hash(compiler ∥ commit ∥ repos_digest)] so a repo or compiler
- bump invalidates only the affected entries. {!is_cache_key_valid}
- is the validity check — entries without a [cache_key] are always
- considered valid (legacy/CLI behaviour). *)
+ The optional [cache_key] field carries an opaque cache-validity fingerprint.
+ day11 CLI never sets it; ocaml-docs-ci sets it to
+ [hash(compiler ∥ commit ∥ repos_digest)] so a repo or compiler bump
+ invalidates only the affected entries. {!is_cache_key_valid} is the validity
+ check — entries without a [cache_key] are always considered valid
+ (legacy/CLI behaviour). *)
type cached_solution = {
package : OpamPackage.t;
result : Day11_solution.Solve_result.t;
cache_key : string option;
}
-(** A solved result. The examined set used for reusability checks
- lives inside {!Day11_solution.Solve_result.t}. *)
+(** A solved result. The examined set used for reusability checks lives inside
+ {!Day11_solution.Solve_result.t}. *)
type cached_failure = {
package : OpamPackage.t;
@@ -42,21 +41,20 @@ type cache_entry =
val cache_key_of : cache_entry -> string option
(** Project the [cache_key] field from either constructor. *)
-val is_cache_key_valid :
- expected:string option -> cache_entry -> bool
-(** [is_cache_key_valid ~expected entry] returns [true] when
- [expected] is [None] (caller doesn't care), or when the entry has
- no [cache_key] (legacy entry, always accepted), or when the
- entry's [cache_key] equals [expected]. *)
+val is_cache_key_valid : expected:string option -> cache_entry -> bool
+(** [is_cache_key_valid ~expected entry] returns [true] when [expected] is
+ [None] (caller doesn't care), or when the entry has no [cache_key] (legacy
+ entry, always accepted), or when the entry's [cache_key] equals [expected].
+*)
val save : Fpath.t -> cache_entry -> (unit, [> Rresult.R.msg ]) result
-(** [save path entry] writes a cache entry (solution or failure) to
- a JSON file. Embeds the entry's [cache_key] when set. *)
+(** [save path entry] writes a cache entry (solution or failure) to a JSON file.
+ Embeds the entry's [cache_key] when set. *)
val load : Fpath.t -> (cache_entry, [> Rresult.R.msg ]) result
-(** [load path] reads a cache entry from a JSON file. The package is
- taken from the JSON body if present; otherwise the file's
- basename (minus [.json]) is parsed as [name.version]. *)
+(** [load path] reads a cache entry from a JSON file. The package is taken from
+ the JSON body if present; otherwise the file's basename (minus [.json]) is
+ parsed as [name.version]. *)
val reuse_solutions :
solutions_cache_dir:Fpath.t ->
@@ -64,13 +62,11 @@ val reuse_solutions :
changed_packages:OpamPackage.Name.Set.t ->
packages:string list ->
int
-(** [reuse_solutions ~solutions_cache_dir ~previous_dir
- ~changed_packages ~packages] hardlinks reusable solutions from
- [previous_dir] into [solutions_cache_dir]. A solution is reusable
- when its examined set does not intersect [changed_packages].
- Returns the number of solutions reused. *)
+(** [reuse_solutions ~solutions_cache_dir ~previous_dir ~changed_packages
+ ~packages] hardlinks reusable solutions from [previous_dir] into
+ [solutions_cache_dir]. A solution is reusable when its examined set does not
+ intersect [changed_packages]. Returns the number of solutions reused. *)
-val find_previous_sha_dir :
- Fpath.t -> current_sha:string -> Fpath.t option
-(** [find_previous_sha_dir base ~current_sha] finds the most recently
- modified SHA directory under [base] that is not [current_sha]. *)
+val find_previous_sha_dir : Fpath.t -> current_sha:string -> Fpath.t option
+(** [find_previous_sha_dir base ~current_sha] finds the most recently modified
+ SHA directory under [base] that is not [current_sha]. *)
File "day11/batch/live_view.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/live_view.ml b/_build/default/day11/batch/.formatted/live_view.ml
index 55aed04..04b5d6e 100644
--- a/_build/default/day11/batch/live_view.ml
+++ b/_build/default/day11/batch/.formatted/live_view.ml
@@ -1,8 +1,4 @@
-type counts = {
- ok : int;
- fail : int;
- cascade : int;
-}
+type counts = { ok : int; fail : int; cascade : int }
type progress = {
completed : int;
@@ -31,142 +27,157 @@ let latest_run ~snapshot_dir =
let runs_dir = Fpath.(snapshot_dir / "runs") in
match Bos.OS.Dir.contents runs_dir with
| Error _ -> None
- | Ok entries ->
- entries
- |> List.filter (fun p -> Bos.OS.Dir.exists p |> Result.value ~default:false)
- |> List.filter (fun p ->
- Sys.file_exists (Fpath.to_string Fpath.(p / "build.jsonl")))
- |> List.sort (fun a b -> compare (Fpath.to_string b) (Fpath.to_string a))
- |> function [] -> None | d :: _ -> Some d
+ | Ok entries -> (
+ entries
+ |> List.filter (fun p ->
+ Bos.OS.Dir.exists p |> Result.value ~default:false)
+ |> List.filter (fun p ->
+ Sys.file_exists (Fpath.to_string Fpath.(p / "build.jsonl")))
+ |> List.sort (fun a b -> compare (Fpath.to_string b) (Fpath.to_string a))
+ |> function
+ | [] -> None
+ | d :: _ -> Some d)
let read_jsonl path =
let lines = ref [] in
let ic = open_in (Fpath.to_string path) in
- Fun.protect ~finally:(fun () -> close_in ic) (fun () ->
- try
- while true do
- let line = input_line ic in
- if String.length line > 0 then
- try lines := Yojson.Safe.from_string line :: !lines
- with _ -> ()
- done
- with End_of_file -> ());
+ Fun.protect
+ ~finally:(fun () -> close_in ic)
+ (fun () ->
+ try
+ while true do
+ let line = input_line ic in
+ if String.length line > 0 then
+ try lines := Yojson.Safe.from_string line :: !lines with _ -> ()
+ done
+ with End_of_file -> ());
List.rev !lines
let read_json_opt path =
try
- let data = In_channel.with_open_text (Fpath.to_string path)
- In_channel.input_all in
+ let data =
+ In_channel.with_open_text (Fpath.to_string path) In_channel.input_all
+ in
Some (Yojson.Safe.from_string data)
with _ -> None
let kind_totals_of_doc_dag json =
let open Yojson.Safe.Util in
- let i name =
- match json |> member name with `Int n -> n | _ -> 0 in
+ let i name = match json |> member name with `Int n -> n | _ -> 0 in
[
- ("build", i "build_nodes");
- ("tool", i "tool_nodes");
+ ("build", i "build_nodes");
+ ("tool", i "tool_nodes");
("compile", i "compile_nodes");
("doc-all", i "doc_all_nodes");
- ("link", i "link_nodes");
+ ("link", i "link_nodes");
]
let load_latest ~snapshot_dir =
match latest_run ~snapshot_dir with
| None -> None
| Some run_dir ->
- let jsonl = Fpath.(run_dir / "build.jsonl") in
- if not (Sys.file_exists (Fpath.to_string jsonl)) then None
- else
- let pkg_status : (string, string) Hashtbl.t = Hashtbl.create 256 in
- let failed_dep : (string, string) Hashtbl.t = Hashtbl.create 32 in
- let by_kind : (string, int) Hashtbl.t = Hashtbl.create 8 in
- let seen_hashes : (string, unit) Hashtbl.t = Hashtbl.create 256 in
- let counts = ref { ok = 0; fail = 0; cascade = 0 } in
- let completed = ref 0 in
- List.iter (fun json ->
- let open Yojson.Safe.Util in
- let pkg = json |> member "pkg" |> to_string in
- let status = json |> member "status" |> to_string in
- let kind = match json |> member "kind" with
- | `String s -> s
- | _ -> "build" in
- let hash = match json |> member "hash" with
- | `String s -> s
- | _ -> "" in
- (* Each hash counts once — lines can be rewritten on retry. *)
- if hash <> "" && not (Hashtbl.mem seen_hashes hash) then begin
- Hashtbl.add seen_hashes hash ();
- incr completed;
- Hashtbl.replace by_kind kind
- ((try Hashtbl.find by_kind kind with Not_found -> 0) + 1);
- (match status with
- | "ok" -> counts := { !counts with ok = !counts.ok + 1 }
- | "fail" -> counts := { !counts with fail = !counts.fail + 1 }
- | "cascade" ->
- counts := { !counts with cascade = !counts.cascade + 1 }
- | _ -> ())
- end;
- (* pkg_status: an "ok" on any hash wins (a later version built). *)
- (match Hashtbl.find_opt pkg_status pkg with
- | Some "ok" -> ()
- | _ -> Hashtbl.replace pkg_status pkg status);
- (match json |> member "failed_dep" with
- | `String dep -> Hashtbl.replace failed_dep pkg dep
- | _ -> ())
- ) (read_jsonl jsonl);
- let kind_totals = match read_json_opt Fpath.(run_dir / "doc_dag.json") with
- | Some j -> kind_totals_of_doc_dag j
- | None ->
- match read_json_opt Fpath.(run_dir / "dag.json") with
- | Some j ->
+ let jsonl = Fpath.(run_dir / "build.jsonl") in
+ if not (Sys.file_exists (Fpath.to_string jsonl)) then None
+ else
+ let pkg_status : (string, string) Hashtbl.t = Hashtbl.create 256 in
+ let failed_dep : (string, string) Hashtbl.t = Hashtbl.create 32 in
+ let by_kind : (string, int) Hashtbl.t = Hashtbl.create 8 in
+ let seen_hashes : (string, unit) Hashtbl.t = Hashtbl.create 256 in
+ let counts = ref { ok = 0; fail = 0; cascade = 0 } in
+ let completed = ref 0 in
+ List.iter
+ (fun json ->
let open Yojson.Safe.Util in
- (match j |> member "build_nodes" with
- | `Int n -> [ ("build", n) ]
- | _ -> [])
- | None -> [] in
- let total =
- if kind_totals = [] then None
- else Some (List.fold_left (fun acc (_, n) -> acc + n) 0 kind_totals)
- in
- let progress = {
- completed = !completed;
- total;
- by_kind = Hashtbl.fold (fun k n acc -> (k, n) :: acc) by_kind []
- |> List.sort compare;
-kind_totals;
- } in
- Some {
- run_dir;
- run_id = Fpath.basename run_dir;
- pkg_status;
- failed_dep;
- counts = !counts;
- progress;
- }
+ let pkg = json |> member "pkg" |> to_string in
+ let status = json |> member "status" |> to_string in
+ let kind =
+ match json |> member "kind" with `String s -> s | _ -> "build"
+ in
+ let hash =
+ match json |> member "hash" with `String s -> s | _ -> ""
+ in
+ (* Each hash counts once — lines can be rewritten on retry. *)
+ if hash <> "" && not (Hashtbl.mem seen_hashes hash) then (
+ Hashtbl.add seen_hashes hash ();
+ incr completed;
+ Hashtbl.replace by_kind kind
+ ((try Hashtbl.find by_kind kind with Not_found -> 0) + 1);
+ match status with
+ | "ok" -> counts := { !counts with ok = !counts.ok + 1 }
+ | "fail" -> counts := { !counts with fail = !counts.fail + 1 }
+ | "cascade" ->
+ counts := { !counts with cascade = !counts.cascade + 1 }
+ | _ -> ());
+ (* pkg_status: an "ok" on any hash wins (a later version built). *)
+ (match Hashtbl.find_opt pkg_status pkg with
+ | Some "ok" -> ()
+ | _ -> Hashtbl.replace pkg_status pkg status);
+ match json |> member "failed_dep" with
+ | `String dep -> Hashtbl.replace failed_dep pkg dep
+ | _ -> ())
+ (read_jsonl jsonl);
+ let kind_totals =
+ match read_json_opt Fpath.(run_dir / "doc_dag.json") with
+ | Some j -> kind_totals_of_doc_dag j
+ | None -> (
+ match read_json_opt Fpath.(run_dir / "dag.json") with
+ | Some j -> (
+ let open Yojson.Safe.Util in
+ match j |> member "build_nodes" with
+ | `Int n -> [ ("build", n) ]
+ | _ -> [])
+ | None -> [])
+ in
+ let total =
+ if kind_totals = [] then None
+ else Some (List.fold_left (fun acc (_, n) -> acc + n) 0 kind_totals)
+ in
+ let progress =
+ {
+ completed = !completed;
+ total;
+ by_kind =
+ Hashtbl.fold (fun k n acc -> (k, n) :: acc) by_kind []
+ |> List.sort compare;
+ kind_totals;
+ }
+ in
+ Some
+ {
+ run_dir;
+ run_id = Fpath.basename run_dir;
+ pkg_status;
+ failed_dep;
+ counts = !counts;
+ progress;
+ }
let format_progress (p : progress) =
- let pct = match p.total with
+ let pct =
+ match p.total with
| Some t when t > 0 ->
- Printf.sprintf " (%.1f%%)"
- (100. *. float p.completed /. float t)
- | _ -> "" in
- let total_s = match p.total with
- | Some t -> Printf.sprintf "/%d" t
- | None -> "" in
+ Printf.sprintf " (%.1f%%)" (100. *. float p.completed /. float t)
+ | _ -> ""
+ in
+ let total_s =
+ match p.total with Some t -> Printf.sprintf "/%d" t | None -> ""
+ in
let per_kind =
- let lookup kind =
- try List.assoc kind p.by_kind with Not_found -> 0 in
+ let lookup kind = try List.assoc kind p.by_kind with Not_found -> 0 in
let total_of kind =
- try List.assoc kind p.kind_totals with Not_found -> 0 in
- let parts = List.filter_map (fun kind ->
- let done_ = lookup kind in
- let total = total_of kind in
- if done_ = 0 && total = 0 then None
- else if total > 0 then
- Some (Printf.sprintf "%s=%d/%d" kind done_ total)
- else Some (Printf.sprintf "%s=%d" kind done_)
- ) [ "build"; "tool"; "compile"; "doc-all"; "link" ] in
- if parts = [] then "" else " — " ^ String.concat " " parts in
+ try List.assoc kind p.kind_totals with Not_found -> 0
+ in
+ let parts =
+ List.filter_map
+ (fun kind ->
+ let done_ = lookup kind in
+ let total = total_of kind in
+ if done_ = 0 && total = 0 then None
+ else if total > 0 then
+ Some (Printf.sprintf "%s=%d/%d" kind done_ total)
+ else Some (Printf.sprintf "%s=%d" kind done_))
+ [ "build"; "tool"; "compile"; "doc-all"; "link" ]
+ in
+ if parts = [] then "" else " — " ^ String.concat " " parts
+ in
Printf.sprintf "%d%s%s%s" p.completed total_s pct per_kind
File "day11/batch/live_view.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/live_view.mli b/_build/default/day11/batch/.formatted/live_view.mli
index 3d16180..b64716a 100644
--- a/_build/default/day11/batch/live_view.mli
+++ b/_build/default/day11/batch/.formatted/live_view.mli
@@ -1,44 +1,40 @@
(** Live view of an in-progress run.
- Reads [runs/<latest>/build.jsonl] and (when present) the phase
- JSON files written by {!Day11_lib.Run_log} to produce a structured
- snapshot of progress so far. Lets CLIs show meaningful output
- before [summary.json] / [status.json] are written at run end. *)
+ Reads [runs/<latest>/build.jsonl] and (when present) the phase JSON files
+ written by {!Day11_lib.Run_log} to produce a structured snapshot of progress
+ so far. Lets CLIs show meaningful output before [summary.json] /
+ [status.json] are written at run end. *)
-type counts = {
- ok : int;
- fail : int;
- cascade : int;
-}
+type counts = { ok : int; fail : int; cascade : int }
type progress = {
completed : int;
- total : int option; (** [None] when [doc_dag.json] is absent. *)
+ total : int option; (** [None] when [doc_dag.json] is absent. *)
by_kind : (string * int) list;
- (** [(kind, completed_count)] for each kind seen. *)
+ (** [(kind, completed_count)] for each kind seen. *)
kind_totals : (string * int) list;
- (** [(kind, total_planned)] from [doc_dag.json]. Empty if absent. *)
+ (** [(kind, total_planned)] from [doc_dag.json]. Empty if absent. *)
}
type t = {
run_dir : Fpath.t;
- run_id : string; (** Directory name (e.g. "2026-04-22-112301"). *)
+ run_id : string; (** Directory name (e.g. "2026-04-22-112301"). *)
pkg_status : (string, string) Hashtbl.t;
- (** [pkg_str -> "ok" | "fail" | "cascade"] — "ok" wins if a package
- has multiple hashes. *)
+ (** [pkg_str -> "ok" | "fail" | "cascade"] — "ok" wins if a package has
+ multiple hashes. *)
failed_dep : (string, string) Hashtbl.t;
- (** [pkg_str -> failed_dep_pkg_str] for cascade entries. *)
+ (** [pkg_str -> failed_dep_pkg_str] for cascade entries. *)
counts : counts;
progress : progress;
}
val load_latest : snapshot_dir:Fpath.t -> t option
-(** Load the most recent run under [snapshot_dir/runs/]. Returns
- [None] if the snapshot has no runs or [build.jsonl] is missing. *)
+(** Load the most recent run under [snapshot_dir/runs/]. Returns [None] if the
+ snapshot has no runs or [build.jsonl] is missing. *)
val is_terminal : snapshot_dir:Fpath.t -> bool
-(** [true] iff [status.json] exists — i.e. the pipeline has written a
- finished state and callers can use the usual code path. *)
+(** [true] iff [status.json] exists — i.e. the pipeline has written a finished
+ state and callers can use the usual code path. *)
val format_progress : progress -> string
(** One-line summary, e.g. [" 128/4430 (2.9%) — build=120 tool=2 compile=6"]. *)
File "day11/batch/profile.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/profile.mli b/_build/default/day11/batch/.formatted/profile.mli
index 0efaa50..7a94d92 100644
--- a/_build/default/day11/batch/profile.mli
+++ b/_build/default/day11/batch/.formatted/profile.mli
@@ -1,22 +1,21 @@
(** Named profiles for day11 analysis configurations.
- A profile captures the stable configuration for an ongoing analysis:
- which opam repositories to use, what overrides to apply, what targets
- to build, and what platform to target. Profiles are stored as JSON
- files in a profile directory (default [~/.day11/profiles/]). *)
+ A profile captures the stable configuration for an ongoing analysis: which
+ opam repositories to use, what overrides to apply, what targets to build,
+ and what platform to target. Profiles are stored as JSON files in a profile
+ directory (default [~/.day11/profiles/]). *)
-(** Target selection on two orthogonal axes: which versions to take,
- and which packages to include. *)
+(** Target selection on two orthogonal axes: which versions to take, and which
+ packages to include. *)
type version_mode =
| All_versions
| Latest_n of int
- (** Keep the [n] most-recent (non-avoided) versions of each
- package. [Latest_n 1] = newest only. *)
+ (** Keep the [n] most-recent (non-avoided) versions of each package.
+ [Latest_n 1] = newest only. *)
type name_filter =
| All_names
- | Names of string list
- (** Track only these exact package names. *)
+ | Names of string list (** Track only these exact package names. *)
type target_mode = { versions : version_mode; names : name_filter }
@@ -36,20 +35,18 @@ type t = {
driver_compiler : string;
extra_pins : string list;
pinned_versions : string list;
- (** Hard version pins fed into the solver as
- [(`Eq, version)] constraints, format ["name.version"].
- Used to propagate a specific [+ox] (or otherwise
- variant-flavoured) version through a target's
- transitive deps when the solver would otherwise pick a
- lex-max mainline alternative — equivalent in shape to
- [oi]'s [x-oi-toolchain-roots]. Empty list = no extra
- pins beyond [compiler]. *)
+ (** Hard version pins fed into the solver as [(`Eq, version)] constraints,
+ format ["name.version"]. Used to propagate a specific [+ox] (or
+ otherwise variant-flavoured) version through a target's transitive
+ deps when the solver would otherwise pick a lex-max mainline
+ alternative — equivalent in shape to [oi]'s [x-oi-toolchain-roots].
+ Empty list = no extra pins beyond [compiler]. *)
patches_dir : string option;
base_image_digest : string option;
base_image_updated : string option;
html_dir : string option;
- (** Destination for generated HTML when this profile is
- driven by a doc pipeline. [None] = build-only, no docs. *)
+ (** Destination for generated HTML when this profile is driven by a doc
+ pipeline. [None] = build-only, no docs. *)
}
val save : dir:Fpath.t -> t -> (unit, [> Rresult.R.msg ]) result
@@ -58,10 +55,10 @@ val save : dir:Fpath.t -> t -> (unit, [> Rresult.R.msg ]) result
val load : dir:Fpath.t -> name:string -> (t, [> Rresult.R.msg ]) result
(** [load ~dir ~name] reads a profile from [dir/<name>.json].
- Relative [opam_repositories] entries are resolved against the
- .day11 root ([dir]'s parent — [dir] being the [profiles/] dir), so
- a profile can refer to e.g. ["overlays/odoc-master/repo"] without
- an absolute prefix. Absolute entries are kept as-is. *)
+ Relative [opam_repositories] entries are resolved against the .day11 root
+ ([dir]'s parent — [dir] being the [profiles/] dir), so a profile can refer
+ to e.g. ["overlays/odoc-master/repo"] without an absolute prefix. Absolute
+ entries are kept as-is. *)
val list : dir:Fpath.t -> string list
(** [list ~dir] returns the names of all profiles in [dir]. *)
@@ -84,34 +81,33 @@ val default_dir : unit -> Fpath.t
(** [~/.day11] *)
val resolve_repo : day11_dir:Fpath.t -> string -> string
-(** [resolve_repo ~day11_dir s] resolves a repository path against the
- .day11 root: an absolute [s] is returned unchanged, a relative one
- is taken relative to [day11_dir] (and normalised). {!load} applies
- this to every [opam_repositories] entry; callers that accept repo
- paths from elsewhere (e.g. ocaml-docs-ci's [--remote] /
- [--github-pin-overlay] CLI args) should use it too so the paths
- resolve identically and line up. *)
+(** [resolve_repo ~day11_dir s] resolves a repository path against the .day11
+ root: an absolute [s] is returned unchanged, a relative one is taken
+ relative to [day11_dir] (and normalised). {!load} applies this to every
+ [opam_repositories] entry; callers that accept repo paths from elsewhere
+ (e.g. ocaml-docs-ci's [--remote] / [--github-pin-overlay] CLI args) should
+ use it too so the paths resolve identically and line up. *)
val base_image_tag : t -> string
(** E.g. ["debian:bookworm"]. *)
val resolve_base_digest : t -> string option
-(** Query the Docker registry for the current image digest.
- Calls [docker manifest inspect] — can take 10-15 seconds. *)
+(** Query the Docker registry for the current image digest. Calls
+ [docker manifest inspect] — can take 10-15 seconds. *)
val refresh_base_digest : t -> (t, [> Rresult.R.msg ]) result
-(** Resolve the digest and return an updated profile.
- Caller must save the profile. *)
+(** Resolve the digest and return an updated profile. Caller must save the
+ profile. *)
val base_image_stale : ?max_age_days:int -> t -> bool
-(** Returns [true] if the base image digest is older than
- [max_age_days] (default 30), or if no digest is recorded. *)
+(** Returns [true] if the base image digest is older than [max_age_days]
+ (default 30), or if no digest is recorded. *)
val track_limit : t -> int option
-(** Convert [target_mode] into a "number of versions per package"
- limit for use with tracking pipelines (ocaml-docs-ci). [None]
- means no limit (track every version). *)
+(** Convert [target_mode] into a "number of versions per package" limit for use
+ with tracking pipelines (ocaml-docs-ci). [None] means no limit (track every
+ version). *)
val track_filter : t -> string list
-(** Convert [target_mode] into a list of package names to track.
- Empty list means no filter (track all). *)
+(** Convert [target_mode] into a list of package names to track. Empty list
+ means no filter (track all). *)
File "day11/batch/profile_ctx.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/profile_ctx.ml b/_build/default/day11/batch/.formatted/profile_ctx.ml
index 8ccd619..acbec7f 100644
--- a/_build/default/day11/batch/profile_ctx.ml
+++ b/_build/default/day11/batch/.formatted/profile_ctx.ml
@@ -20,62 +20,74 @@ let parse_ocaml_version = function
let image_of_profile (profile : Profile.t) =
match profile.base_image_digest with
| Some d -> d
- | None ->
- Printf.sprintf "%s:%s" profile.os_distribution profile.os_version
+ | None -> Printf.sprintf "%s:%s" profile.os_distribution profile.os_version
-let finalise_load (profile : Profile.t) ~cache_dir
- git_packages repos_with_shas =
+let finalise_load (profile : Profile.t) ~cache_dir git_packages repos_with_shas
+ =
let os_dir = Fpath.(cache_dir / Profile.os_dir_name profile) in
(* ocaml-git clobbers Bos's temp dir default; reset for downstream
callers that use Bos.OS.Dir.tmp. *)
Bos.OS.Dir.set_default_tmp (Fpath.v (Filename.get_temp_dir_name ()));
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch:profile.arch
- ~os:"linux"
- ~os_distribution:profile.os_distribution
- ~os_family:profile.os_distribution
- ~os_version:profile.os_version
- ()
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch:profile.arch ~os:"linux"
+ ~os_distribution:profile.os_distribution
+ ~os_family:profile.os_distribution ~os_version:profile.os_version ()
in
let ocaml_version = parse_ocaml_version profile.compiler in
let driver_compiler =
if profile.driver_compiler = "" then None
else Some (OpamPackage.of_string profile.driver_compiler)
in
- let patches = Option.map
- (fun dir -> Day11_opam_build.Patches.create (Fpath.v dir))
- profile.patches_dir
+ let patches =
+ Option.map
+ (fun dir -> Day11_opam_build.Patches.create (Fpath.v dir))
+ profile.patches_dir
in
let base_dir = Fpath.(cache_dir / "base") in
let image = image_of_profile profile in
let base : Day11_layer.Base.t =
- { hash = Day11_opam_build.Base.build_hash
- ~os_distribution:profile.os_distribution
- ~os_version:profile.os_version
- ~arch:profile.arch
- ?digest:profile.base_image_digest ();
+ {
+ hash =
+ Day11_opam_build.Base.build_hash
+ ~os_distribution:profile.os_distribution
+ ~os_version:profile.os_version ~arch:profile.arch
+ ?digest:profile.base_image_digest ();
dir = base_dir;
- image }
+ image;
+ }
in
let benv = Day11_opam_build.Types.make_build_env ~base ~os_dir () in
let find_opam = Day11_opam.Git_packages.find_package git_packages in
let hash_cache = Day11_opam_build.Hash_cache.create ~find_opam ?patches () in
- { profile; cache_dir; os_dir;
- git_packages; repos_with_shas; opam_env;
- ocaml_version; driver_compiler; patches;
- base; benv; hash_cache }
+ {
+ profile;
+ cache_dir;
+ os_dir;
+ git_packages;
+ repos_with_shas;
+ opam_env;
+ ocaml_version;
+ driver_compiler;
+ patches;
+ base;
+ benv;
+ hash_cache;
+ }
let load (profile : Profile.t) ~cache_dir =
let repos_with_heads =
- List.map (fun r -> (r, None)) profile.opam_repositories in
+ List.map (fun r -> (r, None)) profile.opam_repositories
+ in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories repos_with_heads in
+ Day11_opam.Git_packages.of_repositories repos_with_heads
+ in
finalise_load profile ~cache_dir git_packages repos_with_shas
let load_lwt (profile : Profile.t) ~cache_dir =
let open Lwt.Infix in
let repos_with_heads =
- List.map (fun r -> (r, None)) profile.opam_repositories in
+ List.map (fun r -> (r, None)) profile.opam_repositories
+ in
Day11_opam.Git_packages.of_repositories_lwt repos_with_heads
>|= fun (git_packages, repos_with_shas) ->
finalise_load profile ~cache_dir git_packages repos_with_shas
@@ -86,28 +98,34 @@ let base_materialised (base : Day11_layer.Base.t) =
Bos.OS.Dir.exists marker |> Result.value ~default:false
let rebuild_base_with ~base ctx =
- { ctx with base;
- benv = Day11_opam_build.Types.make_build_env ~base
- ~os_dir:ctx.os_dir ~uid:ctx.benv.uid ~gid:ctx.benv.gid
- ?cpu_slots:ctx.benv.cpu_slots () }
+ {
+ ctx with
+ base;
+ benv =
+ Day11_opam_build.Types.make_build_env ~base ~os_dir:ctx.os_dir
+ ~uid:ctx.benv.uid ~gid:ctx.benv.gid ?cpu_slots:ctx.benv.cpu_slots ();
+ }
let with_cpu_slots ctx pool =
- { ctx with benv = Day11_opam_build.Types.make_build_env
- ~base:ctx.base ~os_dir:ctx.os_dir
- ~uid:ctx.benv.uid ~gid:ctx.benv.gid
- ~cpu_slots:pool () }
+ {
+ ctx with
+ benv =
+ Day11_opam_build.Types.make_build_env ~base:ctx.base ~os_dir:ctx.os_dir
+ ~uid:ctx.benv.uid ~gid:ctx.benv.gid ~cpu_slots:pool ();
+ }
let with_base_digest ctx digest =
let profile = { ctx.profile with base_image_digest = Some digest } in
let base_dir = ctx.base.dir in
let base : Day11_layer.Base.t =
- { hash = Day11_opam_build.Base.build_hash
- ~os_distribution:profile.os_distribution
- ~os_version:profile.os_version
- ~arch:profile.arch
- ~digest ();
+ {
+ hash =
+ Day11_opam_build.Base.build_hash
+ ~os_distribution:profile.os_distribution
+ ~os_version:profile.os_version ~arch:profile.arch ~digest ();
dir = base_dir;
- image = digest }
+ image = digest;
+ }
in
rebuild_base_with ~base { ctx with profile }
@@ -117,35 +135,30 @@ let ensure_base ~sw env ctx =
binary that gets baked into the base image, so profiles with
different [opam_build_repo] settings don't step on each other
even when they share a base image. *)
- let opam_build_repo =
- Option.map Fpath.v ctx.profile.opam_build_repo in
+ let opam_build_repo = Option.map Fpath.v ctx.profile.opam_build_repo in
match
- Day11_opam_build.Base.build_opam_build ~sw env
- ~cache_dir:ctx.cache_dir ~arch:ctx.profile.arch
- ?opam_build_repo ()
+ Day11_opam_build.Base.build_opam_build ~sw env ~cache_dir:ctx.cache_dir
+ ~arch:ctx.profile.arch ?opam_build_repo ()
with
| Error _ as e -> e
- | Ok _ ->
- if base_materialised ctx.base then Ok ctx
- else begin
- let uid = Unix.getuid () and gid = Unix.getgid () in
- (* The base image is repo-agnostic now (empty [default] repo;
+ | Ok _ -> (
+ if base_materialised ctx.base then Ok ctx
+ else
+ let uid = Unix.getuid () and gid = Unix.getgid () in
+ (* The base image is repo-agnostic now (empty [default] repo;
per-package slices are mounted at build time), so it takes no
[opam_repositories]. *)
- match Day11_opam_build.Base.build ~sw env ~cache_dir:ctx.cache_dir
- ~os_distribution:ctx.profile.os_distribution
- ~os_version:ctx.profile.os_version
- ~arch:ctx.profile.arch
- ~uid ~gid
- ?digest:ctx.profile.base_image_digest ()
- with
- | Ok base -> Ok (rebuild_base_with ~base ctx)
- | Error _ as e -> e
- end
+ match
+ Day11_opam_build.Base.build ~sw env ~cache_dir:ctx.cache_dir
+ ~os_distribution:ctx.profile.os_distribution
+ ~os_version:ctx.profile.os_version ~arch:ctx.profile.arch ~uid ~gid
+ ?digest:ctx.profile.base_image_digest ()
+ with
+ | Ok base -> Ok (rebuild_base_with ~base ctx)
+ | Error _ as e -> e)
let require_base ctx =
if base_materialised ctx.base then Ok ctx
else
Rresult.R.error_msgf
- "No base image for profile %s — run 'day11 batch' first"
- ctx.profile.name
+ "No base image for profile %s — run 'day11 batch' first" ctx.profile.name
File "day11/batch/profile_ctx.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/profile_ctx.mli b/_build/default/day11/batch/.formatted/profile_ctx.mli
index 2bc4e61..a92ad89 100644
--- a/_build/default/day11/batch/profile_ctx.mli
+++ b/_build/default/day11/batch/.formatted/profile_ctx.mli
@@ -1,94 +1,88 @@
(** Resolved profile context: profile + everything derived from it.
- A {!Profile.t} is the on-disk stable configuration. A {!t} is
- what day11 actually runs against: the profile plus the git
- package index read from its opam repositories, the opam
- variable environment for its platform, the base layer for its
- distribution + architecture, the {!Day11_opam_build.Types.build_env}
- it produces, and a shared {!Day11_opam_build.Hash_cache.t}.
+ A {!Profile.t} is the on-disk stable configuration. A {!t} is what day11
+ actually runs against: the profile plus the git package index read from its
+ opam repositories, the opam variable environment for its platform, the base
+ layer for its distribution + architecture, the
+ {!Day11_opam_build.Types.build_env} it produces, and a shared
+ {!Day11_opam_build.Hash_cache.t}.
- Callers that today assembled these pieces by hand from a profile
- — [cmd_batch], [cmd_build], [cmd_rerun], the ocaml-docs-ci
- pipeline — construct one [Profile_ctx.t] up front and pass it
- to {!Day11_doc.Generate.build_tools_and_run}, {!plan_doc_dag},
- and similar. *)
+ Callers that today assembled these pieces by hand from a profile —
+ [cmd_batch], [cmd_build], [cmd_rerun], the ocaml-docs-ci pipeline —
+ construct one [Profile_ctx.t] up front and pass it to
+ {!Day11_doc.Generate.build_tools_and_run}, {!plan_doc_dag}, and similar. *)
type t = {
profile : Profile.t;
cache_dir : Fpath.t;
- (** Top-level day11 cache root (e.g. [~/.day11/cache]). Typically
- [paths.cache_dir] from [Common.paths]. *)
+ (** Top-level day11 cache root (e.g. [~/.day11/cache]). Typically
+ [paths.cache_dir] from [Common.paths]. *)
os_dir : Fpath.t;
- (** Platform-specific cache dir ([cache_dir / Profile.os_dir_name]). *)
+ (** Platform-specific cache dir ([cache_dir / Profile.os_dir_name]). *)
git_packages : Day11_opam.Git_packages.t;
- (** Loaded opam package index from [profile.opam_repositories]. *)
+ (** Loaded opam package index from [profile.opam_repositories]. *)
repos_with_shas : (string * string) list;
- (** [(repo_path, commit_sha)] pairs, one per repo; SHAs are resolved
- from the current [HEAD] of each repository at [load] time. *)
+ (** [(repo_path, commit_sha)] pairs, one per repo; SHAs are resolved from
+ the current [HEAD] of each repository at [load] time. *)
opam_env : string -> OpamVariable.variable_contents option;
- (** Opam variable lookup for this profile's platform ([arch],
- [os_distribution], [os_family], [os_version]). *)
+ (** Opam variable lookup for this profile's platform ([arch],
+ [os_distribution], [os_family], [os_version]). *)
ocaml_version : OpamPackage.t option;
- (** Parsed [profile.compiler] — used as a constraint for the solver
- when set. *)
+ (** Parsed [profile.compiler] — used as a constraint for the solver when
+ set. *)
driver_compiler : OpamPackage.t option;
- (** Parsed [profile.driver_compiler], or [None] if the profile uses
- the empty-string default. *)
+ (** Parsed [profile.driver_compiler], or [None] if the profile uses the
+ empty-string default. *)
patches : Day11_opam_build.Patches.t option;
- (** Loaded from [profile.patches_dir], if any. *)
+ (** Loaded from [profile.patches_dir], if any. *)
base : Day11_layer.Base.t;
- (** Base layer. At [load] time, the [hash] is always computable
- from profile fields; the on-disk [dir] may be empty (base image
- not built yet). Use {!ensure_base} to build and populate it. *)
+ (** Base layer. At [load] time, the [hash] is always computable from
+ profile fields; the on-disk [dir] may be empty (base image not built
+ yet). Use {!ensure_base} to build and populate it. *)
benv : Day11_opam_build.Types.build_env;
- (** Shared {!Day11_opam_build.Types.build_env} built from [base] +
- [os_dir]. *)
+ (** Shared {!Day11_opam_build.Types.build_env} built from [base] +
+ [os_dir]. *)
hash_cache : Day11_opam_build.Hash_cache.t;
- (** Shared hash cache seeded with [find_opam] from [git_packages]
- and [patches]. Passed to {!Day11_opam_build.Dag.build_dag} and
- to doc tool planning so that the same node hashes are computed
- everywhere. *)
+ (** Shared hash cache seeded with [find_opam] from [git_packages] and
+ [patches]. Passed to {!Day11_opam_build.Dag.build_dag} and to doc tool
+ planning so that the same node hashes are computed everywhere. *)
}
val load : Profile.t -> cache_dir:Fpath.t -> t
-(** Load profile-derived context: read the opam repositories, resolve
- commit SHAs, build the opam env, compute the base hash, construct
- [benv] and [hash_cache]. Does not touch the network and does not
- materialise the base image on disk. *)
+(** Load profile-derived context: read the opam repositories, resolve commit
+ SHAs, build the opam env, compute the base hash, construct [benv] and
+ [hash_cache]. Does not touch the network and does not materialise the base
+ image on disk. *)
val load_lwt : Profile.t -> cache_dir:Fpath.t -> t Lwt.t
-(** Lwt-native version of {!load}. Use from inside an already-running
- Lwt event loop (e.g. an OCurrent Op) to avoid nested
- [Lwt_main.run] errors in the underlying git-unix reads. *)
+(** Lwt-native version of {!load}. Use from inside an already-running Lwt event
+ loop (e.g. an OCurrent Op) to avoid nested [Lwt_main.run] errors in the
+ underlying git-unix reads. *)
val ensure_base :
- sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> t ->
- (t, [> Rresult.R.msg ]) result
-(** Materialise the base image on disk if not already cached,
- returning an updated ctx with the resulting [base] populated.
- Also ensures the cached [opam-build] binary exists (built from
- [profile.opam_build_repo] if set, otherwise from upstream), so
- the base image embeds it. Idempotent: if the base layer already
- exists, returns the ctx unchanged. This is the single entry
- point for triggering a [docker build] of the base image. *)
+ sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> t -> (t, [> Rresult.R.msg ]) result
+(** Materialise the base image on disk if not already cached, returning an
+ updated ctx with the resulting [base] populated. Also ensures the cached
+ [opam-build] binary exists (built from [profile.opam_build_repo] if set,
+ otherwise from upstream), so the base image embeds it. Idempotent: if the
+ base layer already exists, returns the ctx unchanged. This is the single
+ entry point for triggering a [docker build] of the base image. *)
val with_cpu_slots : t -> Day11_runner.Cpu_slots.t -> t
-(** Return [ctx] with its [benv] rebuilt so container launches
- acquire / release slots from [pool] — caps nested build
- parallelism and pins each container to a NUMA-local cpu set. *)
+(** Return [ctx] with its [benv] rebuilt so container launches acquire / release
+ slots from [pool] — caps nested build parallelism and pins each container to
+ a NUMA-local cpu set. *)
val with_base_digest : t -> string -> t
(** [with_base_digest ctx digest] returns a new context whose
- [profile.base_image_digest] is set to [digest] and whose [base]
- layer hash and [benv] are recomputed against that digest. The
- on-disk [base.dir] is preserved; [ensure_base] must still be
- called to materialise the new base image. Use when an external
- source (e.g. a periodic docker-manifest-inspect OCurrent job)
- produces a fresh digest that should drive the whole build tree. *)
+ [profile.base_image_digest] is set to [digest] and whose [base] layer hash
+ and [benv] are recomputed against that digest. The on-disk [base.dir] is
+ preserved; [ensure_base] must still be called to materialise the new base
+ image. Use when an external source (e.g. a periodic docker-manifest-inspect
+ OCurrent job) produces a fresh digest that should drive the whole build
+ tree. *)
-val require_base :
- t -> (t, [> Rresult.R.msg ]) result
-(** Like {!ensure_base}, but never runs [docker build] — returns an
- error if the base image is not already cached. Use from contexts
- that should fail fast when the base image is missing (e.g.
- ocaml-docs-ci's doc pipeline). *)
+val require_base : t -> (t, [> Rresult.R.msg ]) result
+(** Like {!ensure_base}, but never runs [docker build] — returns an error if the
+ base image is not already cached. Use from contexts that should fail fast
+ when the base image is missing (e.g. ocaml-docs-ci's doc pipeline). *)
File "day11/batch/recorder.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/recorder.ml b/_build/default/day11/batch/.formatted/recorder.ml
index 3a168d9..edcf8b2 100644
--- a/_build/default/day11/batch/recorder.ml
+++ b/_build/default/day11/batch/.formatted/recorder.ml
@@ -15,20 +15,25 @@ type t = {
let now_iso8601 () =
let t = Unix.gettimeofday () in
let tm = Unix.gmtime t in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min tm.tm_sec
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (tm.tm_year + 1900)
+ (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
let create ~env ~os_dir ~packages_dir ~blessing_maps ~run_log =
- { env; os_dir; packages_dir; blessing_maps; run_log;
+ {
+ env;
+ os_dir;
+ packages_dir;
+ blessing_maps;
+ run_log;
outcomes_lock = Mutex.create ();
outcomes = ref [];
- doc_outcomes = ref [] }
+ doc_outcomes = ref [];
+ }
let is_blessed t (node : Build.t) =
- List.exists (fun (_target, map) ->
- Blessing.is_blessed map node.pkg
- ) t.blessing_maps
+ List.exists
+ (fun (_target, map) -> Blessing.is_blessed map node.pkg)
+ t.blessing_maps
let log_file_for t (node : Build.t) =
let dir = Build.dir ~os_dir:t.os_dir node in
@@ -43,60 +48,65 @@ let append_outcome t outcome =
let ensure_symlink t (node : Build.t) =
let pkg_str = OpamPackage.to_string node.pkg in
let layer_name = Build.dir_name node in
- ignore (Day11_layer.Symlinks.ensure t.env
- ~packages_dir:t.packages_dir ~id:pkg_str ~layer_name)
+ ignore
+ (Day11_layer.Symlinks.ensure t.env ~packages_dir:t.packages_dir ~id:pkg_str
+ ~layer_name)
let classify_log log_file =
match log_file with
| None -> ("build_failure", None)
- | Some path ->
- match Bos.OS.File.read path with
- | Error _ -> ("build_failure", None)
- | Ok content ->
- let (_status, category, error) =
- Day11_lib.Classify.classify_build_log content in
- (category, error)
+ | Some path -> (
+ match Bos.OS.File.read path with
+ | Error _ -> ("build_failure", None)
+ | Ok content ->
+ let _status, category, error =
+ Day11_lib.Classify.classify_build_log content
+ in
+ (category, error))
-(** Append one history entry to disk immediately. Per-pkg history.jsonl
- becomes the live event log; downstream regen of [status.json]
- happens on a schedule, not at the end of the OCurrent tick. *)
+(** Append one history entry to disk immediately. Per-pkg history.jsonl becomes
+ the live event log; downstream regen of [status.json] happens on a schedule,
+ not at the end of the OCurrent tick. *)
let append_history t ~node ~status ~category ~error ~blessed =
- let entry : Day11_lib.History.entry = {
- ts = now_iso8601 ();
- run = Day11_lib.Run_log.get_id t.run_log;
- build_hash = node.Build.hash;
- status;
- category;
- blessed;
- error;
- } in
+ let entry : Day11_lib.History.entry =
+ {
+ ts = now_iso8601 ();
+ run = Day11_lib.Run_log.get_id t.run_log;
+ build_hash = node.Build.hash;
+ status;
+ category;
+ blessed;
+ error;
+ }
+ in
Day11_lib.History.append ~packages_dir:t.packages_dir
- ~pkg_str:(OpamPackage.to_string node.pkg) entry
+ ~pkg_str:(OpamPackage.to_string node.pkg)
+ entry
let record_build t (node : Build.t) ~success =
ensure_symlink t node;
let log_file = log_file_for t node in
let blessed = is_blessed t node in
let category, error =
- if success then ("success", None) else classify_log log_file in
+ if success then ("success", None) else classify_log log_file
+ in
append_history t ~node
~status:(if success then "success" else "failure")
~category ~error ~blessed;
- append_outcome t {
- Summary.pkg = node.pkg;
- build_hash = node.hash;
- success;
- log_file;
- blessed;
- };
- let layer_dir =
- Fpath.to_string (Build.dir ~os_dir:t.os_dir node) in
+ append_outcome t
+ {
+ Summary.pkg = node.pkg;
+ build_hash = node.hash;
+ success;
+ log_file;
+ blessed;
+ };
+ let layer_dir = Fpath.to_string (Build.dir ~os_dir:t.os_dir node) in
Day11_lib.Run_log.log_build_result t.run_log
~pkg:(OpamPackage.to_string node.pkg)
~hash:node.hash
~status:(if success then "ok" else "fail")
- ~failed_dep:None
- ~kind:"build" ~layer_dir ()
+ ~failed_dep:None ~kind:"build" ~layer_dir ()
let record_cascade t ~(failed : Build.t) ~(failed_dep : Build.t) =
(* Cascades are entirely derivable from [<snapshot_dir>/dag.json] +
@@ -108,8 +118,7 @@ let record_cascade t ~(failed : Build.t) ~(failed_dep : Build.t) =
ensure_symlink t failed;
Day11_lib.Run_log.log_build_result t.run_log
~pkg:(OpamPackage.to_string failed.pkg)
- ~hash:failed.hash
- ~status:"cascade"
+ ~hash:failed.hash ~status:"cascade"
~failed_dep:(Some (OpamPackage.to_string failed_dep.pkg))
~kind:"build" ()
@@ -126,21 +135,20 @@ let record_doc t (node : Build.t) ~success =
~status:(if success then "success" else "failure")
~category:(if success then "doc_success" else "doc_failure")
~error:None ~blessed;
- append_doc_outcome t {
- Summary.pkg = node.pkg;
- success;
- layer_hash = node.hash;
- log_file;
- blessed;
- };
- let layer_dir =
- Fpath.to_string (Build.dir ~os_dir:t.os_dir node) in
+ append_doc_outcome t
+ {
+ Summary.pkg = node.pkg;
+ success;
+ layer_hash = node.hash;
+ log_file;
+ blessed;
+ };
+ let layer_dir = Fpath.to_string (Build.dir ~os_dir:t.os_dir node) in
Day11_lib.Run_log.log_build_result t.run_log
~pkg:(OpamPackage.to_string node.pkg)
~hash:node.hash
~status:(if success then "ok" else "fail")
- ~failed_dep:None
- ~kind:"doc" ~layer_dir ()
+ ~failed_dep:None ~kind:"doc" ~layer_dir ()
let outcomes t =
Mutex.lock t.outcomes_lock;
File "day11/batch/recorder.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/recorder.mli b/_build/default/day11/batch/.formatted/recorder.mli
index c8ac1b4..7d44c2f 100644
--- a/_build/default/day11/batch/recorder.mli
+++ b/_build/default/day11/batch/.formatted/recorder.mli
@@ -1,9 +1,9 @@
-(** Shared writer for per-build bookkeeping: outcome accumulation,
- packages-dir symlinks, and run-log lines.
+(** Shared writer for per-build bookkeeping: outcome accumulation, packages-dir
+ symlinks, and run-log lines.
- Used by [day11 batch] (the one-shot CLI) and by long-running
- pipelines like ocaml-docs-ci that want the same snapshot layout.
- All entry points are thread-safe. *)
+ Used by [day11 batch] (the one-shot CLI) and by long-running pipelines like
+ ocaml-docs-ci that want the same snapshot layout. All entry points are
+ thread-safe. *)
type t
@@ -16,35 +16,31 @@ val create :
t
val is_blessed : t -> Day11_opam_layer.Build.t -> bool
-(** Whether [node.pkg] is blessed in any of the blessing maps
- attached at [create] time. *)
+(** Whether [node.pkg] is blessed in any of the blessing maps attached at
+ [create] time. *)
-val record_build :
- t -> Day11_opam_layer.Build.t -> success:bool -> unit
+val record_build : t -> Day11_opam_layer.Build.t -> success:bool -> unit
(** Record a finished build. Appends a {!Day11_lib.History.entry} to
[packages/<pkg>/history.jsonl] immediately, also buffers a
{!Summary.build_outcome} for end-of-tick stats, ensures the
- [packages/<pkg>/<hash>] symlink, and writes one ["build"]-kind
- line to the run log. *)
+ [packages/<pkg>/<hash>] symlink, and writes one ["build"]-kind line to the
+ run log. *)
val record_cascade :
t ->
failed:Day11_opam_layer.Build.t ->
failed_dep:Day11_opam_layer.Build.t ->
unit
-(** Record a cascade failure: a build skipped because a dep failed.
- Creates the [packages/<pkg>] symlink and logs the cascade line.
- Does {b not} write any layer state under [<os_dir>/<hash>/], and
- does {b not} write to [history.jsonl] — cascade attribution is
- fully derivable from [<snapshot_dir>/dag.json] plus
- [<os_dir>/layer_status.jsonl]. *)
-
-val record_doc :
- t -> Day11_opam_layer.Build.t -> success:bool -> unit
-(** Record a finished doc-pipeline node (compile / doc-all / link).
- Appends a {!Day11_lib.History.entry} immediately, buffers a
- {!Summary.doc_outcome}, ensures the symlink, and writes a
- ["doc"]-kind line to the run log. *)
+(** Record a cascade failure: a build skipped because a dep failed. Creates the
+ [packages/<pkg>] symlink and logs the cascade line. Does {b not} write any
+ layer state under [<os_dir>/<hash>/], and does {b not} write to
+ [history.jsonl] — cascade attribution is fully derivable from
+ [<snapshot_dir>/dag.json] plus [<os_dir>/layer_status.jsonl]. *)
+
+val record_doc : t -> Day11_opam_layer.Build.t -> success:bool -> unit
+(** Record a finished doc-pipeline node (compile / doc-all / link). Appends a
+ {!Day11_lib.History.entry} immediately, buffers a {!Summary.doc_outcome},
+ ensures the symlink, and writes a ["doc"]-kind line to the run log. *)
val outcomes : t -> Summary.build_outcome list
(** Current accumulated build outcomes (most recent first). Pass to
File "day11/batch/rerun.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/rerun.ml b/_build/default/day11/batch/.formatted/rerun.ml
index 52813d5..b3c0ed5 100644
--- a/_build/default/day11/batch/rerun.ml
+++ b/_build/default/day11/batch/.formatted/rerun.ml
@@ -1,6 +1,7 @@
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
module Layer = Day11_layer.Layer
+
type build = Build.t
let load_exit_status env layer_json =
@@ -8,60 +9,57 @@ let load_exit_status env layer_json =
| Ok { exit_status; _ } -> Some exit_status
| Error _ -> None
-let build_env_of_meta ~os_dir ~cache_dir ~image
- (meta : Day11_layer.Meta.t) =
+let build_env_of_meta ~os_dir ~cache_dir ~image (meta : Day11_layer.Meta.t) =
let base_dir = Fpath.(cache_dir / "base") in
- let base : Day11_layer.Base.t = {
- hash = meta.base_hash;
- dir = base_dir;
- image;
- } in
- Day11_opam_build.Types.make_build_env ~base ~os_dir
- ~uid:meta.uid ~gid:meta.gid ()
+ let base : Day11_layer.Base.t =
+ { hash = meta.base_hash; dir = base_dir; image }
+ in
+ Day11_opam_build.Types.make_build_env ~base ~os_dir ~uid:meta.uid
+ ~gid:meta.gid ()
let rerun ~sw env ~os_dir ~cache_dir node =
let layer = Build.layer ~os_dir node in
let layer_dir = Layer.dir layer in
match Day11_layer.Meta.load env (Layer.meta_path layer) with
- | Error (`Msg e) ->
- Day11_opam_build.Types.Failure e
- | Ok { exit_status = 0; _ } ->
- Day11_opam_build.Types.Success node
+ | Error (`Msg e) -> Day11_opam_build.Types.Failure e
+ | Ok { exit_status = 0; _ } -> Day11_opam_build.Types.Success node
| Ok meta ->
- (* Read [base_image] from the layer's [build.json] sidecar so the
+ (* Read [base_image] from the layer's [build.json] sidecar so the
rerun reconstructs the same base. Fall back to "" — the cached
base layer at [cache_dir/base] is still mounted by hash, so a
warm cache rerun works without the image string. *)
- let image =
- match Day11_opam_layer.Build_meta.load layer_dir with
- | Ok bm -> bm.base_image
- | Error _ -> ""
- in
- let benv = build_env_of_meta ~os_dir ~cache_dir ~image meta in
- let opam_repo = Fpath.(layer_dir / "opam-repository") in
- let opam_repos =
- if Bos.OS.Dir.exists opam_repo |> Result.get_ok
- then [ opam_repo ]
- else []
- in
- ignore (Day11_sys.Sudo.rm_rf ~sw env layer_dir);
- Day11_opam_build.Build_layer.build ~sw env benv
- ~opam_repositories:opam_repos node ()
+ let image =
+ match Day11_opam_layer.Build_meta.load layer_dir with
+ | Ok bm -> bm.base_image
+ | Error _ -> ""
+ in
+ let benv = build_env_of_meta ~os_dir ~cache_dir ~image meta in
+ let opam_repo = Fpath.(layer_dir / "opam-repository") in
+ let opam_repos =
+ if Bos.OS.Dir.exists opam_repo |> Result.get_ok then [ opam_repo ]
+ else []
+ in
+ ignore (Day11_sys.Sudo.rm_rf ~sw env layer_dir);
+ Day11_opam_build.Build_layer.build ~sw env benv
+ ~opam_repositories:opam_repos node ()
let cascade ~sw env ~os_dir ~cache_dir nodes =
let rerun_count = ref 0 in
- List.iter (fun (node : build) ->
- let layer = Build.layer ~os_dir node in
- match load_exit_status env (Layer.meta_path layer) with
- | Some (-1) ->
- let all_deps_ok = List.for_all (fun (dep : build) ->
- let dep_layer = Build.layer ~os_dir dep in
- load_exit_status env (Layer.meta_path dep_layer) = Some 0
- ) node.deps in
- if all_deps_ok then begin
- ignore (rerun ~sw env ~os_dir ~cache_dir node);
- incr rerun_count
- end
- | _ -> ()
- ) nodes;
+ List.iter
+ (fun (node : build) ->
+ let layer = Build.layer ~os_dir node in
+ match load_exit_status env (Layer.meta_path layer) with
+ | Some -1 ->
+ let all_deps_ok =
+ List.for_all
+ (fun (dep : build) ->
+ let dep_layer = Build.layer ~os_dir dep in
+ load_exit_status env (Layer.meta_path dep_layer) = Some 0)
+ node.deps
+ in
+ if all_deps_ok then (
+ ignore (rerun ~sw env ~os_dir ~cache_dir node);
+ incr rerun_count)
+ | _ -> ())
+ nodes;
!rerun_count
File "day11/batch/rerun.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/rerun.mli b/_build/default/day11/batch/.formatted/rerun.mli
index 0883c74..79ed793 100644
--- a/_build/default/day11/batch/rerun.mli
+++ b/_build/default/day11/batch/.formatted/rerun.mli
@@ -1,8 +1,8 @@
(** Rerun failed builds and cascade recovery.
- Layers are self-describing — uid, gid, and base_hash are read
- from layer.json. Opam files are read from the layer's own
- [opam-repository/] directory. No external configuration needed. *)
+ Layers are self-describing — uid, gid, and base_hash are read from
+ layer.json. Opam files are read from the layer's own [opam-repository/]
+ directory. No external configuration needed. *)
val rerun :
sw:Eio.Switch.t ->
@@ -11,9 +11,9 @@ val rerun :
cache_dir:Fpath.t ->
Day11_opam_layer.Build.t ->
Day11_opam_build.Types.build_result
-(** [rerun ~sw env ~os_dir ~cache_dir node] rebuilds a failed layer.
- Reads uid/gid/base_hash from the layer's [layer.json] and
- opam files from its [opam-repository/] directory. *)
+(** [rerun ~sw env ~os_dir ~cache_dir node] rebuilds a failed layer. Reads
+ uid/gid/base_hash from the layer's [layer.json] and opam files from its
+ [opam-repository/] directory. *)
val cascade :
sw:Eio.Switch.t ->
@@ -22,6 +22,6 @@ val cascade :
cache_dir:Fpath.t ->
Day11_opam_layer.Build.t list ->
int
-(** [cascade ~sw env ~os_dir ~cache_dir nodes] scans [nodes] for
- dependency failures where the dependency has since succeeded,
- and reruns them. Returns the number of packages rerun. *)
+(** [cascade ~sw env ~os_dir ~cache_dir nodes] scans [nodes] for dependency
+ failures where the dependency has since succeeded, and reruns them. Returns
+ the number of packages rerun. *)
File "day11/batch/snapshot.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/snapshot.ml b/_build/default/day11/batch/.formatted/snapshot.ml
index 0b0aac8..adf3da3 100644
--- a/_build/default/day11/batch/snapshot.ml
+++ b/_build/default/day11/batch/.formatted/snapshot.ml
@@ -1,12 +1,10 @@
-type t = {
- repos : (string * string) list;
- key : string;
- created : string;
-}
+type t = { repos : (string * string) list; key : string; created : string }
let git_head_sha repo_path =
- let cmd = Printf.sprintf "git -C %s rev-parse HEAD 2>/dev/null"
- (Filename.quote repo_path) in
+ let cmd =
+ Printf.sprintf "git -C %s rev-parse HEAD 2>/dev/null"
+ (Filename.quote repo_path)
+ in
let ic = Unix.open_process_in cmd in
let sha = try String.trim (input_line ic) with _ -> "unknown" in
ignore (Unix.close_process_in ic);
@@ -15,39 +13,44 @@ let git_head_sha repo_path =
let compute_key repos =
let shas = List.map snd repos in
let combined = String.concat ":" shas in
- Digest.string combined |> Digest.to_hex |> fun s ->
- String.sub s 0 12
+ Digest.string combined |> Digest.to_hex |> fun s -> String.sub s 0 12
let now_iso8601 () =
let t = Unix.gettimeofday () in
let tm = Unix.gmtime t in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min tm.tm_sec
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (tm.tm_year + 1900)
+ (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
let current (profile : Profile.t) =
- let repos = List.map (fun path ->
- (path, git_head_sha path)
- ) profile.opam_repositories in
+ let repos =
+ List.map (fun path -> (path, git_head_sha path)) profile.opam_repositories
+ in
let key = compute_key repos in
{ repos; key; created = now_iso8601 () }
let to_json t =
- `Assoc [
- ("repos", `List (List.map (fun (path, sha) ->
- `Assoc [("path", `String path); ("commit", `String sha)]
- ) t.repos));
- ("key", `String t.key);
- ("created", `String t.created);
- ]
+ `Assoc
+ [
+ ( "repos",
+ `List
+ (List.map
+ (fun (path, sha) ->
+ `Assoc [ ("path", `String path); ("commit", `String sha) ])
+ t.repos) );
+ ("key", `String t.key);
+ ("created", `String t.created);
+ ]
let of_json json =
try
let open Yojson.Safe.Util in
- let repos = json |> member "repos" |> to_list |> List.map (fun r ->
- (r |> member "path" |> to_string,
- r |> member "commit" |> to_string)
- ) in
+ let repos =
+ json
+ |> member "repos"
+ |> to_list
+ |> List.map (fun r ->
+ (r |> member "path" |> to_string, r |> member "commit" |> to_string))
+ in
let key = json |> member "key" |> to_string in
let created = json |> member "created" |> to_string in
Ok { repos; key; created }
@@ -58,8 +61,7 @@ let save dir t =
let path = Fpath.(dir / "repos.json") in
try
ignore (Bos.OS.Dir.create ~path:true dir);
- Bos.OS.File.write path
- (Yojson.Safe.pretty_to_string (to_json t))
+ Bos.OS.File.write path (Yojson.Safe.pretty_to_string (to_json t))
with exn ->
Rresult.R.error_msgf "Snapshot.save: %s" (Printexc.to_string exn)
@@ -67,10 +69,10 @@ let load dir =
let path = Fpath.(dir / "repos.json") in
match Bos.OS.File.read path with
| Error _ as e -> e
- | Ok data ->
- try of_json (Yojson.Safe.from_string data)
- with exn ->
- Rresult.R.error_msgf "Snapshot.load: %s" (Printexc.to_string exn)
+ | Ok data -> (
+ try of_json (Yojson.Safe.from_string data)
+ with exn ->
+ Rresult.R.error_msgf "Snapshot.load: %s" (Printexc.to_string exn))
let solutions_dir dir = Fpath.(dir / "solutions")
let packages_dir dir = Fpath.(dir / "packages")
File "day11/batch/snapshot.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/snapshot.mli b/_build/default/day11/batch/.formatted/snapshot.mli
index 8921b15..e8bcf93 100644
--- a/_build/default/day11/batch/snapshot.mli
+++ b/_build/default/day11/batch/.formatted/snapshot.mli
@@ -1,30 +1,27 @@
(** Point-in-time state of all opam repositories within a profile.
- A snapshot captures the git commit SHA of each opam-repository at
- the time of a run. The snapshot key is a hash of all commit SHAs,
- used to identify which solver results and build outcomes belong
- together. Multiple runs may target the same snapshot (e.g. retries
- with [--rebuild-failed]). *)
+ A snapshot captures the git commit SHA of each opam-repository at the time
+ of a run. The snapshot key is a hash of all commit SHAs, used to identify
+ which solver results and build outcomes belong together. Multiple runs may
+ target the same snapshot (e.g. retries with [--rebuild-failed]). *)
type t = {
repos : (string * string) list;
- (** [(repo_path, commit_sha)] for each opam-repository. *)
- key : string;
- (** Hash of all commit SHAs — the snapshot identifier. *)
+ (** [(repo_path, commit_sha)] for each opam-repository. *)
+ key : string; (** Hash of all commit SHAs — the snapshot identifier. *)
created : string;
- (** ISO-8601 UTC timestamp of when the snapshot was first seen. *)
+ (** ISO-8601 UTC timestamp of when the snapshot was first seen. *)
}
val current : Profile.t -> t
-(** [current profile] reads the current HEAD of each opam-repository
- in [profile] and returns a snapshot. If a repo is not a git
- repository, uses ["unknown"] as the commit SHA. *)
+(** [current profile] reads the current HEAD of each opam-repository in
+ [profile] and returns a snapshot. If a repo is not a git repository, uses
+ ["unknown"] as the commit SHA. *)
val compute_key : (string * string) list -> string
-(** [compute_key repos] hashes the commit SHAs into the 12-char
- snapshot key. Callers that already have [(path, sha)] pairs (e.g.
- from a live OCurrent poll) can use this directly rather than
- going through [current]. *)
+(** [compute_key repos] hashes the commit SHAs into the 12-char snapshot key.
+ Callers that already have [(path, sha)] pairs (e.g. from a live OCurrent
+ poll) can use this directly rather than going through [current]. *)
val save : Fpath.t -> t -> (unit, [> Rresult.R.msg ]) result
(** [save dir snapshot] writes [repos.json] into [dir]. *)
File "day11/batch/summary.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/summary.ml b/_build/default/day11/batch/.formatted/summary.ml
index 19d76b8..92d046c 100644
--- a/_build/default/day11/batch/summary.ml
+++ b/_build/default/day11/batch/.formatted/summary.ml
@@ -23,14 +23,14 @@ type results = {
let classify_log log_file =
match log_file with
| None -> ("build_failure", None)
- | Some path ->
- match Bos.OS.File.read path with
- | Error _ -> ("build_failure", None)
- | Ok content ->
- let (_status, category, error) =
- Day11_lib.Classify.classify_build_log content
- in
- (category, error)
+ | Some path -> (
+ match Bos.OS.File.read path with
+ | Error _ -> ("build_failure", None)
+ | Ok content ->
+ let _status, category, error =
+ Day11_lib.Classify.classify_build_log content
+ in
+ (category, error))
(* History writes happen incrementally inside {!Recorder} now. *)
@@ -46,31 +46,28 @@ let finish ~snapshot_dir ~packages_dir ~run_info results =
(* History is written incrementally by [Recorder] now. *)
generate_status ~snapshot_dir ~packages_dir ~run_id;
let builds_ok =
- List.length (List.filter (fun (b : build_outcome) -> b.success) results.builds)
+ List.length
+ (List.filter (fun (b : build_outcome) -> b.success) results.builds)
in
let builds_fail = List.length results.builds - builds_ok in
let docs_ok =
List.length (List.filter (fun (d : doc_outcome) -> d.success) results.docs)
in
let failures =
- List.filter_map (fun (b : build_outcome) ->
- if b.success then None
- else
- let cat, _ = classify_log b.log_file in
- Some (OpamPackage.to_string b.pkg, cat)
- ) results.builds
+ List.filter_map
+ (fun (b : build_outcome) ->
+ if b.success then None
+ else
+ let cat, _ = classify_log b.log_file in
+ Some (OpamPackage.to_string b.pkg, cat))
+ results.builds
in
Printf.printf "Build: %d success, %d failed\n" builds_ok builds_fail;
Printf.printf "Docs: %d generated\n" docs_ok;
- if failures <> [] then begin
+ if failures <> [] then (
Printf.printf "Failures:\n";
- List.iter (fun (p, cat) ->
- Printf.printf " %s (%s)\n" p cat
- ) failures
- end;
+ List.iter (fun (p, cat) -> Printf.printf " %s (%s)\n" p cat) failures);
Day11_lib.Run_log.finish_run run_info
~targets_requested:(List.length results.targets)
- ~packages_built:builds_ok
- ~packages_failed:builds_fail
- ~docs_generated:docs_ok
- ~failures
+ ~packages_built:builds_ok ~packages_failed:builds_fail
+ ~docs_generated:docs_ok ~failures
File "day11/batch/summary.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/summary.mli b/_build/default/day11/batch/.formatted/summary.mli
index 97089e7..9627dd3 100644
--- a/_build/default/day11/batch/summary.mli
+++ b/_build/default/day11/batch/.formatted/summary.mli
@@ -1,8 +1,7 @@
(** Result aggregation and reporting.
- Collects build and doc outcomes, records them in per-package
- history files, generates the status index, and prints a
- human-readable summary. *)
+ Collects build and doc outcomes, records them in per-package history files,
+ generates the status index, and prints a human-readable summary. *)
type build_outcome = {
pkg : OpamPackage.t;
@@ -27,14 +26,11 @@ type results = {
}
val generate_status :
- snapshot_dir:Fpath.t ->
- packages_dir:Fpath.t ->
- run_id:string ->
- unit
-(** Regenerate [status.json] from current on-disk history, detecting
- changes from the previous snapshot. Safe to call from anywhere
- (e.g. a periodic timer) — it just reads [packages/*/history.jsonl]
- and writes [snapshot_dir/status.json]. *)
+ snapshot_dir:Fpath.t -> packages_dir:Fpath.t -> run_id:string -> unit
+(** Regenerate [status.json] from current on-disk history, detecting changes
+ from the previous snapshot. Safe to call from anywhere (e.g. a periodic
+ timer) — it just reads [packages/*/history.jsonl] and writes
+ [snapshot_dir/status.json]. *)
val finish :
snapshot_dir:Fpath.t ->
@@ -42,7 +38,6 @@ val finish :
run_info:Day11_lib.Run_log.t ->
results ->
Day11_lib.Run_log.summary
-(** [finish ~snapshot_dir ~packages_dir ~run_info results] generates
- status.json from the (already incrementally-written) history,
- finishes the run log, and prints a summary to stdout. Returns
- the run summary. *)
+(** [finish ~snapshot_dir ~packages_dir ~run_info results] generates status.json
+ from the (already incrementally-written) history, finishes the run log, and
+ prints a summary to stdout. Returns the run summary. *)
File "day11/batch/targets.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/targets.ml b/_build/default/day11/batch/.formatted/targets.ml
index c9ce85a..f1cffd2 100644
--- a/_build/default/day11/batch/targets.ml
+++ b/_build/default/day11/batch/.formatted/targets.ml
@@ -1,104 +1,135 @@
-let small_universe = [
- "astring"; "fmt"; "fpath"; "rresult"; "bos"; "logs"; "cmdliner";
- "ptime"; "uutf"; "mtime"; "yojson"; "eio"; "lwt"; "ppxlib";
- "odoc"; "odoc-parser"; "re"; "cstruct"; "bigstringaf";
-]
+let small_universe =
+ [
+ "astring";
+ "fmt";
+ "fpath";
+ "rresult";
+ "bos";
+ "logs";
+ "cmdliner";
+ "ptime";
+ "uutf";
+ "mtime";
+ "yojson";
+ "eio";
+ "lwt";
+ "ppxlib";
+ "odoc";
+ "odoc-parser";
+ "re";
+ "cstruct";
+ "bigstringaf";
+ ]
let find_latest_versions git_packages =
let all_names = Day11_opam.Git_packages.all_names git_packages in
let compiler_names = Day11_opam_layer.Opamh.compiler_packages in
- let all_names = List.filter (fun name ->
- not (List.mem name compiler_names)
- ) all_names in
- List.filter_map (fun name ->
- let versions = Day11_opam.Git_packages.get_versions git_packages name in
- let non_avoided =
- OpamPackage.Version.Map.filter (fun _v opam ->
- not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam)
- ) versions
- in
- let versions = if OpamPackage.Version.Map.is_empty non_avoided
- then versions else non_avoided in
- match OpamPackage.Version.Map.max_binding_opt versions with
- | Some (v, _) -> Some (OpamPackage.create name v)
- | None -> None
- ) all_names
+ let all_names =
+ List.filter (fun name -> not (List.mem name compiler_names)) all_names
+ in
+ List.filter_map
+ (fun name ->
+ let versions = Day11_opam.Git_packages.get_versions git_packages name in
+ let non_avoided =
+ OpamPackage.Version.Map.filter
+ (fun _v opam ->
+ not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam))
+ versions
+ in
+ let versions =
+ if OpamPackage.Version.Map.is_empty non_avoided then versions
+ else non_avoided
+ in
+ match OpamPackage.Version.Map.max_binding_opt versions with
+ | Some (v, _) -> Some (OpamPackage.create name v)
+ | None -> None)
+ all_names
let find_all_versions git_packages =
let all_names = Day11_opam.Git_packages.all_names git_packages in
let compiler_names = Day11_opam_layer.Opamh.compiler_packages in
- let all_names = List.filter (fun name ->
- not (List.mem name compiler_names)
- ) all_names in
- List.concat_map (fun name ->
- let versions = Day11_opam.Git_packages.get_versions git_packages name in
- OpamPackage.Version.Map.fold (fun v _opam acc ->
- OpamPackage.create name v :: acc
- ) versions []
- |> List.rev
- ) all_names
+ let all_names =
+ List.filter (fun name -> not (List.mem name compiler_names)) all_names
+ in
+ List.concat_map
+ (fun name ->
+ let versions = Day11_opam.Git_packages.get_versions git_packages name in
+ OpamPackage.Version.Map.fold
+ (fun v _opam acc -> OpamPackage.create name v :: acc)
+ versions []
+ |> List.rev)
+ all_names
let load_package_list filename =
let json = Yojson.Safe.from_file filename in
let open Yojson.Safe.Util in
- let parse_list l = List.filter_map (fun j ->
- try Some (OpamPackage.of_string (to_string j))
- with _ -> None) l
+ let parse_list l =
+ List.filter_map
+ (fun j -> try Some (OpamPackage.of_string (to_string j)) with _ -> None)
+ l
in
match json with
| `List l -> parse_list l
- | `Assoc _ ->
- (match json |> member "packages" with
- | `List l -> parse_list l
- | _ -> [])
+ | `Assoc _ -> (
+ match json |> member "packages" with `List l -> parse_list l | _ -> [])
| _ -> []
let pick_latest_version git_packages name =
let n = OpamPackage.Name.of_string name in
let versions = Day11_opam.Git_packages.get_versions git_packages n in
let non_avoided =
- OpamPackage.Version.Map.filter (fun _v opam ->
- not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam)
- ) versions in
- let versions = if OpamPackage.Version.Map.is_empty non_avoided
- then versions else non_avoided in
- let candidates = OpamPackage.Version.Map.bindings versions
- |> List.rev in
+ OpamPackage.Version.Map.filter
+ (fun _v opam -> not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam))
+ versions
+ in
+ let versions =
+ if OpamPackage.Version.Map.is_empty non_avoided then versions
+ else non_avoided
+ in
+ let candidates = OpamPackage.Version.Map.bindings versions |> List.rev in
List.map (fun (v, _) -> OpamPackage.create n v) candidates
let resolve ?(small = false) ?(all_versions = false) git_packages target =
match target with
| None when small && all_versions ->
- Printf.printf "Finding all versions of small universe...\n%!";
- let compiler_names = Day11_opam_layer.Opamh.compiler_packages in
- let names = List.filter_map (fun name ->
- let n = OpamPackage.Name.of_string name in
- if List.mem n compiler_names then None else Some n
- ) small_universe in
- List.concat_map (fun name ->
- let versions = Day11_opam.Git_packages.get_versions git_packages name in
- OpamPackage.Version.Map.fold (fun v _opam acc ->
- OpamPackage.create name v :: acc
- ) versions [] |> List.rev
- ) names
+ Printf.printf "Finding all versions of small universe...\n%!";
+ let compiler_names = Day11_opam_layer.Opamh.compiler_packages in
+ let names =
+ List.filter_map
+ (fun name ->
+ let n = OpamPackage.Name.of_string name in
+ if List.mem n compiler_names then None else Some n)
+ small_universe
+ in
+ List.concat_map
+ (fun name ->
+ let versions =
+ Day11_opam.Git_packages.get_versions git_packages name
+ in
+ OpamPackage.Version.Map.fold
+ (fun v _opam acc -> OpamPackage.create name v :: acc)
+ versions []
+ |> List.rev)
+ names
| None when small ->
- Printf.printf "Using small universe (%d packages)...\n%!"
- (List.length small_universe);
- List.filter_map (fun name ->
- match pick_latest_version git_packages name with
- | v :: _ -> Some v
- | [] -> None
- ) small_universe
+ Printf.printf "Using small universe (%d packages)...\n%!"
+ (List.length small_universe);
+ List.filter_map
+ (fun name ->
+ match pick_latest_version git_packages name with
+ | v :: _ -> Some v
+ | [] -> None)
+ small_universe
| None when all_versions ->
- Printf.printf "Finding all package versions...\n%!";
- find_all_versions git_packages
+ Printf.printf "Finding all package versions...\n%!";
+ find_all_versions git_packages
| None ->
- Printf.printf "Finding all latest package versions...\n%!";
- find_latest_versions git_packages
+ Printf.printf "Finding all latest package versions...\n%!";
+ find_latest_versions git_packages
| Some t when String.length t > 0 && t.[0] = '@' ->
- let filename = String.sub t 1 (String.length t - 1) in
- Printf.printf "Loading package list from %s...\n%!" filename;
- load_package_list filename
+ let filename = String.sub t 1 (String.length t - 1) in
+ Printf.printf "Loading package list from %s...\n%!" filename;
+ load_package_list filename
| Some t ->
- Printf.printf "Target: %s\n%!" t;
- [ OpamPackage.of_string t ]
+ Printf.printf "Target: %s\n%!" t;
+ [ OpamPackage.of_string t ]
File "day11/batch/targets.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/targets.mli b/_build/default/day11/batch/.formatted/targets.mli
index 4ab7aa3..dd5bd56 100644
--- a/_build/default/day11/batch/targets.mli
+++ b/_build/default/day11/batch/.formatted/targets.mli
@@ -11,11 +11,10 @@ val small_universe : string list
val pick_latest_version :
Day11_opam.Git_packages.t -> string -> OpamPackage.t list
-(** [pick_latest_version packages name] returns all non-avoid versions
- of [name] from newest to oldest. Used for retry on solve failure. *)
+(** [pick_latest_version packages name] returns all non-avoid versions of [name]
+ from newest to oldest. Used for retry on solve failure. *)
-val find_all_versions :
- Day11_opam.Git_packages.t -> OpamPackage.t list
+val find_all_versions : Day11_opam.Git_packages.t -> OpamPackage.t list
(** All versions of all non-compiler packages. *)
val resolve :
@@ -25,6 +24,5 @@ val resolve :
string option ->
OpamPackage.t list
(** [resolve ?small ?all_versions packages target] resolves the target
- specification to a list of packages. When [all_versions] is true
- and no target is given, returns all versions instead of just the
- latest. *)
+ specification to a list of packages. When [all_versions] is true and no
+ target is given, returns all versions instead of just the latest. *)
File "day11/opam_build/test_noop/test_executor.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_build/test_noop/test_executor.ml b/_build/default/day11/opam_build/test_noop/.formatted/test_executor.ml
index b0a9a6e..0713569 100644
--- a/_build/default/day11/opam_build/test_noop/test_executor.ml
+++ b/_build/default/day11/opam_build/test_noop/.formatted/test_executor.ml
@@ -7,59 +7,78 @@ let () =
let sleep_ms = float_of_string Sys.argv.(3) in
(* Load DAG from JSONL *)
let nodes_by_hash : (string, Day11_opam_layer.Build.t) Hashtbl.t =
- Hashtbl.create 100000 in
+ Hashtbl.create 100000
+ in
let ic = open_in dag_file in
let count = ref 0 in
- (try while true do
- let line = input_line ic in
- let json = Yojson.Safe.from_string line in
- let open Yojson.Safe.Util in
- let hash = json |> member "hash" |> to_string in
- let pkg_str = json |> member "pkg" |> to_string in
- let dep_hashes = json |> member "deps" |> to_list
- |> List.map to_string in
- let pkg = OpamPackage.of_string pkg_str in
- (* Store without deps first, patch later *)
- let node : Day11_opam_layer.Build.t =
- { hash; pkg; deps = []; universe = Day11_solution.Universe.dummy } in
- Hashtbl.replace nodes_by_hash hash node;
- ignore dep_hashes;
- incr count
- done with End_of_file -> close_in ic);
+ (try
+ while true do
+ let line = input_line ic in
+ let json = Yojson.Safe.from_string line in
+ let open Yojson.Safe.Util in
+ let hash = json |> member "hash" |> to_string in
+ let pkg_str = json |> member "pkg" |> to_string in
+ let dep_hashes =
+ json |> member "deps" |> to_list |> List.map to_string
+ in
+ let pkg = OpamPackage.of_string pkg_str in
+ (* Store without deps first, patch later *)
+ let node : Day11_opam_layer.Build.t =
+ { hash; pkg; deps = []; universe = Day11_solution.Universe.dummy }
+ in
+ Hashtbl.replace nodes_by_hash hash node;
+ ignore dep_hashes;
+ incr count
+ done
+ with End_of_file -> close_in ic);
Printf.printf "Loaded %d nodes\n%!" !count;
(* Second pass: resolve deps *)
let ic = open_in dag_file in
- (try while true do
- let line = input_line ic in
- let json = Yojson.Safe.from_string line in
- let open Yojson.Safe.Util in
- let hash = json |> member "hash" |> to_string in
- let dep_hashes = json |> member "deps" |> to_list
- |> List.map to_string in
- let deps = List.filter_map (fun dh ->
- Hashtbl.find_opt nodes_by_hash dh
- ) dep_hashes in
- let pkg = (Hashtbl.find nodes_by_hash hash).pkg in
- Hashtbl.replace nodes_by_hash hash
- { Day11_opam_layer.Build.hash; pkg; deps; universe = Day11_solution.Universe.dummy }
- done with End_of_file -> close_in ic);
- let all_nodes = Hashtbl.fold (fun _ n acc -> n :: acc)
- nodes_by_hash [] in
- let all_nodes = List.sort (fun (a : Day11_opam_layer.Build.t) b ->
- compare (List.length a.deps) (List.length b.deps)) all_nodes in
- Printf.printf "Running executor with %d workers, %.0fms sleep...\n%!" np sleep_ms;
+ (try
+ while true do
+ let line = input_line ic in
+ let json = Yojson.Safe.from_string line in
+ let open Yojson.Safe.Util in
+ let hash = json |> member "hash" |> to_string in
+ let dep_hashes =
+ json |> member "deps" |> to_list |> List.map to_string
+ in
+ let deps =
+ List.filter_map
+ (fun dh -> Hashtbl.find_opt nodes_by_hash dh)
+ dep_hashes
+ in
+ let pkg = (Hashtbl.find nodes_by_hash hash).pkg in
+ Hashtbl.replace nodes_by_hash hash
+ {
+ Day11_opam_layer.Build.hash;
+ pkg;
+ deps;
+ universe = Day11_solution.Universe.dummy;
+ }
+ done
+ with End_of_file -> close_in ic);
+ let all_nodes = Hashtbl.fold (fun _ n acc -> n :: acc) nodes_by_hash [] in
+ let all_nodes =
+ List.sort
+ (fun (a : Day11_opam_layer.Build.t) b ->
+ compare (List.length a.deps) (List.length b.deps))
+ all_nodes
+ in
+ Printf.printf "Running executor with %d workers, %.0fms sleep...\n%!" np
+ sleep_ms;
let active = Atomic.make 0 in
let max_active = Atomic.make 0 in
let t0 = Unix.gettimeofday () in
Eio_main.run @@ fun _env ->
Day11_opam_build.Dag_executor.execute
- (_env :> Eio_unix.Stdenv.base) ~np
+ (_env :> Eio_unix.Stdenv.base)
+ ~np
~on_complete:(fun ~stats ~cached:_ _node _success ->
- if stats.completed mod 1000 = 0 then begin
+ if stats.completed mod 1000 = 0 then
let elapsed = Unix.gettimeofday () -. t0 in
- Printf.printf " [%d/%d] %.1fs max_active=%d\n%!"
- stats.completed stats.total elapsed (Atomic.get max_active)
- end)
+ Printf.printf " [%d/%d] %.1fs max_active=%d\n%!" stats.completed
+ stats.total elapsed (Atomic.get max_active))
~on_cascade:(fun ~failed:_ ~failed_dep:_ -> ())
all_nodes
(fun _node ->
@@ -71,4 +90,5 @@ let () =
ignore (Atomic.fetch_and_add active (-1));
true);
let elapsed = Unix.gettimeofday () -. t0 in
- Printf.printf "Done in %.1fs, max_active=%d\n%!" elapsed (Atomic.get max_active)
+ Printf.printf "Done in %.1fs, max_active=%d\n%!" elapsed
+ (Atomic.get max_active)
File "day11/lib/build_config.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/build_config.ml b/_build/default/day11/lib/.formatted/build_config.ml
index 3df8a8f..98a600c 100644
--- a/_build/default/day11/lib/build_config.ml
+++ b/_build/default/day11/lib/.formatted/build_config.ml
@@ -8,47 +8,79 @@ type t = {
}
let save path t =
- let json = `Assoc [
- ("opam_repositories",
- `List (List.map (fun p -> `String (Fpath.to_string p)) t.opam_repositories));
- ("local_repos",
- `List (List.map (fun (p, pkgs) ->
- `Assoc [ ("path", `String (Fpath.to_string p));
- ("packages", `List (List.map (fun s -> `String s) pkgs)) ]
- ) t.local_repos));
- ("with_doc", `Bool t.with_doc);
- ("with_jtw", `Bool t.with_jtw);
- ("html_output",
- match t.html_output with
- | Some p -> `String (Fpath.to_string p) | None -> `Null);
- ("jtw_output",
- match t.jtw_output with
- | Some p -> `String (Fpath.to_string p) | None -> `Null);
- ] in
+ let json =
+ `Assoc
+ [
+ ( "opam_repositories",
+ `List
+ (List.map
+ (fun p -> `String (Fpath.to_string p))
+ t.opam_repositories) );
+ ( "local_repos",
+ `List
+ (List.map
+ (fun (p, pkgs) ->
+ `Assoc
+ [
+ ("path", `String (Fpath.to_string p));
+ ("packages", `List (List.map (fun s -> `String s) pkgs));
+ ])
+ t.local_repos) );
+ ("with_doc", `Bool t.with_doc);
+ ("with_jtw", `Bool t.with_jtw);
+ ( "html_output",
+ match t.html_output with
+ | Some p -> `String (Fpath.to_string p)
+ | None -> `Null );
+ ( "jtw_output",
+ match t.jtw_output with
+ | Some p -> `String (Fpath.to_string p)
+ | None -> `Null );
+ ]
+ in
Bos.OS.File.write path (Yojson.Safe.to_string json)
let load path =
match Bos.OS.File.read path with
| Error _ as e -> e
- | Ok data ->
- try
- let json = Yojson.Safe.from_string data in
- let open Yojson.Safe.Util in
- let opam_repositories =
- json |> member "opam_repositories" |> to_list
- |> List.map (fun j -> Fpath.v (to_string j)) in
- let local_repos =
- json |> member "local_repos" |> to_list
- |> List.map (fun j ->
- (Fpath.v (j |> member "path" |> to_string),
- j |> member "packages" |> to_list |> List.map to_string)) in
- let with_doc = json |> member "with_doc" |> to_bool in
- let with_jtw = json |> member "with_jtw" |> to_bool in
- let html_output = match json |> member "html_output" with
- | `Null -> None | j -> Some (Fpath.v (to_string j)) in
- let jtw_output = match json |> member "jtw_output" with
- | `Null -> None | j -> Some (Fpath.v (to_string j)) in
- Ok { opam_repositories; local_repos; with_doc; with_jtw;
- html_output; jtw_output }
- with exn ->
- Rresult.R.error_msgf "Build_config.load: %s" (Printexc.to_string exn)
+ | Ok data -> (
+ try
+ let json = Yojson.Safe.from_string data in
+ let open Yojson.Safe.Util in
+ let opam_repositories =
+ json
+ |> member "opam_repositories"
+ |> to_list
+ |> List.map (fun j -> Fpath.v (to_string j))
+ in
+ let local_repos =
+ json
+ |> member "local_repos"
+ |> to_list
+ |> List.map (fun j ->
+ ( Fpath.v (j |> member "path" |> to_string),
+ j |> member "packages" |> to_list |> List.map to_string ))
+ in
+ let with_doc = json |> member "with_doc" |> to_bool in
+ let with_jtw = json |> member "with_jtw" |> to_bool in
+ let html_output =
+ match json |> member "html_output" with
+ | `Null -> None
+ | j -> Some (Fpath.v (to_string j))
+ in
+ let jtw_output =
+ match json |> member "jtw_output" with
+ | `Null -> None
+ | j -> Some (Fpath.v (to_string j))
+ in
+ Ok
+ {
+ opam_repositories;
+ local_repos;
+ with_doc;
+ with_jtw;
+ html_output;
+ jtw_output;
+ }
+ with exn ->
+ Rresult.R.error_msgf "Build_config.load: %s" (Printexc.to_string exn))
File "day11/lib/build_config.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/build_config.mli b/_build/default/day11/lib/.formatted/build_config.mli
index 7c7b064..ff09335 100644
--- a/_build/default/day11/lib/build_config.mli
+++ b/_build/default/day11/lib/.formatted/build_config.mli
@@ -1,7 +1,7 @@
(** Build configuration persistence.
- Saves batch run parameters so rerun/cascade commands don't
- need CLI arguments. *)
+ Saves batch run parameters so rerun/cascade commands don't need CLI
+ arguments. *)
type t = {
opam_repositories : Fpath.t list;
File "day11/lib/build_lock.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/build_lock.ml b/_build/default/day11/lib/.formatted/build_lock.ml
index d335c7d..74eaf06 100644
--- a/_build/default/day11/lib/build_lock.ml
+++ b/_build/default/day11/lib/.formatted/build_lock.ml
@@ -19,52 +19,62 @@ let parse_lock_filename filename =
let base = Filename.chop_suffix filename ".lock" in
let parse_pkg_ver_universe rest =
match String.rindex_opt rest '-' with
- | Some i when String.length rest - i - 1 = 32 ->
+ | Some i when String.length rest - i - 1 = 32 -> (
let pkg_ver = String.sub rest 0 i in
let universe = String.sub rest (i + 1) (String.length rest - i - 1) in
- (match String.rindex_opt pkg_ver '.' with
- | None -> None
- | Some j ->
- let package = String.sub pkg_ver 0 j in
- let version = String.sub pkg_ver (j + 1) (String.length pkg_ver - j - 1) in
- Some (package, version, Some universe))
- | _ ->
- (match String.rindex_opt rest '.' with
- | None -> None
- | Some i ->
- let package = String.sub rest 0 i in
- let version = String.sub rest (i + 1) (String.length rest - i - 1) in
- Some (package, version, None))
+ match String.rindex_opt pkg_ver '.' with
+ | None -> None
+ | Some j ->
+ let package = String.sub pkg_ver 0 j in
+ let version =
+ String.sub pkg_ver (j + 1) (String.length pkg_ver - j - 1)
+ in
+ Some (package, version, Some universe))
+ | _ -> (
+ match String.rindex_opt rest '.' with
+ | None -> None
+ | Some i ->
+ let package = String.sub rest 0 i in
+ let version =
+ String.sub rest (i + 1) (String.length rest - i - 1)
+ in
+ Some (package, version, None))
in
if String.length base > 6 && String.sub base 0 6 = "build-" then
let rest = String.sub base 6 (String.length base - 6) in
parse_pkg_ver_universe rest
- |> Option.map (fun (package, version, universe) -> (Build, package, version, universe))
+ |> Option.map (fun (package, version, universe) ->
+ (Build, package, version, universe))
else if String.length base > 4 && String.sub base 0 4 = "doc-" then
let rest = String.sub base 4 (String.length base - 4) in
parse_pkg_ver_universe rest
- |> Option.map (fun (package, version, universe) -> (Doc, package, version, universe))
+ |> Option.map (fun (package, version, universe) ->
+ (Doc, package, version, universe))
else if String.length base > 5 && String.sub base 0 5 = "tool-" then
let rest = String.sub base 5 (String.length base - 5) in
match String.rindex_opt rest '-' with
| Some i ->
let name = String.sub rest 0 i in
- let ocaml_ver = String.sub rest (i + 1) (String.length rest - i - 1) in
+ let ocaml_ver =
+ String.sub rest (i + 1) (String.length rest - i - 1)
+ in
if String.contains ocaml_ver '.' then
Some (Tool, name, "0", Some ocaml_ver)
- else
- Some (Tool, rest, "0", None)
- | None ->
- Some (Tool, rest, "0", None)
- else
- None
+ else Some (Tool, rest, "0", None)
+ | None -> Some (Tool, rest, "0", None)
+ else None
let is_lock_held lock_path =
try
- let fd = Unix.openfile lock_path [Unix.O_RDONLY] 0o644 in
+ let fd = Unix.openfile lock_path [ Unix.O_RDONLY ] 0o644 in
let held =
- try Unix.lockf fd Unix.F_TEST 0; false
- with Unix.Unix_error (Unix.EAGAIN, _, _) | Unix.Unix_error (Unix.EACCES, _, _) -> true
+ try
+ Unix.lockf fd Unix.F_TEST 0;
+ false
+ with
+ | Unix.Unix_error (Unix.EAGAIN, _, _) | Unix.Unix_error (Unix.EACCES, _, _)
+ ->
+ true
in
Unix.close fd;
held
@@ -79,30 +89,48 @@ let list_active ~cache_dir =
|> Array.to_list
|> List.filter (fun name -> Filename.check_suffix name ".lock")
|> List.filter_map (fun filename ->
- let path = Filename.concat locks_dir filename in
- match parse_lock_filename filename with
- | None -> None
- | Some (stage, package, version, universe) ->
- if is_lock_held path then
- try
- let content = In_channel.with_open_text path In_channel.input_all in
- let lines = String.split_on_char '\n' content in
- match lines with
- | pid_str :: time_str :: rest ->
- let pid = int_of_string (String.trim pid_str) in
- let start_time = float_of_string (String.trim time_str) in
- let layer_name = match rest with
- | s :: _ when String.trim s <> "" -> Some (String.trim s)
- | _ -> None
- in
- let temp_log_path = match rest with
- | _ :: s :: _ when String.trim s <> "" -> Some (String.trim s)
- | _ -> None
- in
- Some { stage; package; version; universe; pid; start_time; layer_name; temp_log_path }
- | _ -> None
- with _ -> None
- else None)
+ let path = Filename.concat locks_dir filename in
+ match parse_lock_filename filename with
+ | None -> None
+ | Some (stage, package, version, universe) ->
+ if is_lock_held path then
+ try
+ let content =
+ In_channel.with_open_text path In_channel.input_all
+ in
+ let lines = String.split_on_char '\n' content in
+ match lines with
+ | pid_str :: time_str :: rest ->
+ let pid = int_of_string (String.trim pid_str) in
+ let start_time =
+ float_of_string (String.trim time_str)
+ in
+ let layer_name =
+ match rest with
+ | s :: _ when String.trim s <> "" ->
+ Some (String.trim s)
+ | _ -> None
+ in
+ let temp_log_path =
+ match rest with
+ | _ :: s :: _ when String.trim s <> "" ->
+ Some (String.trim s)
+ | _ -> None
+ in
+ Some
+ {
+ stage;
+ package;
+ version;
+ universe;
+ pid;
+ start_time;
+ layer_name;
+ temp_log_path;
+ }
+ | _ -> None
+ with _ -> None
+ else None)
with _ -> []
let cleanup_stale ~cache_dir =
@@ -111,8 +139,8 @@ let cleanup_stale ~cache_dir =
try
Sys.readdir locks_dir
|> Array.iter (fun filename ->
- if Filename.check_suffix filename ".lock" then
- let path = Filename.concat locks_dir filename in
- if not (is_lock_held path) then
- try Unix.unlink path with _ -> ())
+ if Filename.check_suffix filename ".lock" then
+ let path = Filename.concat locks_dir filename in
+ if not (is_lock_held path) then
+ try Unix.unlink path with _ -> ())
with _ -> ()
File "day11/lib/build_lock.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/build_lock.mli b/_build/default/day11/lib/.formatted/build_lock.mli
index e3407d1..d3598e5 100644
--- a/_build/default/day11/lib/build_lock.mli
+++ b/_build/default/day11/lib/.formatted/build_lock.mli
@@ -1,14 +1,13 @@
(** Lock file tracking and management.
- Each in-progress build acquires a file lock under
- [<cache_dir>/locks/]. This module queries those lock files to report
- what is currently building, and can clean up stale locks left by
- crashed processes. Used by the web dashboard and CLI status commands. *)
+ Each in-progress build acquires a file lock under [<cache_dir>/locks/]. This
+ module queries those lock files to report what is currently building, and
+ can clean up stale locks left by crashed processes. Used by the web
+ dashboard and CLI status commands. *)
(** The build stage a lock belongs to. *)
type stage = Build | Doc | Tool
-(** Metadata parsed from a held lock file. *)
type lock_info = {
stage : stage;
package : string;
@@ -19,12 +18,13 @@ type lock_info = {
layer_name : string option;
temp_log_path : string option;
}
+(** Metadata parsed from a held lock file. *)
-(** Return metadata for every currently-held lock in [cache_dir]. *)
val list_active : cache_dir:string -> lock_info list
+(** Return metadata for every currently-held lock in [cache_dir]. *)
-(** Remove lock files whose owning process is no longer running. *)
val cleanup_stale : cache_dir:string -> unit
+(** Remove lock files whose owning process is no longer running. *)
-(** Test whether the lock at the given path is currently held by a process. *)
val is_lock_held : string -> bool
+(** Test whether the lock at the given path is currently held by a process. *)
File "day11/lib/cascade.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/cascade.ml b/_build/default/day11/lib/.formatted/cascade.ml
index 07b7d0d..70bcaba 100644
--- a/_build/default/day11/lib/cascade.ml
+++ b/_build/default/day11/lib/.formatted/cascade.ml
@@ -1,36 +1,27 @@
-type status =
- | Ok
- | Failed
- | Cascade of string
- | Pending
+type status = Ok | Failed | Cascade of string | Pending
+type result = { status : status; pkg : OpamPackage.t; kind : Dag_marshal.kind }
-type result = {
- status : status;
- pkg : OpamPackage.t;
- kind : Dag_marshal.kind;
-}
-
-(** Build [pkg → (build_hash → entry)] from disk, scanning each unique
- package once. Latest entry per hash wins (matches
- {!History.read_latest}). *)
+(** Build [pkg → (build_hash → entry)] from disk, scanning each unique package
+ once. Latest entry per hash wins (matches {!History.read_latest}). *)
let load_history_index ~packages_dir entries =
let by_pkg : (string, (string, History.entry) Hashtbl.t) Hashtbl.t =
- Hashtbl.create 64 in
+ Hashtbl.create 64
+ in
let load_pkg pkg_str =
if Hashtbl.mem by_pkg pkg_str then ()
- else begin
+ else
let entries = History.read_latest ~packages_dir ~pkg_str in
let tbl = Hashtbl.create (List.length entries) in
- List.iter (fun (h : History.entry) ->
- if not (Hashtbl.mem tbl h.build_hash) then
- Hashtbl.add tbl h.build_hash h
- ) entries;
+ List.iter
+ (fun (h : History.entry) ->
+ if not (Hashtbl.mem tbl h.build_hash) then
+ Hashtbl.add tbl h.build_hash h)
+ entries;
Hashtbl.add by_pkg pkg_str tbl
- end
in
- List.iter (fun (e : Dag_marshal.entry) ->
- load_pkg (OpamPackage.to_string e.pkg)
- ) entries;
+ List.iter
+ (fun (e : Dag_marshal.entry) -> load_pkg (OpamPackage.to_string e.pkg))
+ entries;
by_pkg
let lookup_history index pkg hash =
@@ -51,50 +42,55 @@ type direct = D_ok | D_failed | D_unrun
[direct_status] (per-package history vs. on-disk layer status). *)
let classify_dfs ~direct_status entries =
let by_hash : (string, Dag_marshal.entry) Hashtbl.t =
- Hashtbl.create (List.length entries) in
- List.iter (fun (e : Dag_marshal.entry) ->
- Hashtbl.replace by_hash e.hash e) entries;
+ Hashtbl.create (List.length entries)
+ in
+ List.iter
+ (fun (e : Dag_marshal.entry) -> Hashtbl.replace by_hash e.hash e)
+ entries;
let table : (string, result) Hashtbl.t =
- Hashtbl.create (List.length entries) in
+ Hashtbl.create (List.length entries)
+ in
let visiting : (string, unit) Hashtbl.t = Hashtbl.create 64 in
let rec classify_one h =
match Hashtbl.find_opt table h with
| Some r -> Some r
- | None ->
- match Hashtbl.find_opt by_hash h with
- | None -> None
- | Some e ->
- if Hashtbl.mem visiting h then begin
- (* DAG cycle — shouldn't happen, but stay safe. *)
- let r = { status = Pending; pkg = e.pkg; kind = e.kind } in
- Hashtbl.replace table h r;
- Some r
- end else begin
- Hashtbl.add visiting h ();
- List.iter (fun dh -> ignore (classify_one dh)) e.deps;
- Hashtbl.remove visiting h;
- let status = match direct_status e h with
- | D_ok -> Ok
- | D_failed -> Failed
- | D_unrun ->
- (match
- List.find_map (fun dh ->
- match Hashtbl.find_opt table dh with
- | Some { status = Failed; _ } -> Some dh
- | Some { status = Cascade src; _ } -> Some src
- | _ -> None
- ) e.deps
- with
- | Some src -> Cascade src
- | None -> Pending)
- in
- let r = { status; pkg = e.pkg; kind = e.kind } in
- Hashtbl.replace table h r;
- Some r
- end
+ | None -> (
+ match Hashtbl.find_opt by_hash h with
+ | None -> None
+ | Some e ->
+ if Hashtbl.mem visiting h then (
+ (* DAG cycle — shouldn't happen, but stay safe. *)
+ let r = { status = Pending; pkg = e.pkg; kind = e.kind } in
+ Hashtbl.replace table h r;
+ Some r)
+ else (
+ Hashtbl.add visiting h ();
+ List.iter (fun dh -> ignore (classify_one dh)) e.deps;
+ Hashtbl.remove visiting h;
+ let status =
+ match direct_status e h with
+ | D_ok -> Ok
+ | D_failed -> Failed
+ | D_unrun -> (
+ match
+ List.find_map
+ (fun dh ->
+ match Hashtbl.find_opt table dh with
+ | Some { status = Failed; _ } -> Some dh
+ | Some { status = Cascade src; _ } -> Some src
+ | _ -> None)
+ e.deps
+ with
+ | Some src -> Cascade src
+ | None -> Pending)
+ in
+ let r = { status; pkg = e.pkg; kind = e.kind } in
+ Hashtbl.replace table h r;
+ Some r))
in
- List.iter (fun (e : Dag_marshal.entry) ->
- ignore (classify_one e.hash)) entries;
+ List.iter
+ (fun (e : Dag_marshal.entry) -> ignore (classify_one e.hash))
+ entries;
table
let classify ~packages_dir entries =
@@ -119,7 +115,7 @@ let classify_from_layer_index ~status_index entries =
match Hashtbl.find_opt status_index key with
| None -> D_unrun
| Some (e : Day11_layer.Layer_status.entry) ->
- if e.exit_status = 0 then D_ok else D_failed
+ if e.exit_status = 0 then D_ok else D_failed
in
classify_dfs ~direct_status entries
File "day11/lib/cascade.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/cascade.mli b/_build/default/day11/lib/.formatted/cascade.mli
index 7ca30be..57f0d12 100644
--- a/_build/default/day11/lib/cascade.mli
+++ b/_build/default/day11/lib/.formatted/cascade.mli
@@ -1,63 +1,46 @@
(** Offline cascade attribution.
- Given a planned DAG ([<snapshot_dir>/dag.json] via {!Dag_marshal})
- and the per-package history files, classify every node as one of:
+ Given a planned DAG ([<snapshot_dir>/dag.json] via {!Dag_marshal}) and the
+ per-package history files, classify every node as one of:
- [Ok]: ran and succeeded (history records [status=success])
- - [Failed]: ran and failed (history records [status=failure]) — a
- root cause
+ - [Failed]: ran and failed (history records [status=failure]) — a root cause
- [Cascade source_hash]: did not run because a failed ancestor;
- [source_hash] points at the closest [Failed] node in the
- ancestry chain
- - [Pending]: did not run, and no failed ancestor explains why
- (the node is in-flight, or the run hasn't reached it yet)
-
- Cascades are derived, not stored. The recorder writes only "this
- node ran" entries; everything else is recovered here. *)
-
-type status =
- | Ok
- | Failed
- | Cascade of string
- | Pending
-
-type result = {
- status : status;
- pkg : OpamPackage.t;
- kind : Dag_marshal.kind;
-}
+ [source_hash] points at the closest [Failed] node in the ancestry chain
+ - [Pending]: did not run, and no failed ancestor explains why (the node is
+ in-flight, or the run hasn't reached it yet)
+
+ Cascades are derived, not stored. The recorder writes only "this node ran"
+ entries; everything else is recovered here. *)
+
+type status = Ok | Failed | Cascade of string | Pending
+type result = { status : status; pkg : OpamPackage.t; kind : Dag_marshal.kind }
val classify :
- packages_dir:Fpath.t ->
- Dag_marshal.entry list ->
- (string, result) Hashtbl.t
-(** [classify ~packages_dir entries] returns a hash → result table for
- every entry. Reads each unique package's [history.jsonl] once. *)
+ packages_dir:Fpath.t -> Dag_marshal.entry list -> (string, result) Hashtbl.t
+(** [classify ~packages_dir entries] returns a hash → result table for every
+ entry. Reads each unique package's [history.jsonl] once. *)
val classify_from_layers :
- os_dir:Fpath.t ->
- Dag_marshal.entry list ->
- (string, result) Hashtbl.t
-(** [classify_from_layers ~os_dir entries] returns a comprehensive
- hash → result table derived from on-disk layer state — answering
- "what's the persistent state of this DAG", independent of which
- nodes happened to dispatch in any particular run.
+ os_dir:Fpath.t -> Dag_marshal.entry list -> (string, result) Hashtbl.t
+(** [classify_from_layers ~os_dir entries] returns a comprehensive hash → result
+ table derived from on-disk layer state — answering "what's the persistent
+ state of this DAG", independent of which nodes happened to dispatch in any
+ particular run.
- A layer is considered [Ok] iff the layer dir's [layer.json] exists
- and reports [exit_status = 0]; [Failed] if the layer dir exists
- with non-zero exit status; otherwise the node didn't run, and we
- walk its deps to find a [Failed]/[Cascade] ancestor (root cause)
- or report [Pending]. *)
+ A layer is considered [Ok] iff the layer dir's [layer.json] exists and
+ reports [exit_status = 0]; [Failed] if the layer dir exists with non-zero
+ exit status; otherwise the node didn't run, and we walk its deps to find a
+ [Failed]/[Cascade] ancestor (root cause) or report [Pending]. *)
val classify_from_layer_index :
status_index:(string, Day11_layer.Layer_status.entry) Hashtbl.t ->
Dag_marshal.entry list ->
(string, result) Hashtbl.t
-(** Variant of {!classify_from_layers} that takes a pre-loaded layer
- status index. Hot path for the dashboard, where one [layer_status.jsonl]
- is shared across many snapshot pages. *)
-
-val root_cause :
- (string, result) Hashtbl.t -> string -> string option
-(** Walk a cascade chain to its [Failed] origin. Returns [Some hash]
- if the input is [Cascade _] or [Failed]; [None] otherwise. *)
+(** Variant of {!classify_from_layers} that takes a pre-loaded layer status
+ index. Hot path for the dashboard, where one [layer_status.jsonl] is shared
+ across many snapshot pages. *)
+
+val root_cause : (string, result) Hashtbl.t -> string -> string option
+(** Walk a cascade chain to its [Failed] origin. Returns [Some hash] if the
+ input is [Cascade _] or [Failed]; [None] otherwise. *)
File "day11/lib/classify.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/classify.ml b/_build/default/day11/lib/.formatted/classify.ml
index 4d7d2d9..a05634f 100644
--- a/_build/default/day11/lib/classify.ml
+++ b/_build/default/day11/lib/.formatted/classify.ml
@@ -17,45 +17,49 @@ let matches_any patterns text =
let extract_compiler_from_deps json =
let open Yojson.Safe.Util in
let deps =
- try json |> member "deps" |> to_list |> List.map to_string
- with _ -> []
+ try json |> member "deps" |> to_list |> List.map to_string with _ -> []
in
let compiler_pkg =
- List.find_opt (fun dep ->
- let name =
- try String.sub dep 0 (String.index dep '.')
- with Not_found -> dep
- in
- name = "ocaml-base-compiler" || name = "ocaml-variants"
- ) deps
+ List.find_opt
+ (fun dep ->
+ let name =
+ try String.sub dep 0 (String.index dep '.') with Not_found -> dep
+ in
+ name = "ocaml-base-compiler" || name = "ocaml-variants")
+ deps
in
match compiler_pkg with
- | Some pkg ->
- (try
- let dot = String.index pkg '.' in
- String.sub pkg (dot + 1) (String.length pkg - dot - 1)
- with Not_found -> pkg)
+ | Some pkg -> (
+ try
+ let dot = String.index pkg '.' in
+ String.sub pkg (dot + 1) (String.length pkg - dot - 1)
+ with Not_found -> pkg)
| None -> ""
let classify_build_log log_content =
- let transient_patterns = [
- "No space left on device";
- "Connection timed out";
- "Could not resolve host";
- "Temporary failure in name resolution";
- "Network is unreachable";
- ] in
- let depext_patterns = [
- "Unable to locate package";
- "is not available";
- "unmet dependencies";
- "dpkg: dependency problems";
- ] in
+ let transient_patterns =
+ [
+ "No space left on device";
+ "Connection timed out";
+ "Could not resolve host";
+ "Temporary failure in name resolution";
+ "Network is unreachable";
+ ]
+ in
+ let depext_patterns =
+ [
+ "Unable to locate package";
+ "is not available";
+ "unmet dependencies";
+ "dpkg: dependency problems";
+ ]
+ in
if matches_any transient_patterns log_content then
- ("failure", "transient_failure",
- Some "Transient infrastructure failure detected in build log")
+ ( "failure",
+ "transient_failure",
+ Some "Transient infrastructure failure detected in build log" )
else if matches_any depext_patterns log_content then
- ("failure", "depext_unavailable",
- Some "Missing system dependency detected in build log")
- else
- ("failure", "build_failure", None)
+ ( "failure",
+ "depext_unavailable",
+ Some "Missing system dependency detected in build log" )
+ else ("failure", "build_failure", None)
File "day11/lib/classify.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/classify.mli b/_build/default/day11/lib/.formatted/classify.mli
index 91ad4d0..bb91633 100644
--- a/_build/default/day11/lib/classify.mli
+++ b/_build/default/day11/lib/.formatted/classify.mli
@@ -1,25 +1,22 @@
(** Build failure classification.
- Scans build log content for known failure patterns to categorize
- failures as transient infrastructure issues, missing system
- dependencies, or genuine build failures. *)
+ Scans build log content for known failure patterns to categorize failures as
+ transient infrastructure issues, missing system dependencies, or genuine
+ build failures. *)
-val classify_build_log :
- string -> string * string * string option
-(** [classify_build_log content] returns [(status, category, error_opt)]
- where:
+val classify_build_log : string -> string * string * string option
+(** [classify_build_log content] returns [(status, category, error_opt)] where:
- [status] is ["failure"]
- - [category] is one of ["transient_failure"], ["depext_unavailable"],
- or ["build_failure"]
+ - [category] is one of ["transient_failure"], ["depext_unavailable"], or
+ ["build_failure"]
- [error_opt] is an optional human-radable description *)
-val extract_compiler_from_deps :
- Yojson.Safe.t -> string
-(** [extract_compiler_from_deps json] extracts the compiler version
- from a layer.json's [deps] field. Looks for packages starting
- with [ocaml-base-compiler] or [ocaml-variants]. Returns [""] if
- no compiler is found. *)
+val extract_compiler_from_deps : Yojson.Safe.t -> string
+(** [extract_compiler_from_deps json] extracts the compiler version from a
+ layer.json's [deps] field. Looks for packages starting with
+ [ocaml-base-compiler] or [ocaml-variants]. Returns [""] if no compiler is
+ found. *)
val matches_any : string list -> string -> bool
-(** [matches_any patterns text] returns [true] if any pattern in
- [patterns] is a case-insensitive substring of [text]. *)
+(** [matches_any patterns text] returns [true] if any pattern in [patterns] is a
+ case-insensitive substring of [text]. *)
File "day11/lib/dag_marshal.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/dag_marshal.ml b/_build/default/day11/lib/.formatted/dag_marshal.ml
index 243c085..9f47347 100644
--- a/_build/default/day11/lib/dag_marshal.ml
+++ b/_build/default/day11/lib/.formatted/dag_marshal.ml
@@ -6,14 +6,14 @@ type entry = {
kind : kind;
deps : string list;
universe : string;
- (** Real output universe of this node — [compute_universe_hash] of the
- node's build-layer hash, i.e. the [u/<universe>/...] path the docs
- land in. ["" ] for nodes with no meaningful universe (tools) or
- old dag.json files written before this field existed. *)
+ (** Real output universe of this node — [compute_universe_hash] of the
+ node's build-layer hash, i.e. the [u/<universe>/...] path the docs
+ land in. ["" ] for nodes with no meaningful universe (tools) or old
+ dag.json files written before this field existed. *)
blessed : bool;
- (** Whether this node's universe is the blessed one for its package
- (the per-universe blessing decision, not package-level). [false]
- for nodes from dag.json files predating this field. *)
+ (** Whether this node's universe is the blessed one for its package (the
+ per-universe blessing decision, not package-level). [false] for nodes
+ from dag.json files predating this field. *)
}
let kind_to_string = function
@@ -34,20 +34,19 @@ let kind_of_string = function
let path snapshot_dir = Fpath.(snapshot_dir / "dag.json")
let entry_to_json (e : entry) : Yojson.Safe.t =
- `Assoc [
- "hash", `String e.hash;
- "pkg", `String (OpamPackage.to_string e.pkg);
- "kind", `String (kind_to_string e.kind);
- "deps", `List (List.map (fun h -> `String h) e.deps);
- "universe", `String e.universe;
- "blessed", `Bool e.blessed;
- ]
+ `Assoc
+ [
+ ("hash", `String e.hash);
+ ("pkg", `String (OpamPackage.to_string e.pkg));
+ ("kind", `String (kind_to_string e.kind));
+ ("deps", `List (List.map (fun h -> `String h) e.deps));
+ ("universe", `String e.universe);
+ ("blessed", `Bool e.blessed);
+ ]
let to_json entries : Yojson.Safe.t =
- `Assoc [
- "version", `Int 1;
- "nodes", `List (List.map entry_to_json entries);
- ]
+ `Assoc
+ [ ("version", `Int 1); ("nodes", `List (List.map entry_to_json entries)) ]
let write ~snapshot_dir entries =
let p = path snapshot_dir in
@@ -62,7 +61,8 @@ let entry_of_json (j : Yojson.Safe.t) =
let pkg_s = j |> member "pkg" |> to_string in
let pkg = OpamPackage.of_string pkg_s in
let kind_s = j |> member "kind" |> to_string in
- let kind = match kind_of_string kind_s with
+ let kind =
+ match kind_of_string kind_s with
| Some k -> k
| None -> failwith (Printf.sprintf "unknown kind %S" kind_s)
in
@@ -88,22 +88,22 @@ let read ~snapshot_dir =
let p = path snapshot_dir in
match Bos.OS.File.read p with
| Error _ as e -> e
- | Ok data ->
- try
- let json = Yojson.Safe.from_string data in
- let nodes_j =
- json |> Yojson.Safe.Util.member "nodes" |> Yojson.Safe.Util.to_list
- in
- let rec collect = function
- | [] -> Ok []
- | x :: xs ->
- (match entry_of_json x with
- | Error e -> Error e
- | Ok e ->
- match collect xs with
- | Error err -> Error err
- | Ok rest -> Ok (e :: rest))
- in
- collect nodes_j
- with exn ->
- Rresult.R.error_msgf "Dag_marshal.read: %s" (Printexc.to_string exn)
+ | Ok data -> (
+ try
+ let json = Yojson.Safe.from_string data in
+ let nodes_j =
+ json |> Yojson.Safe.Util.member "nodes" |> Yojson.Safe.Util.to_list
+ in
+ let rec collect = function
+ | [] -> Ok []
+ | x :: xs -> (
+ match entry_of_json x with
+ | Error e -> Error e
+ | Ok e -> (
+ match collect xs with
+ | Error err -> Error err
+ | Ok rest -> Ok (e :: rest)))
+ in
+ collect nodes_j
+ with exn ->
+ Rresult.R.error_msgf "Dag_marshal.read: %s" (Printexc.to_string exn))
File "day11/lib/dag_marshal.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/dag_marshal.mli b/_build/default/day11/lib/.formatted/dag_marshal.mli
index a22dd47..dd8b0b6 100644
--- a/_build/default/day11/lib/dag_marshal.mli
+++ b/_build/default/day11/lib/.formatted/dag_marshal.mli
@@ -1,16 +1,16 @@
(** Persist the planned doc DAG to [<snapshot_dir>/dag.json] so cascade
attribution can be recovered offline.
- The DAG is computed once per snapshot (a fixed point of opam-repo
- SHAs + profile config), so the on-disk file is also written once
- per snapshot — re-running a snapshot's pipeline overwrites
- identically since all node hashes are content-derived.
+ The DAG is computed once per snapshot (a fixed point of opam-repo SHAs +
+ profile config), so the on-disk file is also written once per snapshot —
+ re-running a snapshot's pipeline overwrites identically since all node
+ hashes are content-derived.
- Cascade attribution from the JSON: for any node whose layer-on-disk
- is missing, walk [deps] transitively to find the first ancestor
- that ran and failed. That ancestor is the root cause; everything
- in between is a cascade. No need to record cascades to disk —
- they're a derived view of (DAG ∩ on-disk layer state). *)
+ Cascade attribution from the JSON: for any node whose layer-on-disk is
+ missing, walk [deps] transitively to find the first ancestor that ran and
+ failed. That ancestor is the root cause; everything in between is a cascade.
+ No need to record cascades to disk — they're a derived view of (DAG ∩
+ on-disk layer state). *)
type kind = Build | Tool | Compile | Doc_all | Link
@@ -19,29 +19,25 @@ type entry = {
pkg : OpamPackage.t;
kind : kind;
deps : string list;
- (** Hashes of direct dependencies, in plan-construction order. *)
+ (** Hashes of direct dependencies, in plan-construction order. *)
universe : string;
- (** Real output universe — [Day11_doc.Command.compute_universe_hash] of
- the node's build-layer hash, i.e. the [u/<universe>/...] path the
- docs land in (matches the [--parent-id u/...] in the build log).
- ["" ] for tool nodes and for dag.json files predating this field. *)
+ (** Real output universe — [Day11_doc.Command.compute_universe_hash] of
+ the node's build-layer hash, i.e. the [u/<universe>/...] path the docs
+ land in (matches the [--parent-id u/...] in the build log). ["" ] for
+ tool nodes and for dag.json files predating this field. *)
blessed : bool;
- (** Whether this node's universe is the blessed one for its package
- (per-universe, not the package-level [is_blessed]). [false] for
- dag.json files predating this field. *)
+ (** Whether this node's universe is the blessed one for its package
+ (per-universe, not the package-level [is_blessed]). [false] for
+ dag.json files predating this field. *)
}
val path : Fpath.t -> Fpath.t
(** [path snapshot_dir] returns the canonical [dag.json] location. *)
val write :
- snapshot_dir:Fpath.t ->
- entry list ->
- (unit, [> Rresult.R.msg ]) result
+ snapshot_dir:Fpath.t -> entry list -> (unit, [> Rresult.R.msg ]) result
(** [write ~snapshot_dir entries] serialises [entries] to
[<snapshot_dir>/dag.json]. Overwrites any existing file. *)
-val read :
- snapshot_dir:Fpath.t ->
- (entry list, [> Rresult.R.msg ]) result
+val read : snapshot_dir:Fpath.t -> (entry list, [> Rresult.R.msg ]) result
(** [read ~snapshot_dir] reads [<snapshot_dir>/dag.json]. *)
File "day11/lib/disk_usage.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/disk_usage.ml b/_build/default/day11/lib/.formatted/disk_usage.ml
index 628b01c..375a262 100644
--- a/_build/default/day11/lib/disk_usage.ml
+++ b/_build/default/day11/lib/.formatted/disk_usage.ml
@@ -14,10 +14,11 @@ let dir_size path =
if not (Sys.file_exists path_s) then 0
else
(* Use du -sb for accurate byte count *)
- let ic = Unix.open_process_in
- (Printf.sprintf "du -sb %s 2>/dev/null" (Filename.quote path_s)) in
- let result = try Scanf.sscanf (input_line ic) "%d" Fun.id
- with _ -> 0 in
+ let ic =
+ Unix.open_process_in
+ (Printf.sprintf "du -sb %s 2>/dev/null" (Filename.quote path_s))
+ in
+ let result = try Scanf.sscanf (input_line ic) "%d" Fun.id with _ -> 0 in
ignore (Unix.close_process_in ic);
result
@@ -25,19 +26,18 @@ let sum_matching ~dir prefix =
let dir_s = Fpath.to_string dir in
if not (Sys.file_exists dir_s) then 0
else
- Sys.readdir dir_s |> Array.to_list
+ Sys.readdir dir_s
+ |> Array.to_list
|> List.filter (fun name ->
- String.length name >= String.length prefix
- && String.sub name 0 (String.length prefix) = prefix)
- |> List.fold_left (fun acc name ->
- acc + dir_size Fpath.(dir / name)) 0
+ String.length name >= String.length prefix
+ && String.sub name 0 (String.length prefix) = prefix)
+ |> List.fold_left (fun acc name -> acc + dir_size Fpath.(dir / name)) 0
let is_layer_dir name =
(* Layer dirs are 12-char hex strings (new format) or build-<hex> (legacy) *)
let is_hex c = (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') in
(String.length name = 12 && String.for_all is_hex name)
- || (String.length name > 6
- && String.sub name 0 6 = "build-")
+ || (String.length name > 6 && String.sub name 0 6 = "build-")
let scan ~os_dir ~cache_dir =
let base = dir_size Fpath.(cache_dir / "base") in
@@ -45,10 +45,10 @@ let scan ~os_dir ~cache_dir =
let dir_s = Fpath.to_string os_dir in
if not (Sys.file_exists dir_s) then 0
else
- Sys.readdir dir_s |> Array.to_list
+ Sys.readdir dir_s
+ |> Array.to_list
|> List.filter is_layer_dir
- |> List.fold_left (fun acc name ->
- acc + dir_size Fpath.(os_dir / name)) 0
+ |> List.fold_left (fun acc name -> acc + dir_size Fpath.(os_dir / name)) 0
in
let docs = dir_size Fpath.(os_dir / "odoc-store") in
let jtw = sum_matching ~dir:os_dir "jtw-" in
@@ -65,7 +65,15 @@ let human_size n =
else Printf.sprintf "%d B" n
let pp fmt r =
- Fmt.pf fmt "@[<v>Base: %s@,Builds: %s@,Docs: %s@,JTW: %s@,Solutions: %s@,Logs: %s@,Packages: %s@,Total: %s@]"
+ Fmt.pf fmt
+ "@[<v>Base: %s@,\
+ Builds: %s@,\
+ Docs: %s@,\
+ JTW: %s@,\
+ Solutions: %s@,\
+ Logs: %s@,\
+ Packages: %s@,\
+ Total: %s@]"
(human_size r.base) (human_size r.builds) (human_size r.docs)
(human_size r.jtw) (human_size r.solutions) (human_size r.logs)
(human_size r.packages) (human_size r.total)
File "day11/lib/disk_usage.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/disk_usage.mli b/_build/default/day11/lib/.formatted/disk_usage.mli
index dbd6bba..ec06288 100644
--- a/_build/default/day11/lib/disk_usage.mli
+++ b/_build/default/day11/lib/.formatted/disk_usage.mli
@@ -12,8 +12,7 @@ type report = {
}
val scan : os_dir:Fpath.t -> cache_dir:Fpath.t -> report
-(** [scan ~os_dir ~cache_dir] computes disk usage in bytes for
- each category. *)
+(** [scan ~os_dir ~cache_dir] computes disk usage in bytes for each category. *)
val pp : report Fmt.t
(** Pretty-print a report with human-readable sizes. *)
File "day11/lib/epoch.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/epoch.ml b/_build/default/day11/lib/.formatted/epoch.ml
index b3c6eae..9f8fb56 100644
--- a/_build/default/day11/lib/epoch.ml
+++ b/_build/default/day11/lib/.formatted/epoch.ml
@@ -1,7 +1,4 @@
-type t = {
- hash : string;
- dir : Fpath.t;
-}
+type t = { hash : string; dir : Fpath.t }
(* Manual doc-format version. Bump when day11's doc-generation logic,
HTML layout, or output convention changes *without* a doc-tool change
@@ -21,8 +18,7 @@ let version = "v1"
[tool_hashes] is sorted+deduped so ordering doesn't affect the hash. *)
let compute ~tool_hashes =
let key = String.concat ":" (List.sort_uniq String.compare tool_hashes) in
- Printf.sprintf "%s:%s" version key
- |> Digest.string |> Digest.to_hex
+ Printf.sprintf "%s:%s" version key |> Digest.string |> Digest.to_hex
let create ~base_dir hash =
let dir = Fpath.(base_dir / ("epoch-" ^ hash)) in
@@ -38,7 +34,8 @@ let promote ~base_dir t =
(e.g. /srv). [t.dir] is [base_dir/epoch-<hash>] and the link lives
in [base_dir], so the relative target is "epoch-<hash>/html". *)
let target =
- Filename.concat (Filename.basename (Fpath.to_string t.dir)) "html" in
+ Filename.concat (Filename.basename (Fpath.to_string t.dir)) "html"
+ in
(try Unix.unlink link_s with Unix.Unix_error _ -> ());
Unix.symlink target link_s
@@ -61,32 +58,37 @@ let current ~base_dir =
let gc ~base_dir ~keep =
let base_s = Fpath.to_string base_dir in
let entries =
- try Sys.readdir base_s |> Array.to_list
- with Sys_error _ -> []
+ try Sys.readdir base_s |> Array.to_list with Sys_error _ -> []
+ in
+ let epochs =
+ List.filter_map
+ (fun name ->
+ if String.length name > 6 && String.sub name 0 6 = "epoch-" then
+ let dir = Fpath.(base_dir / name) in
+ let mtime =
+ try (Unix.stat (Fpath.to_string dir)).Unix.st_mtime with _ -> 0.0
+ in
+ Some (name, dir, mtime)
+ else None)
+ entries
in
- let epochs = List.filter_map (fun name ->
- if String.length name > 6 && String.sub name 0 6 = "epoch-" then
- let dir = Fpath.(base_dir / name) in
- let mtime =
- try (Unix.stat (Fpath.to_string dir)).Unix.st_mtime
- with _ -> 0.0
- in
- Some (name, dir, mtime)
- else None
- ) entries in
let sorted = List.sort (fun (_, _, a) (_, _, b) -> compare b a) epochs in
- let to_delete = if List.length sorted > keep then
- List.filteri (fun i _ -> i >= keep) sorted
- else [] in
+ let to_delete =
+ if List.length sorted > keep then List.filteri (fun i _ -> i >= keep) sorted
+ else []
+ in
(* Never delete the currently-live epoch, even if it's older than the
[keep] most-recent — e.g. after a deliberate rollback-promote to a
known-good older epoch. *)
- let to_delete = match current ~base_dir with
+ let to_delete =
+ match current ~base_dir with
| Some live ->
- List.filter (fun (_, dir, _) -> not (Fpath.equal dir live.dir)) to_delete
+ List.filter
+ (fun (_, dir, _) -> not (Fpath.equal dir live.dir))
+ to_delete
| None -> to_delete
in
- List.iter (fun (_, dir, _) ->
- Bos.OS.Dir.delete ~recurse:true dir |> ignore
- ) to_delete;
+ List.iter
+ (fun (_, dir, _) -> Bos.OS.Dir.delete ~recurse:true dir |> ignore)
+ to_delete;
List.length to_delete
File "day11/lib/epoch.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/epoch.mli b/_build/default/day11/lib/.formatted/epoch.mli
index b71b95c..4391b92 100644
--- a/_build/default/day11/lib/epoch.mli
+++ b/_build/default/day11/lib/.formatted/epoch.mli
@@ -1,40 +1,35 @@
(** Epoch management for atomic documentation deployment.
- An epoch is a versioned collection of documentation artifacts.
- The live symlink points to the current epoch; promotion switches
- it atomically. *)
+ An epoch is a versioned collection of documentation artifacts. The live
+ symlink points to the current epoch; promotion switches it atomically. *)
-type t = {
- hash : string;
- dir : Fpath.t;
-}
+type t = { hash : string; dir : Fpath.t }
val version : string
(** Manual doc-format version, part of {!compute}. Bump it when day11's
doc-generation logic / HTML layout changes without a doc-tool change. *)
val compute : tool_hashes:string list -> string
-(** [compute ~tool_hashes] is the epoch hash for a doc toolchain: a
- digest of {!version} and the doc-tool build hashes (the
- odoc-driver/voodoo plus the per-compiler odoc builds, sorted+deduped).
- Those build hashes are content-addressed, so they already capture the
- tools' source, their transitive deps (sherlodoc/odig/…), and the
- compiler/base image. Per-package inputs are intentionally excluded —
- they update incrementally within an epoch. Pass the result to
- {!create}. *)
+(** [compute ~tool_hashes] is the epoch hash for a doc toolchain: a digest of
+ {!version} and the doc-tool build hashes (the odoc-driver/voodoo plus the
+ per-compiler odoc builds, sorted+deduped). Those build hashes are
+ content-addressed, so they already capture the tools' source, their
+ transitive deps (sherlodoc/odig/…), and the compiler/base image. Per-package
+ inputs are intentionally excluded — they update incrementally within an
+ epoch. Pass the result to {!create}. *)
val create : base_dir:Fpath.t -> string -> t
-(** [create ~base_dir hash] creates an epoch directory
- [base_dir/epoch-{hash}/] and returns its handle. *)
+(** [create ~base_dir hash] creates an epoch directory [base_dir/epoch-{hash}/]
+ and returns its handle. *)
val promote : base_dir:Fpath.t -> t -> unit
-(** [promote ~base_dir epoch] atomically switches the [html-live]
- symlink to point to [epoch]'s html directory. *)
+(** [promote ~base_dir epoch] atomically switches the [html-live] symlink to
+ point to [epoch]'s html directory. *)
val current : base_dir:Fpath.t -> t option
-(** [current ~base_dir] reads the [html-live] symlink and returns
- the current epoch, or [None] if no epoch is live. *)
+(** [current ~base_dir] reads the [html-live] symlink and returns the current
+ epoch, or [None] if no epoch is live. *)
val gc : base_dir:Fpath.t -> keep:int -> int
-(** [gc ~base_dir ~keep] removes old epoch directories, keeping
- the [keep] most recent. Returns the number deleted. *)
+(** [gc ~base_dir ~keep] removes old epoch directories, keeping the [keep] most
+ recent. Returns the number deleted. *)
File "day11/lib/gc.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/gc.ml b/_build/default/day11/lib/.formatted/gc.ml
index 3de7d12..fe85440 100644
--- a/_build/default/day11/lib/gc.ml
+++ b/_build/default/day11/lib/.formatted/gc.ml
@@ -1,48 +1,43 @@
-type result = {
- total : int;
- kept : int;
- deleted : int;
-}
+type result = { total : int; kept : int; deleted : int }
-let log fmt = Printf.ksprintf (fun msg ->
- Printf.printf "[gc] %s\n%!" msg
-) fmt
+let log fmt = Printf.ksprintf (fun msg -> Printf.printf "[gc] %s\n%!" msg) fmt
let rm_rf path =
- let ret = Sys.command (Printf.sprintf "rm -rf %s 2>/dev/null"
- (Filename.quote path)) in
+ let ret =
+ Sys.command (Printf.sprintf "rm -rf %s 2>/dev/null" (Filename.quote path))
+ in
if ret <> 0 then
- ignore (Sys.command (Printf.sprintf "sudo rm -rf %s"
- (Filename.quote path)))
+ ignore (Sys.command (Printf.sprintf "sudo rm -rf %s" (Filename.quote path)))
let list_dirs dir =
if Sys.file_exists dir && Sys.is_directory dir then
try
- Sys.readdir dir |> Array.to_list
- |> List.filter (fun name ->
- Sys.is_directory (Filename.concat dir name))
+ Sys.readdir dir
+ |> Array.to_list
+ |> List.filter (fun name -> Sys.is_directory (Filename.concat dir name))
with _ -> []
- else
- []
+ else []
let gc_build_layers ~os_dir ~referenced =
let referenced_set = Hashtbl.create (List.length referenced) in
List.iter (fun r -> Hashtbl.replace referenced_set r ()) referenced;
- let all = list_dirs os_dir
+ let all =
+ list_dirs os_dir
|> List.filter (fun name ->
- String.length name > 6 && String.sub name 0 6 = "build-") in
+ String.length name > 6 && String.sub name 0 6 = "build-")
+ in
let total = List.length all in
let deleted = ref 0 in
- List.iter (fun name ->
- if not (Hashtbl.mem referenced_set name) then begin
- log "Deleting unreferenced layer: %s" name;
- rm_rf (Filename.concat os_dir name);
- (* Also remove lock file *)
- let lock = Filename.concat os_dir (name ^ ".lock") in
- if Sys.file_exists lock then rm_rf lock;
- incr deleted
- end
- ) all;
+ List.iter
+ (fun name ->
+ if not (Hashtbl.mem referenced_set name) then (
+ log "Deleting unreferenced layer: %s" name;
+ rm_rf (Filename.concat os_dir name);
+ (* Also remove lock file *)
+ let lock = Filename.concat os_dir (name ^ ".lock") in
+ if Sys.file_exists lock then rm_rf lock;
+ incr deleted))
+ all;
{ total; kept = total - !deleted; deleted = !deleted }
let gc_odoc_store ~os_dir ~referenced_universes =
@@ -52,28 +47,32 @@ let gc_odoc_store ~os_dir ~referenced_universes =
let deleted = ref 0 in
let total = ref 0 in
(* GC odoc-out/u/ and html/u/ *)
- List.iter (fun subdir ->
- let u_dir = Filename.concat (Filename.concat store subdir) "u" in
- let universes = list_dirs u_dir in
- List.iter (fun uhash ->
- incr total;
- if not (Hashtbl.mem referenced_set uhash) then begin
- log "Deleting unreferenced universe %s from %s/u/" uhash subdir;
- rm_rf (Filename.concat u_dir uhash);
- incr deleted
- end
- ) universes
- ) [ "odoc-out"; "html" ];
+ List.iter
+ (fun subdir ->
+ let u_dir = Filename.concat (Filename.concat store subdir) "u" in
+ let universes = list_dirs u_dir in
+ List.iter
+ (fun uhash ->
+ incr total;
+ if not (Hashtbl.mem referenced_set uhash) then (
+ log "Deleting unreferenced universe %s from %s/u/" uhash subdir;
+ rm_rf (Filename.concat u_dir uhash);
+ incr deleted))
+ universes)
+ [ "odoc-out"; "html" ];
{ total = !total; kept = !total - !deleted; deleted = !deleted }
let gc_stale_temp_dirs () =
let tmp = Filename.get_temp_dir_name () in
- let stale = list_dirs tmp
+ let stale =
+ list_dirs tmp
|> List.filter (fun name ->
- String.length name > 10 && String.sub name 0 10 = "day11_run_") in
- List.iter (fun name ->
- let merged = Filename.concat (Filename.concat tmp name) "merged" in
- ignore (Sys.command (Printf.sprintf "sudo umount %s 2>/dev/null" merged));
- rm_rf (Filename.concat tmp name)
- ) stale;
+ String.length name > 10 && String.sub name 0 10 = "day11_run_")
+ in
+ List.iter
+ (fun name ->
+ let merged = Filename.concat (Filename.concat tmp name) "merged" in
+ ignore (Sys.command (Printf.sprintf "sudo umount %s 2>/dev/null" merged));
+ rm_rf (Filename.concat tmp name))
+ stale;
List.length stale
File "day11/lib/gc.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/gc.mli b/_build/default/day11/lib/.formatted/gc.mli
index b8e3263..345d0da 100644
--- a/_build/default/day11/lib/gc.mli
+++ b/_build/default/day11/lib/.formatted/gc.mli
@@ -1,27 +1,20 @@
(** Garbage collection for the build cache.
- Removes unreferenced build layers and stale odoc store entries.
- "Referenced" means the layer hash appears in the current DAG
- (computed from the latest solutions). *)
+ Removes unreferenced build layers and stale odoc store entries. "Referenced"
+ means the layer hash appears in the current DAG (computed from the latest
+ solutions). *)
-type result = {
- total : int;
- kept : int;
- deleted : int;
-}
+type result = { total : int; kept : int; deleted : int }
-val gc_build_layers :
- os_dir:string -> referenced:string list -> result
-(** [gc_build_layers ~os_dir ~referenced] deletes [build-*] directories
- in [os_dir] whose names are not in [referenced]. *)
+val gc_build_layers : os_dir:string -> referenced:string list -> result
+(** [gc_build_layers ~os_dir ~referenced] deletes [build-*] directories in
+ [os_dir] whose names are not in [referenced]. *)
-val gc_odoc_store :
- os_dir:string -> referenced_universes:string list -> result
+val gc_odoc_store : os_dir:string -> referenced_universes:string list -> result
(** [gc_odoc_store ~os_dir ~referenced_universes] removes entries from
- [odoc-store/odoc-out/u/] and [odoc-store/html/u/] whose universe
- hashes are not in [referenced_universes]. Blessed ([p/]) entries
- are always kept. *)
+ [odoc-store/odoc-out/u/] and [odoc-store/html/u/] whose universe hashes are
+ not in [referenced_universes]. Blessed ([p/]) entries are always kept. *)
val gc_stale_temp_dirs : unit -> int
-(** Remove stale [day11_run_*] directories from the system temp dir.
- Returns the number deleted. *)
+(** Remove stale [day11_run_*] directories from the system temp dir. Returns the
+ number deleted. *)
File "day11/lib/history.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/history.mli b/_build/default/day11/lib/.formatted/history.mli
index 49d6c71..39e52b0 100644
--- a/_build/default/day11/lib/history.mli
+++ b/_build/default/day11/lib/.formatted/history.mli
@@ -1,42 +1,42 @@
(** Per-package build history (append-only JSONL).
- Each package has a [history.jsonl] file with one JSON entry per
- build. Uses file locking for concurrent access safety. *)
+ Each package has a [history.jsonl] file with one JSON entry per build. Uses
+ file locking for concurrent access safety. *)
-(** A single build history entry recording what happened and when.
- Fields like compiler/dependency are intentionally absent — they
- are derivable from the build_hash via the per-snapshot
- [dag.json], which avoids storing the same fact twice. *)
type entry = {
- ts : string; (** ISO-8601 timestamp of the build. *)
- run : string; (** Run identifier this entry belongs to. *)
- build_hash : string; (** Content hash of the build layer. *)
- status : string; (** Outcome status (e.g. ["ok"], ["fail"]). *)
- category : string; (** Failure category (e.g. ["build_failure"]). *)
- blessed : bool; (** Whether this is the blessed (primary) build. *)
- error : string option; (** Optional error message. *)
+ ts : string; (** ISO-8601 timestamp of the build. *)
+ run : string; (** Run identifier this entry belongs to. *)
+ build_hash : string; (** Content hash of the build layer. *)
+ status : string; (** Outcome status (e.g. ["ok"], ["fail"]). *)
+ category : string; (** Failure category (e.g. ["build_failure"]). *)
+ blessed : bool; (** Whether this is the blessed (primary) build. *)
+ error : string option; (** Optional error message. *)
}
+(** A single build history entry recording what happened and when. Fields like
+ compiler/dependency are intentionally absent — they are derivable from the
+ build_hash via the per-snapshot [dag.json], which avoids storing the same
+ fact twice. *)
+val append : packages_dir:Fpath.t -> pkg_str:string -> entry -> unit
(** Append an entry to the history file for [pkg_str] under [packages_dir].
Creates the file if it does not exist. *)
-val append : packages_dir:Fpath.t -> pkg_str:string -> entry -> unit
-(** Read all history entries for [pkg_str], most recent first. *)
val read : packages_dir:Fpath.t -> pkg_str:string -> entry list
+(** Read all history entries for [pkg_str], most recent first. *)
-(** Read the latest entry per unique {!field:entry.build_hash}, most recent first. *)
val read_latest : packages_dir:Fpath.t -> pkg_str:string -> entry list
+(** Read the latest entry per unique {!field:entry.build_hash}, most recent
+ first. *)
-(** Return the most recent blessed entry, or [None]. *)
val read_blessed : packages_dir:Fpath.t -> pkg_str:string -> entry option
+(** Return the most recent blessed entry, or [None]. *)
-(** Remove duplicate consecutive entries older than [max_age_days],
- keeping the first and last of each run of identical results. *)
-val compact : packages_dir:Fpath.t -> pkg_str:string ->
- max_age_days:int -> unit
+val compact : packages_dir:Fpath.t -> pkg_str:string -> max_age_days:int -> unit
+(** Remove duplicate consecutive entries older than [max_age_days], keeping the
+ first and last of each run of identical results. *)
-(** Serialize an entry to JSON. *)
val entry_to_json : entry -> Yojson.Safe.t
+(** Serialize an entry to JSON. *)
-(** Deserialize an entry from JSON, returning [None] on malformed input. *)
val entry_of_json : Yojson.Safe.t -> entry option
+(** Deserialize an entry from JSON, returning [None] on malformed input. *)
File "day11/lib/notify.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/notify.ml b/_build/default/day11/lib/.formatted/notify.ml
index 5344304..915fd38 100644
--- a/_build/default/day11/lib/notify.ml
+++ b/_build/default/day11/lib/.formatted/notify.ml
@@ -17,51 +17,85 @@ let channel_to_string = function
let env key =
try Sys.getenv key
- with Not_found -> failwith (Printf.sprintf "Environment variable %s not set" key)
+ with Not_found ->
+ failwith (Printf.sprintf "Environment variable %s not set" key)
let run_curl args =
- let cmd = String.concat " " ("curl" :: "-s" :: "-o" :: "/dev/null" :: "-w" :: "'%{http_code}'" :: args) in
+ let cmd =
+ String.concat " "
+ ("curl" :: "-s" :: "-o" :: "/dev/null" :: "-w" :: "'%{http_code}'" :: args)
+ in
let ic = Unix.open_process_in cmd in
let output = try input_line ic with End_of_file -> "" in
match Unix.close_process_in ic with
| Unix.WEXITED 0 ->
- let code = try int_of_string (String.trim output |> fun s ->
- if String.length s >= 2 && s.[0] = '\'' then String.sub s 1 (String.length s - 2) else s
- ) with _ -> 0 in
- if code >= 200 && code < 300 then 0 else 1
+ let code =
+ try
+ int_of_string
+ ( String.trim output |> fun s ->
+ if String.length s >= 2 && s.[0] = '\'' then
+ String.sub s 1 (String.length s - 2)
+ else s )
+ with _ -> 0
+ in
+ if code >= 200 && code < 300 then 0 else 1
| _ -> 1
let send ~channel ~message =
match channel with
| Stdout ->
- print_endline message; 0
+ print_endline message;
+ 0
| Slack ->
- let url = env "SLACK_WEBHOOK_URL" in
- let escaped = String.concat "\\\"" (String.split_on_char '"' message) in
- run_curl ["-X"; "POST"; "-H"; "'Content-type: application/json'";
- "-d"; Printf.sprintf "'{\"text\":\"%s\"}'" escaped; url]
+ let url = env "SLACK_WEBHOOK_URL" in
+ let escaped = String.concat "\\\"" (String.split_on_char '"' message) in
+ run_curl
+ [
+ "-X";
+ "POST";
+ "-H";
+ "'Content-type: application/json'";
+ "-d";
+ Printf.sprintf "'{\"text\":\"%s\"}'" escaped;
+ url;
+ ]
| Zulip ->
- let email = env "ZULIP_BOT_EMAIL" in
- let api_key = env "ZULIP_BOT_API_KEY" in
- let server = env "ZULIP_SERVER" in
- let stream = env "ZULIP_STREAM" in
- run_curl ["-u"; Printf.sprintf "%s:%s" email api_key;
- "-X"; "POST"; Printf.sprintf "%s/api/v1/messages" server;
- "-d"; Printf.sprintf "'type=stream&to=%s&topic=day10&content=%s'" stream message]
+ let email = env "ZULIP_BOT_EMAIL" in
+ let api_key = env "ZULIP_BOT_API_KEY" in
+ let server = env "ZULIP_SERVER" in
+ let stream = env "ZULIP_STREAM" in
+ run_curl
+ [
+ "-u";
+ Printf.sprintf "%s:%s" email api_key;
+ "-X";
+ "POST";
+ Printf.sprintf "%s/api/v1/messages" server;
+ "-d";
+ Printf.sprintf "'type=stream&to=%s&topic=day10&content=%s'" stream
+ message;
+ ]
| Telegram ->
- let token = env "TELEGRAM_BOT_TOKEN" in
- let chat_id = env "TELEGRAM_CHAT_ID" in
- let escaped = String.concat "\\\"" (String.split_on_char '"' message) in
- let escaped = String.concat "\\n" (String.split_on_char '\n' escaped) in
- run_curl ["-X"; "POST";
- "-H"; "'Content-type: application/json'";
- Printf.sprintf "'https://api.telegram.org/bot%s/sendMessage'" token;
- "-d"; Printf.sprintf "'{\"chat_id\":\"%s\",\"text\":\"%s\"}'" chat_id escaped]
- | Email ->
- let to_addr = env "EMAIL_TO" in
- let from_addr = env "EMAIL_FROM" in
- let cmd = Printf.sprintf "echo %s | mail -s 'Day10 Notification' -r %s %s"
- (Filename.quote message) from_addr to_addr in
- match Unix.system cmd with
- | Unix.WEXITED 0 -> 0
- | _ -> 1
+ let token = env "TELEGRAM_BOT_TOKEN" in
+ let chat_id = env "TELEGRAM_CHAT_ID" in
+ let escaped = String.concat "\\\"" (String.split_on_char '"' message) in
+ let escaped = String.concat "\\n" (String.split_on_char '\n' escaped) in
+ run_curl
+ [
+ "-X";
+ "POST";
+ "-H";
+ "'Content-type: application/json'";
+ Printf.sprintf "'https://api.telegram.org/bot%s/sendMessage'" token;
+ "-d";
+ Printf.sprintf "'{\"chat_id\":\"%s\",\"text\":\"%s\"}'" chat_id
+ escaped;
+ ]
+ | Email -> (
+ let to_addr = env "EMAIL_TO" in
+ let from_addr = env "EMAIL_FROM" in
+ let cmd =
+ Printf.sprintf "echo %s | mail -s 'Day10 Notification' -r %s %s"
+ (Filename.quote message) from_addr to_addr
+ in
+ match Unix.system cmd with Unix.WEXITED 0 -> 0 | _ -> 1)
File "day11/lib/notify.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/notify.mli b/_build/default/day11/lib/.formatted/notify.mli
index 900ea4e..2327f8c 100644
--- a/_build/default/day11/lib/notify.mli
+++ b/_build/default/day11/lib/.formatted/notify.mli
@@ -1,19 +1,19 @@
(** Pluggable notifications.
- Send messages to external services (Slack, Zulip, Telegram, Email)
- or to stdout. Each channel uses environment variables for credentials
- and endpoints; see the implementation for required variables. *)
+ Send messages to external services (Slack, Zulip, Telegram, Email) or to
+ stdout. Each channel uses environment variables for credentials and
+ endpoints; see the implementation for required variables. *)
(** Supported notification channels. *)
type channel = Slack | Zulip | Telegram | Email | Stdout
-(** Send [message] to the given [channel]. Returns [0] on success, [1] on
- failure. External channels dispatch via [curl]; {!Stdout} prints
- directly. *)
val send : channel:channel -> message:string -> int
+(** Send [message] to the given [channel]. Returns [0] on success, [1] on
+ failure. External channels dispatch via [curl]; {!Stdout} prints directly.
+*)
-(** Parse a lowercase channel name (e.g. ["slack"], ["telegram"]). *)
val channel_of_string : string -> channel option
+(** Parse a lowercase channel name (e.g. ["slack"], ["telegram"]). *)
-(** Lowercase string representation of a {!type:channel}. *)
val channel_to_string : channel -> string
+(** Lowercase string representation of a {!type:channel}. *)
File "day11/lib/package_list.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/package_list.ml b/_build/default/day11/lib/.formatted/package_list.ml
index 6fe7f05..079d4c7 100644
--- a/_build/default/day11/lib/package_list.ml
+++ b/_build/default/day11/lib/.formatted/package_list.ml
@@ -2,15 +2,16 @@ let generate ~packages_dir =
let dir_s = Fpath.to_string packages_dir in
if not (Sys.file_exists dir_s) then []
else
- Sys.readdir dir_s |> Array.to_list
+ Sys.readdir dir_s
+ |> Array.to_list
|> List.filter (fun name ->
- let path = Filename.concat dir_s name in
- try Sys.is_directory path with Sys_error _ -> false)
+ let path = Filename.concat dir_s name in
+ try Sys.is_directory path with Sys_error _ -> false)
|> List.filter (fun pkg_str ->
- let entries = History.read ~packages_dir ~pkg_str in
- match entries with
- | [] -> false
- | latest :: _ -> latest.status = "success")
+ let entries = History.read ~packages_dir ~pkg_str in
+ match entries with
+ | [] -> false
+ | latest :: _ -> latest.status = "success")
let save path packages =
let json = `List (List.map (fun s -> `String s) packages) in
@@ -19,9 +20,9 @@ let save path packages =
let load path =
match Bos.OS.File.read path with
| Error _ as e -> e
- | Ok data ->
- try
- let json = Yojson.Safe.from_string data in
- Ok (Yojson.Safe.Util.to_list json |> List.map Yojson.Safe.Util.to_string)
- with exn ->
- Rresult.R.error_msgf "Package_list.load: %s" (Printexc.to_string exn)
+ | Ok data -> (
+ try
+ let json = Yojson.Safe.from_string data in
+ Ok (Yojson.Safe.Util.to_list json |> List.map Yojson.Safe.Util.to_string)
+ with exn ->
+ Rresult.R.error_msgf "Package_list.load: %s" (Printexc.to_string exn))
File "day11/lib/package_list.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/package_list.mli b/_build/default/day11/lib/.formatted/package_list.mli
index 9bfc6b9..11dc881 100644
--- a/_build/default/day11/lib/package_list.mli
+++ b/_build/default/day11/lib/.formatted/package_list.mli
@@ -1,11 +1,11 @@
(** Valid package list generation.
- Scans build history to produce a list of packages that built
- successfully, for publishing to ocaml.org. *)
+ Scans build history to produce a list of packages that built successfully,
+ for publishing to ocaml.org. *)
val generate : packages_dir:Fpath.t -> string list
-(** [generate ~packages_dir] returns package names whose latest
- build status is success. *)
+(** [generate ~packages_dir] returns package names whose latest build status is
+ success. *)
val save : Fpath.t -> string list -> (unit, [> Rresult.R.msg ]) result
(** [save path packages] writes the list as JSON. *)
File "day11/lib/progress.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/progress.ml b/_build/default/day11/lib/.formatted/progress.ml
index 2e51ce7..9c678e2 100644
--- a/_build/default/day11/lib/progress.ml
+++ b/_build/default/day11/lib/.formatted/progress.ml
@@ -40,27 +40,26 @@ let set_solutions t ~found ~failed =
{ t with solutions_found = found; solutions_failed = failed }
let set_build_total t total = { t with build_total = total; doc_total = total }
-
let incr_build_completed t = { t with build_completed = t.build_completed + 1 }
-
let incr_doc_completed t = { t with doc_completed = t.doc_completed + 1 }
let set_completed t ~build ~doc =
{ t with build_completed = build; doc_completed = doc }
let to_json t =
- `Assoc [
- ("run_id", `String t.run_id);
- ("start_time", `String t.start_time);
- ("phase", `String (phase_to_string t.phase));
- ("targets", `List (List.map (fun s -> `String s) t.targets));
- ("solutions_found", `Int t.solutions_found);
- ("solutions_failed", `Int t.solutions_failed);
- ("build_completed", `Int t.build_completed);
- ("build_total", `Int t.build_total);
- ("doc_completed", `Int t.doc_completed);
- ("doc_total", `Int t.doc_total);
- ]
+ `Assoc
+ [
+ ("run_id", `String t.run_id);
+ ("start_time", `String t.start_time);
+ ("phase", `String (phase_to_string t.phase));
+ ("targets", `List (List.map (fun s -> `String s) t.targets));
+ ("solutions_found", `Int t.solutions_found);
+ ("solutions_failed", `Int t.solutions_failed);
+ ("build_completed", `Int t.build_completed);
+ ("build_total", `Int t.build_total);
+ ("doc_completed", `Int t.doc_completed);
+ ("doc_total", `Int t.doc_total);
+ ]
let write ~run_dir t =
let path = Filename.concat run_dir "progress.json" in
@@ -68,7 +67,7 @@ let write ~run_dir t =
let json = to_json t in
let content = Yojson.Safe.pretty_to_string json in
Out_channel.with_open_text temp_path (fun oc ->
- Out_channel.output_string oc content);
+ Out_channel.output_string oc content);
Unix.rename temp_path path
let delete ~run_dir =
File "day11/lib/progress.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/progress.mli b/_build/default/day11/lib/.formatted/progress.mli
index 3c5ec64..6189203 100644
--- a/_build/default/day11/lib/progress.mli
+++ b/_build/default/day11/lib/.formatted/progress.mli
@@ -1,45 +1,44 @@
(** Batch progress tracking.
- Immutable state updated during a batch run, written as
- [progress.json] for the web dashboard to poll. Each mutation
- returns a new {!type:t} value. *)
+ Immutable state updated during a batch run, written as [progress.json] for
+ the web dashboard to poll. Each mutation returns a new {!type:t} value. *)
(** The current phase of a batch run. *)
type phase = Solving | Blessings | Building | Gc | Completed
-(** Opaque progress state. Use {!create} to initialise and the
- [set_*] / [incr_*] functions to update. *)
type t
+(** Opaque progress state. Use {!create} to initialise and the [set_*] /
+ [incr_*] functions to update. *)
-(** Create initial progress state in the {!Solving} phase. *)
val create : run_id:string -> start_time:string -> targets:string list -> t
+(** Create initial progress state in the {!Solving} phase. *)
-(** Set the current phase. *)
val set_phase : t -> phase -> t
+(** Set the current phase. *)
-(** Record how many solutions were found and how many failed. *)
val set_solutions : t -> found:int -> failed:int -> t
+(** Record how many solutions were found and how many failed. *)
-(** Set the total number of builds (and docs) expected. *)
val set_build_total : t -> int -> t
+(** Set the total number of builds (and docs) expected. *)
-(** Increment the count of completed builds by one. *)
val incr_build_completed : t -> t
+(** Increment the count of completed builds by one. *)
-(** Increment the count of completed doc builds by one. *)
val incr_doc_completed : t -> t
+(** Increment the count of completed doc builds by one. *)
-(** Set completed build and doc counts directly. *)
val set_completed : t -> build:int -> doc:int -> t
+(** Set completed build and doc counts directly. *)
-(** Serialize progress state to JSON. *)
val to_json : t -> Yojson.Safe.t
+(** Serialize progress state to JSON. *)
-(** Write [progress.json] atomically into [run_dir]. *)
val write : run_dir:string -> t -> unit
+(** Write [progress.json] atomically into [run_dir]. *)
-(** Delete [progress.json] from [run_dir], ignoring errors. *)
val delete : run_dir:string -> unit
+(** Delete [progress.json] from [run_dir], ignoring errors. *)
-(** Convert a phase to its lowercase string representation. *)
val phase_to_string : phase -> string
+(** Convert a phase to its lowercase string representation. *)
File "day11/lib/run_log.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/run_log.mli b/_build/default/day11/lib/.formatted/run_log.mli
index 96f62df..dae8fac 100644
--- a/_build/default/day11/lib/run_log.mli
+++ b/_build/default/day11/lib/.formatted/run_log.mli
@@ -1,7 +1,7 @@
(** Run lifecycle and structured logging.
- Tracks the start/end of a batch run, collects build/doc logs,
- and produces a summary. *)
+ Tracks the start/end of a batch run, collects build/doc logs, and produces a
+ summary. *)
type t
(** Opaque run metadata. *)
@@ -25,37 +25,61 @@ val get_run_dir : t -> string
val get_start_time : t -> float
val format_time : float -> string
val add_build_log : t -> package:string -> source_log:string -> unit
-val add_doc_log : t -> package:string -> source_log:string ->
- layer_hash:string -> unit
-val finish_run : t -> targets_requested:int -> packages_built:int ->
- packages_failed:int -> docs_generated:int ->
- failures:(string * string) list -> summary
+
+val add_doc_log :
+ t -> package:string -> source_log:string -> layer_hash:string -> unit
+
+val finish_run :
+ t ->
+ targets_requested:int ->
+ packages_built:int ->
+ packages_failed:int ->
+ docs_generated:int ->
+ failures:(string * string) list ->
+ summary
(** {2 Incremental phase files}
Written as the build progresses so status can be checked mid-run. *)
-val write_plan : t -> repos_with_shas:(string * string) list ->
- n_targets:int -> ocaml_version:string option ->
- with_doc:bool -> all_versions:bool -> small_universe:bool -> unit
+val write_plan :
+ t ->
+ repos_with_shas:(string * string) list ->
+ n_targets:int ->
+ ocaml_version:string option ->
+ with_doc:bool ->
+ all_versions:bool ->
+ small_universe:bool ->
+ unit
val write_solve : t -> n_solved:int -> n_failed:int -> unit
-
val write_dag : t -> n_build:int -> n_cached:int -> n_need_build:int -> unit
-val write_doc_dag : t -> n_build:int -> n_tool:int ->
- n_doc_all:int -> n_compile:int -> n_link:int -> unit
+val write_doc_dag :
+ t ->
+ n_build:int ->
+ n_tool:int ->
+ n_doc_all:int ->
+ n_compile:int ->
+ n_link:int ->
+ unit
-val log_build_result : t -> pkg:string -> hash:string ->
- status:string -> failed_dep:string option ->
- ?kind:string -> ?layer_dir:string -> unit -> unit
-(** Append one line to [build.jsonl]. Thread-safe.
- [kind] is ["build"], ["tool"], ["doc-all"], ["compile"], or ["link"].
- [layer_dir] is the path to the layer on disk. *)
+val log_build_result :
+ t ->
+ pkg:string ->
+ hash:string ->
+ status:string ->
+ failed_dep:string option ->
+ ?kind:string ->
+ ?layer_dir:string ->
+ unit ->
+ unit
+(** Append one line to [build.jsonl]. Thread-safe. [kind] is ["build"],
+ ["tool"], ["doc-all"], ["compile"], or ["link"]. [layer_dir] is the path to
+ the layer on disk. *)
val write_dag_structure : t -> Day11_opam_layer.Build.t list -> unit
-(** Write one JSONL line per node: hash, package, dep hashes.
- Enables offline analysis of DAG parallelism. *)
+(** Write one JSONL line per node: hash, package, dep hashes. Enables offline
+ analysis of DAG parallelism. *)
val close_build_log : unit -> unit
-
val summary_to_json : summary -> Yojson.Safe.t
File "day11/lib/status_index.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/status_index.mli b/_build/default/day11/lib/.formatted/status_index.mli
index 2ea1d0e..d9dacfe 100644
--- a/_build/default/day11/lib/status_index.mli
+++ b/_build/default/day11/lib/.formatted/status_index.mli
@@ -1,42 +1,44 @@
(** Global status index.
- Aggregates all packages' current build status into a single
- snapshot, detecting changes from the previous snapshot. Written
- to [status.json] for consumption by the web dashboard and
- notification system. *)
+ Aggregates all packages' current build status into a single snapshot,
+ detecting changes from the previous snapshot. Written to [status.json] for
+ consumption by the web dashboard and notification system. *)
-(** A status change for a single package between two runs. *)
type change = {
- package : string; (** Package name (e.g. ["foo.1.0"]). *)
- build_hash : string; (** Content hash of the build layer. *)
- blessed : bool; (** Whether this is the blessed build. *)
- from_status : string; (** Previous status category. *)
- to_status : string; (** New status category. *)
+ package : string; (** Package name (e.g. ["foo.1.0"]). *)
+ build_hash : string; (** Content hash of the build layer. *)
+ blessed : bool; (** Whether this is the blessed build. *)
+ from_status : string; (** Previous status category. *)
+ to_status : string; (** New status category. *)
}
+(** A status change for a single package between two runs. *)
-(** A complete status snapshot for one run. *)
type t = {
- generated : string; (** ISO-8601 generation timestamp. *)
- run_id : string; (** Unique run identifier. *)
- blessed_totals : (string * int) list; (** Category counts for blessed builds. *)
- non_blessed_totals : (string * int) list; (** Category counts for non-blessed builds. *)
- changes : change list; (** Status changes since the previous run. *)
- new_packages : string list; (** Packages seen for the first time in this run. *)
+ generated : string; (** ISO-8601 generation timestamp. *)
+ run_id : string; (** Unique run identifier. *)
+ blessed_totals : (string * int) list;
+ (** Category counts for blessed builds. *)
+ non_blessed_totals : (string * int) list;
+ (** Category counts for non-blessed builds. *)
+ changes : change list; (** Status changes since the previous run. *)
+ new_packages : string list;
+ (** Packages seen for the first time in this run. *)
}
+(** A complete status snapshot for one run. *)
-(** Scan [packages_dir] and build a status snapshot for [run_id],
- computing changes relative to [previous] (if provided). *)
-val generate : packages_dir:Fpath.t -> run_id:string ->
- previous:t option -> t
+val generate : packages_dir:Fpath.t -> run_id:string -> previous:t option -> t
+(** Scan [packages_dir] and build a status snapshot for [run_id], computing
+ changes relative to [previous] (if provided). *)
-(** Write the status index as [status.json] in [dir]. *)
val write : dir:Fpath.t -> t -> unit
+(** Write the status index as [status.json] in [dir]. *)
-(** Read a previously written status index from [dir], or [None]. *)
val read : dir:Fpath.t -> t option
+(** Read a previously written status index from [dir], or [None]. *)
-(** Serialize a status index to JSON. *)
val to_json : t -> Yojson.Safe.t
+(** Serialize a status index to JSON. *)
-(** Deserialize a status index from JSON, returning [None] on malformed input. *)
val of_json : Yojson.Safe.t -> t option
+(** Deserialize a status index from JSON, returning [None] on malformed input.
+*)
File "day11/lib/universe_manifest.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/universe_manifest.mli b/_build/default/day11/lib/.formatted/universe_manifest.mli
index 4dc73a8..be74a35 100644
--- a/_build/default/day11/lib/universe_manifest.mli
+++ b/_build/default/day11/lib/.formatted/universe_manifest.mli
@@ -1,15 +1,15 @@
(** Per-snapshot universe membership metadata.
A {e universe} is a hash of a doc-dependency closure (see
- {!Day11_solution.Universe}); the hash alone can't be reversed to
- the package set it stands for. When all solutions for a snapshot
- are known we persist that mapping so the dashboard can show, for
- any universe, the exact package versions it contains.
+ {!Day11_solution.Universe}); the hash alone can't be reversed to the package
+ set it stands for. When all solutions for a snapshot are known we persist
+ that mapping so the dashboard can show, for any universe, the exact package
+ versions it contains.
Layout, relative to a snapshot directory:
- [universes/index.json] — [{ "universes": [hash, ...] }]
- - [universes/<hash>.json] — [{ "universe_hash": hash,
- "packages": [name.version, ...] }] *)
+ - [universes/<hash>.json] —
+ [{ "universe_hash": hash, "packages": [name.version, ...] }] *)
type t = {
hash : string;
@@ -23,14 +23,14 @@ val write_all :
snapshot_dir:Fpath.t ->
(string * string list) list ->
(unit, [> Rresult.R.msg ]) result
-(** [write_all ~snapshot_dir universes] writes the index and one
- manifest file per universe. Each element is
- [(universe_hash, packages)]. Overwrites any existing files. *)
+(** [write_all ~snapshot_dir universes] writes the index and one manifest file
+ per universe. Each element is [(universe_hash, packages)]. Overwrites any
+ existing files. *)
val read_index : snapshot_dir:Fpath.t -> string list
-(** [read_index ~snapshot_dir] returns all universe hashes recorded
- for the snapshot, or [[]] if none have been written. *)
+(** [read_index ~snapshot_dir] returns all universe hashes recorded for the
+ snapshot, or [[]] if none have been written. *)
val read_manifest : snapshot_dir:Fpath.t -> hash:string -> t option
-(** [read_manifest ~snapshot_dir ~hash] returns the package set of a
- single universe, or [None] if not recorded. *)
+(** [read_manifest ~snapshot_dir ~hash] returns the package set of a single
+ universe, or [None] if not recorded. *)
File "day11/doc/combine.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/combine.mli b/_build/default/day11/doc/.formatted/combine.mli
index 981a9c8..2f4fb61 100644
--- a/_build/default/day11/doc/combine.mli
+++ b/_build/default/day11/doc/.formatted/combine.mli
@@ -1,7 +1,7 @@
(** Local documentation aggregation via overlayfs.
- Mounts all successful doc layers as an overlay filesystem for
- local viewing. Requires sudo for mount/umount. *)
+ Mounts all successful doc layers as an overlay filesystem for local viewing.
+ Requires sudo for mount/umount. *)
type doc_layer = {
pkg : OpamPackage.t;
@@ -12,12 +12,10 @@ type doc_layer = {
}
(** A doc layer discovered in the cache. *)
-val scan_cache :
- Eio_unix.Stdenv.base ->
- os_dir:Fpath.t -> doc_layer list
-(** [scan_cache env ~os_dir] scans [os_dir] for [doc-*] layer
- directories (excluding tool layers), parses their layer.json,
- and returns successfully-generated doc layers. *)
+val scan_cache : Eio_unix.Stdenv.base -> os_dir:Fpath.t -> doc_layer list
+(** [scan_cache env ~os_dir] scans [os_dir] for [doc-*] layer directories
+ (excluding tool layers), parses their layer.json, and returns
+ successfully-generated doc layers. *)
val mount_overlay :
sw:Eio.Switch.t ->
@@ -26,9 +24,8 @@ val mount_overlay :
mount_point:Fpath.t ->
work_dir:Fpath.t ->
(unit, [> Rresult.R.msg ]) result
-(** [mount_overlay ~sw env ~layers ~mount_point ~work_dir] mounts all
- doc layers' prep directories as a combined overlay at
- [mount_point]. *)
+(** [mount_overlay ~sw env ~layers ~mount_point ~work_dir] mounts all doc
+ layers' prep directories as a combined overlay at [mount_point]. *)
val unmount :
sw:Eio.Switch.t ->
File "day11/doc/command.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/command.ml b/_build/default/day11/doc/.formatted/command.ml
index c686dea..57d596e 100644
--- a/_build/default/day11/doc/command.ml
+++ b/_build/default/day11/doc/.formatted/command.ml
@@ -2,19 +2,12 @@ let compute_universe_hash dep_hashes =
let sorted = List.sort String.compare dep_hashes in
Day11_layer.Hash.of_strings sorted
-let odoc_driver_voodoo ~pkg ~universe:_ ~blessed ~actions
- ~odoc_bin ~odoc_md_bin =
+let odoc_driver_voodoo ~pkg ~universe:_ ~blessed ~actions ~odoc_bin ~odoc_md_bin
+ =
let pkg_name = OpamPackage.name_to_string pkg in
Printf.sprintf
- "odoc_driver_voodoo %s \
- --odoc-dir /home/opam/odoc-out \
- --html-dir /home/opam/html \
- --actions %s -j $(nproc) -v \
- %s \
- --odoc %s \
- --odoc-md %s"
- pkg_name
- actions
+ "odoc_driver_voodoo %s --odoc-dir /home/opam/odoc-out --html-dir \
+ /home/opam/html --actions %s -j $(nproc) -v %s --odoc %s --odoc-md %s"
+ pkg_name actions
(if blessed then "--blessed" else "")
- odoc_bin
- odoc_md_bin
+ odoc_bin odoc_md_bin
File "day11/doc/command.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/command.mli b/_build/default/day11/doc/.formatted/command.mli
index b8efaa1..50571e6 100644
--- a/_build/default/day11/doc/command.mli
+++ b/_build/default/day11/doc/.formatted/command.mli
@@ -1,7 +1,7 @@
(** Shell command generation for odoc_driver_voodoo.
- Generates the command string to run inside a container for
- documentation generation. Pure — no I/O. *)
+ Generates the command string to run inside a container for documentation
+ generation. Pure — no I/O. *)
val odoc_driver_voodoo :
pkg:OpamPackage.t ->
@@ -11,15 +11,14 @@ val odoc_driver_voodoo :
odoc_bin:string ->
odoc_md_bin:string ->
string
-(** [odoc_driver_voodoo ~pkg ~universe ~blessed ~actions ~odoc_bin
- ~odoc_md_bin] generates the shell command to run
- [odoc_driver_voodoo].
+(** [odoc_driver_voodoo ~pkg ~universe ~blessed ~actions ~odoc_bin ~odoc_md_bin]
+ generates the shell command to run [odoc_driver_voodoo].
[actions] is one of ["all"], ["compile-only"], or ["link-and-gen"].
- [odoc_bin] and [odoc_md_bin] are paths to the odoc and odoc-md
- binaries inside the container. *)
+ [odoc_bin] and [odoc_md_bin] are paths to the odoc and odoc-md binaries
+ inside the container. *)
val compute_universe_hash : string list -> string
-(** [compute_universe_hash dep_hashes] computes a deterministic hash
- from a sorted list of dependency doc hashes. Used to identify
- which universe a doc build belongs to. *)
+(** [compute_universe_hash dep_hashes] computes a deterministic hash from a
+ sorted list of dependency doc hashes. Used to identify which universe a doc
+ build belongs to. *)
File "day11/doc/doc_deps.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/doc_deps.ml b/_build/default/day11/doc/.formatted/doc_deps.ml
index 5d51982..bb8e4a8 100644
--- a/_build/default/day11/doc/doc_deps.ml
+++ b/_build/default/day11/doc/.formatted/doc_deps.ml
@@ -1,9 +1,11 @@
let needs_separate_link (result : Day11_solution.Solve_result.t) pkg =
- let compile_set = match OpamPackage.Map.find_opt pkg result.build_deps with
+ let compile_set =
+ match OpamPackage.Map.find_opt pkg result.build_deps with
| Some deps -> deps
| None -> OpamPackage.Set.empty
in
- let link_set = match OpamPackage.Map.find_opt pkg result.doc_deps with
+ let link_set =
+ match OpamPackage.Map.find_opt pkg result.doc_deps with
| Some deps -> deps
| None -> OpamPackage.Set.empty
in
File "day11/batch/profile.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/batch/profile.ml b/_build/default/day11/batch/.formatted/profile.ml
index 05c5f58..5866d80 100644
--- a/_build/default/day11/batch/profile.ml
+++ b/_build/default/day11/batch/.formatted/profile.ml
@@ -3,13 +3,12 @@
type version_mode =
| All_versions
| Latest_n of int
- (** Keep the [n] most-recent (non-avoided) versions of each
- package. [Latest_n 1] = newest only. *)
+ (** Keep the [n] most-recent (non-avoided) versions of each package.
+ [Latest_n 1] = newest only. *)
type name_filter =
| All_names
- | Names of string list
- (** Track only these exact package names. *)
+ | Names of string list (** Track only these exact package names. *)
type target_mode = { versions : version_mode; names : name_filter }
@@ -34,7 +33,7 @@ type t = {
base_image_updated : string option;
(* ISO-8601 timestamp of when base_image_digest was resolved *)
html_dir : string option;
- (* Destination for generated HTML when the profile is driven by
+ (* Destination for generated HTML when the profile is driven by
a doc pipeline ([ocaml-docs-ci] etc.). Each profile gets its
own [html_dir] so a single pipeline run can output to several
separate sites in parallel. [None] means build-only, no docs. *)
@@ -49,8 +48,11 @@ let name_filter_to_json = function
| Names l -> `Assoc [ ("only", `List (List.map (fun s -> `String s) l)) ]
let target_mode_to_json { versions; names } =
- `Assoc [ ("versions", version_mode_to_json versions);
- ("names", name_filter_to_json names) ]
+ `Assoc
+ [
+ ("versions", version_mode_to_json versions);
+ ("names", name_filter_to_json names);
+ ]
let version_mode_of_json = function
| `String "all" -> Ok All_versions
@@ -67,90 +69,98 @@ let name_filter_of_json = function
let target_mode_of_json = function
(* New two-axis form: {"versions": …, "names": …}. *)
- | `Assoc fields when List.mem_assoc "versions" fields
- || List.mem_assoc "names" fields ->
- let v = match List.assoc_opt "versions" fields with
- | None -> Ok All_versions | Some j -> version_mode_of_json j in
- let n = match List.assoc_opt "names" fields with
- | None -> Ok All_names | Some j -> name_filter_of_json j in
- (match v, n with
- | Ok versions, Ok names -> Ok { versions; names }
- | (Error _ as e), _ | _, (Error _ as e) -> e)
+ | `Assoc fields
+ when List.mem_assoc "versions" fields || List.mem_assoc "names" fields -> (
+ let v =
+ match List.assoc_opt "versions" fields with
+ | None -> Ok All_versions
+ | Some j -> version_mode_of_json j
+ in
+ let n =
+ match List.assoc_opt "names" fields with
+ | None -> Ok All_names
+ | Some j -> name_filter_of_json j
+ in
+ match (v, n) with
+ | Ok versions, Ok names -> Ok { versions; names }
+ | (Error _ as e), _ | _, (Error _ as e) -> e)
(* Back-compat with the old single-enum [target_mode]. *)
| `String "all_versions" -> Ok { versions = All_versions; names = All_names }
| `String "latest_versions" -> Ok { versions = Latest_n 1; names = All_names }
| `Assoc [ ("packages", `List l) ] ->
- Ok { versions = All_versions; names = names_of_json l }
+ Ok { versions = All_versions; names = names_of_json l }
| _ -> Error (`Msg "invalid target_mode")
-let opt_to_json = function
- | None -> `Null
- | Some s -> `String s
-
-let opt_of_json = function
- | `Null -> None
- | `String s -> Some s
- | _ -> None
+let opt_to_json = function None -> `Null | Some s -> `String s
+let opt_of_json = function `Null -> None | `String s -> Some s | _ -> None
let to_json t =
- `Assoc [
- ("name", `String t.name);
- ("opam_repositories", `List (List.map (fun s -> `String s) t.opam_repositories));
- ("odoc_repo", opt_to_json t.odoc_repo);
- ("opam_build_repo", opt_to_json t.opam_build_repo);
- ("compiler", opt_to_json t.compiler);
- ("target_mode", target_mode_to_json t.target_mode);
- ("with_doc", `Bool t.with_doc);
- ("with_jtw", `Bool t.with_jtw);
- ("jtw_repo", opt_to_json t.jtw_repo);
- ("arch", `String t.arch);
- ("os_distribution", `String t.os_distribution);
- ("os_version", `String t.os_version);
- ("driver_compiler", `String t.driver_compiler);
- ("extra_pins", `List (List.map (fun s -> `String s) t.extra_pins));
- ("pinned_versions",
- `List (List.map (fun s -> `String s) t.pinned_versions));
- ("patches_dir", opt_to_json t.patches_dir);
- ("base_image_digest", opt_to_json t.base_image_digest);
- ("base_image_updated", opt_to_json t.base_image_updated);
- ("html_dir", opt_to_json t.html_dir);
- ]
+ `Assoc
+ [
+ ("name", `String t.name);
+ ( "opam_repositories",
+ `List (List.map (fun s -> `String s) t.opam_repositories) );
+ ("odoc_repo", opt_to_json t.odoc_repo);
+ ("opam_build_repo", opt_to_json t.opam_build_repo);
+ ("compiler", opt_to_json t.compiler);
+ ("target_mode", target_mode_to_json t.target_mode);
+ ("with_doc", `Bool t.with_doc);
+ ("with_jtw", `Bool t.with_jtw);
+ ("jtw_repo", opt_to_json t.jtw_repo);
+ ("arch", `String t.arch);
+ ("os_distribution", `String t.os_distribution);
+ ("os_version", `String t.os_version);
+ ("driver_compiler", `String t.driver_compiler);
+ ("extra_pins", `List (List.map (fun s -> `String s) t.extra_pins));
+ ( "pinned_versions",
+ `List (List.map (fun s -> `String s) t.pinned_versions) );
+ ("patches_dir", opt_to_json t.patches_dir);
+ ("base_image_digest", opt_to_json t.base_image_digest);
+ ("base_image_updated", opt_to_json t.base_image_updated);
+ ("html_dir", opt_to_json t.html_dir);
+ ]
let of_json json =
try
let open Yojson.Safe.Util in
let str key = json |> member key |> to_string in
let str_opt key = json |> member key |> opt_of_json in
- let str_list key =
- json |> member key |> to_list |> List.map to_string in
+ let str_list key = json |> member key |> to_list |> List.map to_string in
let tm = target_mode_of_json (json |> member "target_mode") in
match tm with
| Error e -> Error e
| Ok target_mode ->
- Ok {
- name = str "name";
- opam_repositories = str_list "opam_repositories";
- odoc_repo = str_opt "odoc_repo";
- opam_build_repo = str_opt "opam_build_repo";
- compiler = str_opt "compiler";
- target_mode;
- with_doc = json |> member "with_doc" |> to_bool_option
- |> Option.value ~default:false;
- with_jtw = json |> member "with_jtw" |> to_bool_option
- |> Option.value ~default:false;
- jtw_repo = str_opt "jtw_repo";
- arch = (try str "arch" with _ -> "x86_64");
- os_distribution = (try str "os_distribution" with _ -> "debian");
- os_version = (try str "os_version" with _ -> "bookworm");
- driver_compiler = (try str "driver_compiler"
- with _ -> "ocaml-base-compiler.5.4.1");
- extra_pins = (try str_list "extra_pins" with _ -> []);
- pinned_versions = (try str_list "pinned_versions" with _ -> []);
- patches_dir = str_opt "patches_dir";
- base_image_digest = str_opt "base_image_digest";
- base_image_updated = str_opt "base_image_updated";
- html_dir = str_opt "html_dir";
- }
+ Ok
+ {
+ name = str "name";
+ opam_repositories = str_list "opam_repositories";
+ odoc_repo = str_opt "odoc_repo";
+ opam_build_repo = str_opt "opam_build_repo";
+ compiler = str_opt "compiler";
+ target_mode;
+ with_doc =
+ json
+ |> member "with_doc"
+ |> to_bool_option
+ |> Option.value ~default:false;
+ with_jtw =
+ json
+ |> member "with_jtw"
+ |> to_bool_option
+ |> Option.value ~default:false;
+ jtw_repo = str_opt "jtw_repo";
+ arch = (try str "arch" with _ -> "x86_64");
+ os_distribution = (try str "os_distribution" with _ -> "debian");
+ os_version = (try str "os_version" with _ -> "bookworm");
+ driver_compiler =
+ (try str "driver_compiler" with _ -> "ocaml-base-compiler.5.4.1");
+ extra_pins = (try str_list "extra_pins" with _ -> []);
+ pinned_versions = (try str_list "pinned_versions" with _ -> []);
+ patches_dir = str_opt "patches_dir";
+ base_image_digest = str_opt "base_image_digest";
+ base_image_updated = str_opt "base_image_updated";
+ html_dir = str_opt "html_dir";
+ }
with exn ->
Rresult.R.error_msgf "Profile.of_json: %s" (Printexc.to_string exn)
@@ -160,8 +170,7 @@ let save ~dir t =
ignore (Bos.OS.Dir.create ~path:true dir);
let data = Yojson.Safe.pretty_to_string (to_json t) in
Bos.OS.File.write path data
- with exn ->
- Rresult.R.error_msgf "Profile.save: %s" (Printexc.to_string exn)
+ with exn -> Rresult.R.error_msgf "Profile.save: %s" (Printexc.to_string exn)
(* Resolve a profile path against the .day11 root. Absolute entries are
returned unchanged; a relative entry such as ["overlays/odoc-master/repo"]
@@ -178,39 +187,44 @@ let load ~dir ~name =
let path = Fpath.(dir / (name ^ ".json")) in
match Bos.OS.File.read path with
| Error _ as e -> e
- | Ok data ->
- try
- match of_json (Yojson.Safe.from_string data) with
- | Error _ as e -> e
- | Ok profile ->
- (* [dir] is the [profiles/] dir, so its parent is the .day11
+ | Ok data -> (
+ try
+ match of_json (Yojson.Safe.from_string data) with
+ | Error _ as e -> e
+ | Ok profile ->
+ (* [dir] is the [profiles/] dir, so its parent is the .day11
root that relative paths resolve against. Resolve every
path-valued field, not just [opam_repositories] — e.g.
[html_dir] was left as an absolute container path and failed
to bind-mount when the daemon ran on the host. *)
- let day11_dir = Fpath.parent dir in
- let r = resolve_repo ~day11_dir in
- let ro = Option.map r in
- Ok { profile with
- opam_repositories = List.map r profile.opam_repositories;
- odoc_repo = ro profile.odoc_repo;
- opam_build_repo = ro profile.opam_build_repo;
- jtw_repo = ro profile.jtw_repo;
- patches_dir = ro profile.patches_dir;
- html_dir = ro profile.html_dir }
- with exn ->
- Rresult.R.error_msgf "Profile.load %s: %s" name (Printexc.to_string exn)
+ let day11_dir = Fpath.parent dir in
+ let r = resolve_repo ~day11_dir in
+ let ro = Option.map r in
+ Ok
+ {
+ profile with
+ opam_repositories = List.map r profile.opam_repositories;
+ odoc_repo = ro profile.odoc_repo;
+ opam_build_repo = ro profile.opam_build_repo;
+ jtw_repo = ro profile.jtw_repo;
+ patches_dir = ro profile.patches_dir;
+ html_dir = ro profile.html_dir;
+ }
+ with exn ->
+ Rresult.R.error_msgf "Profile.load %s: %s" name (Printexc.to_string exn)
+ )
let list ~dir =
match Bos.OS.Dir.contents dir with
| Error _ -> []
| Ok entries ->
- List.filter_map (fun p ->
- let name = Fpath.basename p in
- if Fpath.has_ext ".json" p then
- Some (Fpath.rem_ext (Fpath.v name) |> Fpath.to_string)
- else None
- ) entries
+ List.filter_map
+ (fun p ->
+ let name = Fpath.basename p in
+ if Fpath.has_ext ".json" p then
+ Some (Fpath.rem_ext (Fpath.v name) |> Fpath.to_string)
+ else None)
+ entries
let delete ~dir ~name =
let path = Fpath.(dir / (name ^ ".json")) in
@@ -219,8 +233,7 @@ let delete ~dir ~name =
let os_dir_name t =
Printf.sprintf "%s-%s-%s" t.os_distribution t.os_version t.arch
-let base_image_tag t =
- Printf.sprintf "%s:%s" t.os_distribution t.os_version
+let base_image_tag t = Printf.sprintf "%s:%s" t.os_distribution t.os_version
let default_dir () =
let home = try Sys.getenv "HOME" with Not_found -> "/tmp" in
@@ -229,20 +242,23 @@ let default_dir () =
let now_iso8601 () =
let t = Unix.gettimeofday () in
let tm = Unix.gmtime t in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min tm.tm_sec
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (tm.tm_year + 1900)
+ (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
-(** Resolve the base image digest from the Docker registry.
- This calls `docker manifest inspect` which queries the registry
- without pulling. Can be slow (~10-15s). *)
+(** Resolve the base image digest from the Docker registry. This calls `docker
+ manifest inspect` which queries the registry without pulling. Can be slow
+ (~10-15s). *)
let resolve_base_digest t =
let tag = base_image_tag t in
- let cmd = Printf.sprintf
- "docker manifest inspect %s 2>/dev/null" (Filename.quote tag) in
+ let cmd =
+ Printf.sprintf "docker manifest inspect %s 2>/dev/null" (Filename.quote tag)
+ in
let ic = Unix.open_process_in cmd in
let buf = Buffer.create 4096 in
- (try while true do Buffer.add_char buf (input_char ic) done
+ (try
+ while true do
+ Buffer.add_char buf (input_char ic)
+ done
with End_of_file -> ());
ignore (Unix.close_process_in ic);
let json_str = Buffer.contents buf in
@@ -251,49 +267,65 @@ let resolve_base_digest t =
let open Yojson.Safe.Util in
let manifests = json |> member "manifests" |> to_list in
let arch = t.arch in
- let docker_arch = match arch with
+ let docker_arch =
+ match arch with
| "x86_64" | "amd64" -> "amd64"
| "aarch64" -> "arm64"
| a -> a
in
- List.find_map (fun m ->
- let plat = m |> member "platform" in
- let m_arch = plat |> member "architecture" |> to_string in
- let m_os = plat |> member "os" |> to_string in
- if m_arch = docker_arch && m_os = "linux" then
- Some (m |> member "digest" |> to_string)
- else None
- ) manifests
+ List.find_map
+ (fun m ->
+ let plat = m |> member "platform" in
+ let m_arch = plat |> member "architecture" |> to_string in
+ let m_os = plat |> member "os" |> to_string in
+ if m_arch = docker_arch && m_os = "linux" then
+ Some (m |> member "digest" |> to_string)
+ else None)
+ manifests
with _ -> None
(** Check if the base image digest is older than [max_age_days]. *)
let base_image_stale ?(max_age_days = 30) t =
match t.base_image_updated with
- | None -> true (* no timestamp = stale *)
- | Some ts ->
- (* Parse ISO-8601 timestamp *)
- try
- Scanf.sscanf ts "%4d-%2d-%2dT%2d:%2d:%2dZ"
- (fun year mon day hour min sec ->
- let tm = { Unix.tm_sec = sec; tm_min = min; tm_hour = hour;
- tm_mday = day; tm_mon = mon - 1; tm_year = year - 1900;
- tm_wday = 0; tm_yday = 0; tm_isdst = false } in
- let then_t, _ = Unix.mktime tm in
- let age_days = (Unix.gettimeofday () -. then_t) /. 86400. in
- age_days > float max_age_days)
- with _ -> true
+ | None -> true (* no timestamp = stale *)
+ | Some ts -> (
+ (* Parse ISO-8601 timestamp *)
+ try
+ Scanf.sscanf ts "%4d-%2d-%2dT%2d:%2d:%2dZ"
+ (fun year mon day hour min sec ->
+ let tm =
+ {
+ Unix.tm_sec = sec;
+ tm_min = min;
+ tm_hour = hour;
+ tm_mday = day;
+ tm_mon = mon - 1;
+ tm_year = year - 1900;
+ tm_wday = 0;
+ tm_yday = 0;
+ tm_isdst = false;
+ }
+ in
+ let then_t, _ = Unix.mktime tm in
+ let age_days = (Unix.gettimeofday () -. then_t) /. 86400. in
+ age_days > float max_age_days)
+ with _ -> true)
-(** Update the profile's base image digest by querying the registry.
- Returns the updated profile (caller must save it). *)
+(** Update the profile's base image digest by querying the registry. Returns the
+ updated profile (caller must save it). *)
let refresh_base_digest t =
match resolve_base_digest t with
| Some digest ->
- Ok { t with
- base_image_digest = Some digest;
- base_image_updated = Some (now_iso8601 ()) }
+ Ok
+ {
+ t with
+ base_image_digest = Some digest;
+ base_image_updated = Some (now_iso8601 ());
+ }
| None ->
- Error (`Msg (Printf.sprintf
- "Failed to resolve digest for %s" (base_image_tag t)))
+ Error
+ (`Msg
+ (Printf.sprintf "Failed to resolve digest for %s" (base_image_tag t)))
let track_limit t =
match t.target_mode.versions with
@@ -301,47 +333,46 @@ let track_limit t =
| Latest_n n -> Some n
let track_filter t =
- match t.target_mode.names with
- | All_names -> []
- | Names pkgs -> pkgs
+ match t.target_mode.names with All_names -> [] | Names pkgs -> pkgs
let target_mode_summary t =
- let v = match t.target_mode.versions with
+ let v =
+ match t.target_mode.versions with
| All_versions -> "all versions"
| Latest_n 1 -> "latest version"
- | Latest_n n -> Printf.sprintf "latest %d versions" n in
- let n = match t.target_mode.names with
+ | Latest_n n -> Printf.sprintf "latest %d versions" n
+ in
+ let n =
+ match t.target_mode.names with
| All_names -> "all packages"
- | Names l -> Printf.sprintf "%d packages" (List.length l) in
+ | Names l -> Printf.sprintf "%d packages" (List.length l)
+ in
Printf.sprintf "%s of %s" v n
let pp fmt t =
- Fmt.pf fmt "@[<v>\
- Profile: %s@,\
- Opam repos: %s@,\
- Odoc repo: %s@,\
- Opam-build repo: %s@,\
- Compiler: %s@,\
- Targets: %s@,\
- Docs: %b@,\
- Platform: %s-%s-%s@,\
- Base image: %s%s@,\
- Driver compiler: %s@,\
- HTML dir: %s\
- @]"
+ Fmt.pf fmt
+ "@[<v>Profile: %s@,\
+ Opam repos: %s@,\
+ Odoc repo: %s@,\
+ Opam-build repo: %s@,\
+ Compiler: %s@,\
+ Targets: %s@,\
+ Docs: %b@,\
+ Platform: %s-%s-%s@,\
+ Base image: %s%s@,\
+ Driver compiler: %s@,\
+ HTML dir: %s@]"
t.name
(String.concat ", " t.opam_repositories)
(Option.value ~default:"(none)" t.odoc_repo)
(Option.value ~default:"(none)" t.opam_build_repo)
(Option.value ~default:"(auto)" t.compiler)
- (target_mode_summary t)
- t.with_doc
- t.os_distribution t.os_version t.arch
+ (target_mode_summary t) t.with_doc t.os_distribution t.os_version t.arch
(match t.base_image_digest with
- | Some d -> String.sub d 0 (min 20 (String.length d)) ^ "..."
- | None -> "(not pinned)")
+ | Some d -> String.sub d 0 (min 20 (String.length d)) ^ "..."
+ | None -> "(not pinned)")
(match t.base_image_updated with
- | Some ts -> Printf.sprintf " (%s)" ts
- | None -> "")
+ | Some ts -> Printf.sprintf " (%s)" ts
+ | None -> "")
(if t.driver_compiler = "" then "(auto)" else t.driver_compiler)
(Option.value ~default:"(none)" t.html_dir)
File "day11/opam_layer/test/test_opam_layer.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/opam_layer/test/test_opam_layer.ml b/_build/default/day11/opam_layer/test/.formatted/test_opam_layer.ml
index cdac7a2..d73eeb9 100644
--- a/_build/default/day11/opam_layer/test/test_opam_layer.ml
+++ b/_build/default/day11/opam_layer/test/.formatted/test_opam_layer.ml
@@ -4,38 +4,43 @@ open Day11_opam_layer
open Day11_test_util.Test_util
let is_ok msg r = ok_or_fail msg r |> ignore
-
let pkg_list ss = List.map OpamPackage.of_string ss
(* ── Build_meta tests ────────────────────────────────────────────── *)
-let test_build_meta_roundtrip () = with_tmp_dir @@ fun layer_dir ->
- let m : Build_meta.t = {
- package = "yojson.2.2.2";
- deps = [
- { Build_meta.pkg = "dune.3.0"; hash = "abc123" };
- { Build_meta.pkg = "cppo.1.6"; hash = "def456" };
- ];
- stack = [ "abc123"; "def456"; "ocaml111" ];
- installed_libs = [ "yojson/yojson.cmi"; "yojson/META" ];
- installed_docs = [];
- patches = [];
- base_image = "debian-12-ocaml-5.2";
- cmd = "opam-build -v yojson.2.2.2";
- universe = "u-deadbeef";
- } in
+let test_build_meta_roundtrip () =
+ with_tmp_dir @@ fun layer_dir ->
+ let m : Build_meta.t =
+ {
+ package = "yojson.2.2.2";
+ deps =
+ [
+ { Build_meta.pkg = "dune.3.0"; hash = "abc123" };
+ { Build_meta.pkg = "cppo.1.6"; hash = "def456" };
+ ];
+ stack = [ "abc123"; "def456"; "ocaml111" ];
+ installed_libs = [ "yojson/yojson.cmi"; "yojson/META" ];
+ installed_docs = [];
+ patches = [];
+ base_image = "debian-12-ocaml-5.2";
+ cmd = "opam-build -v yojson.2.2.2";
+ universe = "u-deadbeef";
+ }
+ in
Build_meta.save layer_dir m |> is_ok "save";
Alcotest.(check bool) "exists" true (Build_meta.exists layer_dir);
let loaded = Build_meta.load layer_dir |> ok_or_fail "load" in
Alcotest.(check string) "package" "yojson.2.2.2" loaded.package;
- Alcotest.(check (list string)) "dep pkgs"
- [ "dune.3.0"; "cppo.1.6" ]
+ Alcotest.(check (list string))
+ "dep pkgs" [ "dune.3.0"; "cppo.1.6" ]
(List.map (fun (d : Build_meta.dep) -> d.pkg) loaded.deps);
- Alcotest.(check (list string)) "dep hashes"
- [ "abc123"; "def456" ]
+ Alcotest.(check (list string))
+ "dep hashes" [ "abc123"; "def456" ]
(List.map (fun (d : Build_meta.dep) -> d.hash) loaded.deps);
- Alcotest.(check (list string)) "stack"
- [ "abc123"; "def456"; "ocaml111" ] loaded.stack;
+ Alcotest.(check (list string))
+ "stack"
+ [ "abc123"; "def456"; "ocaml111" ]
+ loaded.stack;
Alcotest.(check string) "base_image" "debian-12-ocaml-5.2" loaded.base_image;
Alcotest.(check string) "cmd" "opam-build -v yojson.2.2.2" loaded.cmd;
Alcotest.(check string) "universe" "u-deadbeef" loaded.universe;
@@ -43,25 +48,29 @@ let test_build_meta_roundtrip () = with_tmp_dir @@ fun layer_dir ->
(* Backward-compat: an old build.json with deps as a plain string
list must still load. *)
-let test_build_meta_legacy_deps () = with_tmp_dir @@ fun layer_dir ->
- let legacy_json = {|{
+let test_build_meta_legacy_deps () =
+ with_tmp_dir @@ fun layer_dir ->
+ let legacy_json =
+ {|{
"package": "yojson.2.2.2",
"deps": ["dune.3.0", "cppo.1.6"],
"installed_libs": [],
"installed_docs": [],
"patches": []
- }|} in
+ }|}
+ in
let path = Fpath.(layer_dir / "build.json") in
write_file path legacy_json;
let loaded = Build_meta.load layer_dir |> ok_or_fail "load legacy" in
- Alcotest.(check (list string)) "dep pkgs from legacy"
- [ "dune.3.0"; "cppo.1.6" ]
+ Alcotest.(check (list string))
+ "dep pkgs from legacy" [ "dune.3.0"; "cppo.1.6" ]
(List.map (fun (d : Build_meta.dep) -> d.pkg) loaded.deps);
- Alcotest.(check (list string)) "dep hashes empty for legacy"
- [ ""; "" ]
+ Alcotest.(check (list string))
+ "dep hashes empty for legacy" [ ""; "" ]
(List.map (fun (d : Build_meta.dep) -> d.hash) loaded.deps)
-let test_build_meta_missing () = with_tmp_dir @@ fun layer_dir ->
+let test_build_meta_missing () =
+ with_tmp_dir @@ fun layer_dir ->
Alcotest.(check bool) "exists false" false (Build_meta.exists layer_dir);
match Build_meta.load layer_dir with
| Ok _ -> Alcotest.fail "should not load missing"
@@ -69,65 +78,77 @@ let test_build_meta_missing () = with_tmp_dir @@ fun layer_dir ->
(* ── Installed_files tests ───────────────────────────────────────── *)
-let test_scan_libs () = with_tmp_dir @@ fun dir ->
- let lib_dir = Fpath.(dir / "fs" / "home" / "opam" / ".opam" / "default" / "lib" / "yojson") in
+let test_scan_libs () =
+ with_tmp_dir @@ fun dir ->
+ let lib_dir =
+ Fpath.(
+ dir / "fs" / "home" / "opam" / ".opam" / "default" / "lib" / "yojson")
+ in
mkdir lib_dir;
write_file Fpath.(lib_dir / "yojson.cmi") "";
write_file Fpath.(lib_dir / "yojson.cmxa") "";
write_file Fpath.(lib_dir / "META") "";
write_file Fpath.(lib_dir / "README.md") "";
let files = Installed_files.scan_libs ~layer_dir:dir in
- Alcotest.(check bool) "has cmi"
- true (List.mem "yojson/yojson.cmi" files);
- Alcotest.(check bool) "has META"
- true (List.mem "yojson/META" files);
- Alcotest.(check bool) "no README"
- false (List.mem "yojson/README.md" files)
-
-let test_scan_docs () = with_tmp_dir @@ fun dir ->
- let doc_dir = Fpath.(dir / "fs" / "home" / "opam" / ".opam" / "default" / "doc" / "yojson") in
+ Alcotest.(check bool) "has cmi" true (List.mem "yojson/yojson.cmi" files);
+ Alcotest.(check bool) "has META" true (List.mem "yojson/META" files);
+ Alcotest.(check bool) "no README" false (List.mem "yojson/README.md" files)
+
+let test_scan_docs () =
+ with_tmp_dir @@ fun dir ->
+ let doc_dir =
+ Fpath.(
+ dir / "fs" / "home" / "opam" / ".opam" / "default" / "doc" / "yojson")
+ in
mkdir doc_dir;
write_file Fpath.(doc_dir / "index.mld") "";
write_file Fpath.(doc_dir / "odoc-config.sexp") "";
write_file Fpath.(doc_dir / "README") "";
let files = Installed_files.scan_docs ~layer_dir:dir in
- Alcotest.(check bool) "has mld"
- true (List.mem "yojson/index.mld" files);
- Alcotest.(check bool) "has sexp"
- true (List.mem "yojson/odoc-config.sexp" files);
- Alcotest.(check bool) "no README"
- false (List.mem "yojson/README" files)
-
-let test_scan_empty_layer () = with_tmp_dir @@ fun dir ->
+ Alcotest.(check bool) "has mld" true (List.mem "yojson/index.mld" files);
+ Alcotest.(check bool)
+ "has sexp" true
+ (List.mem "yojson/odoc-config.sexp" files);
+ Alcotest.(check bool) "no README" false (List.mem "yojson/README" files)
+
+let test_scan_empty_layer () =
+ with_tmp_dir @@ fun dir ->
let files = Installed_files.scan_libs ~layer_dir:dir in
Alcotest.(check (list string)) "empty" [] files
(* ── Opam_repo tests ─────────────────────────────────────────────── *)
-let test_opam_repo_create () = with_tmp_dir @@ fun dir ->
+let test_opam_repo_create () =
+ with_tmp_dir @@ fun dir ->
let repo_dir = Opam_repo.create dir |> ok_or_fail "create" in
- Alcotest.(check bool) "repo file exists"
- true (Bos.OS.File.exists Fpath.(repo_dir / "repo") |> Result.get_ok)
+ Alcotest.(check bool)
+ "repo file exists" true
+ (Bos.OS.File.exists Fpath.(repo_dir / "repo") |> Result.get_ok)
-let test_opam_repo_populate () = with_tmp_dir @@ fun dir ->
+let test_opam_repo_populate () =
+ with_tmp_dir @@ fun dir ->
let src_repo = Fpath.(dir / "opam-repo") in
let pkg_dir = Fpath.(src_repo / "packages" / "yojson" / "yojson.2.2.2") in
mkdir pkg_dir;
write_file Fpath.(pkg_dir / "opam") {|opam-version: "2.0"|};
let tgt_repo = Opam_repo.create dir |> ok_or_fail "create" in
- Opam_repo.populate ~opam_repo:tgt_repo
- ~opam_repositories:[ src_repo ]
+ Opam_repo.populate ~opam_repo:tgt_repo ~opam_repositories:[ src_repo ]
(pkg_list [ "yojson.2.2.2" ])
|> is_ok "populate";
- let copied = Fpath.(tgt_repo / "packages" / "yojson" / "yojson.2.2.2" / "opam") in
- Alcotest.(check bool) "opam file copied"
- true (Bos.OS.File.exists copied |> Result.get_ok)
+ let copied =
+ Fpath.(tgt_repo / "packages" / "yojson" / "yojson.2.2.2" / "opam")
+ in
+ Alcotest.(check bool)
+ "opam file copied" true
+ (Bos.OS.File.exists copied |> Result.get_ok)
-let test_snapshot_to_layer_no_patches () = with_tmp_dir @@ fun dir ->
+let test_snapshot_to_layer_no_patches () =
+ with_tmp_dir @@ fun dir ->
let src_repo = Fpath.(dir / "src-repo") in
let pkg_dir = Fpath.(src_repo / "packages" / "fmt" / "fmt.0.9.0") in
mkdir pkg_dir;
- write_file Fpath.(pkg_dir / "opam")
+ write_file
+ Fpath.(pkg_dir / "opam")
{|opam-version: "2.0"
synopsis: "test"
build: ["dune" "build"]
@@ -136,25 +157,26 @@ build: ["dune" "build"]
write_file Fpath.(pkg_dir / "files" / "extra.txt") "hello";
let layer_dir = Fpath.(dir / "layer") in
mkdir layer_dir;
- Opam_repo.snapshot_to_layer ~layer_dir
- ~opam_repositories:[ src_repo ]
+ Opam_repo.snapshot_to_layer ~layer_dir ~opam_repositories:[ src_repo ]
(OpamPackage.of_string "fmt.0.9.0")
|> is_ok "snapshot";
let slice_pkg =
Fpath.(layer_dir / "opam-repository" / "packages" / "fmt" / "fmt.0.9.0")
in
- Alcotest.(check bool) "opam in slice" true
+ Alcotest.(check bool)
+ "opam in slice" true
(Bos.OS.File.exists Fpath.(slice_pkg / "opam") |> Result.get_ok);
- Alcotest.(check bool) "files copied" true
+ Alcotest.(check bool)
+ "files copied" true
(Bos.OS.File.exists Fpath.(slice_pkg / "files" / "extra.txt")
- |> Result.get_ok)
+ |> Result.get_ok)
-let test_snapshot_to_layer_with_patches () = with_tmp_dir @@ fun dir ->
+let test_snapshot_to_layer_with_patches () =
+ with_tmp_dir @@ fun dir ->
let src_repo = Fpath.(dir / "src-repo") in
let pkg_dir = Fpath.(src_repo / "packages" / "fmt" / "fmt.0.9.0") in
mkdir pkg_dir;
- write_file Fpath.(pkg_dir / "opam")
- {|opam-version: "2.0"
+ write_file Fpath.(pkg_dir / "opam") {|opam-version: "2.0"
synopsis: "test"
|};
let patches_dir = Fpath.(dir / "patches") in
@@ -163,8 +185,7 @@ synopsis: "test"
write_file patch_path "--- a\n+++ b\n";
let layer_dir = Fpath.(dir / "layer") in
mkdir layer_dir;
- Opam_repo.snapshot_to_layer ~layer_dir
- ~opam_repositories:[ src_repo ]
+ Opam_repo.snapshot_to_layer ~layer_dir ~opam_repositories:[ src_repo ]
~patches:[ patch_path ]
(OpamPackage.of_string "fmt.0.9.0")
|> is_ok "snapshot";
@@ -173,25 +194,26 @@ synopsis: "test"
in
let opam_path = Fpath.(slice_pkg / "opam") in
let opam_text = Bos.OS.File.read opam_path |> ok_or_fail "read opam" in
- Alcotest.(check bool) "patches: field present"
- true
+ Alcotest.(check bool)
+ "patches: field present" true
(let needle = "patches:" in
try
let _ = Str.search_forward (Str.regexp_string needle) opam_text 0 in
true
with Not_found -> false);
- Alcotest.(check bool) "patch file copied" true
+ Alcotest.(check bool)
+ "patch file copied" true
(Bos.OS.File.exists Fpath.(slice_pkg / "files" / "000-fix.patch")
- |> Result.get_ok)
+ |> Result.get_ok)
(* ── Opamh tests ─────────────────────────────────────────────────── *)
let test_compiler_packages () =
let names = List.map OpamPackage.Name.to_string Opamh.compiler_packages in
- Alcotest.(check bool) "has ocaml"
- true (List.mem "ocaml" names);
- Alcotest.(check bool) "has ocaml-base-compiler"
- true (List.mem "ocaml-base-compiler" names)
+ Alcotest.(check bool) "has ocaml" true (List.mem "ocaml" names);
+ Alcotest.(check bool)
+ "has ocaml-base-compiler" true
+ (List.mem "ocaml-base-compiler" names)
(* ── Test registration ───────────────────────────────────────────── *)
@@ -220,7 +242,6 @@ let () =
test_snapshot_to_layer_with_patches;
] );
( "Opamh",
- [
- Alcotest.test_case "compiler_packages" `Quick test_compiler_packages;
- ] );
+ [ Alcotest.test_case "compiler_packages" `Quick test_compiler_packages ]
+ );
]
File "day11/lib/history.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/history.ml b/_build/default/day11/lib/.formatted/history.ml
index 5c708ff..ac6d8c6 100644
--- a/_build/default/day11/lib/history.ml
+++ b/_build/default/day11/lib/.formatted/history.ml
@@ -9,29 +9,28 @@ type entry = {
}
let entry_to_json (e : entry) : Yojson.Safe.t =
- let fields = [
- ("ts", `String e.ts);
- ("run", `String e.run);
- ("build_hash", `String e.build_hash);
- ("status", `String e.status);
- ("category", `String e.category);
- ("blessed", `Bool e.blessed);
- ] in
- let fields = match e.error with
- | Some v -> fields @ [("error", `String v)]
+ let fields =
+ [
+ ("ts", `String e.ts);
+ ("run", `String e.run);
+ ("build_hash", `String e.build_hash);
+ ("status", `String e.status);
+ ("category", `String e.category);
+ ("blessed", `Bool e.blessed);
+ ]
+ in
+ let fields =
+ match e.error with
+ | Some v -> fields @ [ ("error", `String v) ]
| None -> fields
in
`Assoc fields
let string_of_json key assoc =
- match List.assoc_opt key assoc with
- | Some (`String s) -> Some s
- | _ -> None
+ match List.assoc_opt key assoc with Some (`String s) -> Some s | _ -> None
let bool_of_json key assoc =
- match List.assoc_opt key assoc with
- | Some (`Bool b) -> Some b
- | _ -> None
+ match List.assoc_opt key assoc with Some (`Bool b) -> Some b | _ -> None
let string_opt_of_json key assoc =
match List.assoc_opt key assoc with
@@ -41,21 +40,27 @@ let string_opt_of_json key assoc =
let entry_of_json (json : Yojson.Safe.t) : entry option =
match json with
- | `Assoc assoc ->
- (* [compiler], [failed_dep], [failed_dep_hash] may be present in
+ | `Assoc assoc -> (
+ (* [compiler], [failed_dep], [failed_dep_hash] may be present in
legacy entries — read tolerantly and ignore them. *)
- (match string_of_json "ts" assoc,
- string_of_json "run" assoc,
- string_of_json "build_hash" assoc,
- string_of_json "status" assoc,
- string_of_json "category" assoc,
- bool_of_json "blessed" assoc,
- string_opt_of_json "error" assoc
- with
- | Some ts, Some run, Some build_hash, Some status, Some category,
- Some blessed, Some error ->
- Some { ts; run; build_hash; status; category; blessed; error }
- | _ -> None)
+ match
+ ( string_of_json "ts" assoc,
+ string_of_json "run" assoc,
+ string_of_json "build_hash" assoc,
+ string_of_json "status" assoc,
+ string_of_json "category" assoc,
+ bool_of_json "blessed" assoc,
+ string_opt_of_json "error" assoc )
+ with
+ | ( Some ts,
+ Some run,
+ Some build_hash,
+ Some status,
+ Some category,
+ Some blessed,
+ Some error ) ->
+ Some { ts; run; build_hash; status; category; blessed; error }
+ | _ -> None)
| _ -> None
let history_path ~packages_dir ~pkg_str =
@@ -63,10 +68,9 @@ let history_path ~packages_dir ~pkg_str =
let mkdir_p path =
let rec create dir =
- if not (Sys.file_exists dir) then begin
+ if not (Sys.file_exists dir) then (
create (Filename.dirname dir);
- try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
- end
+ try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
in
create path
@@ -81,14 +85,15 @@ let path_mutexes_lock = Mutex.create ()
let mutex_for path =
Mutex.lock path_mutexes_lock;
- Fun.protect ~finally:(fun () -> Mutex.unlock path_mutexes_lock)
+ Fun.protect
+ ~finally:(fun () -> Mutex.unlock path_mutexes_lock)
(fun () ->
match Hashtbl.find_opt path_mutexes path with
| Some m -> m
| None ->
- let m = Eio.Mutex.create () in
- Hashtbl.replace path_mutexes path m;
- m)
+ let m = Eio.Mutex.create () in
+ Hashtbl.replace path_mutexes path m;
+ m)
let append ~packages_dir ~pkg_str entry =
let path = history_path ~packages_dir ~pkg_str in
@@ -96,42 +101,52 @@ let append ~packages_dir ~pkg_str entry =
let line = Yojson.Safe.to_string (entry_to_json entry) in
let mu = mutex_for path in
Eio.Mutex.use_rw ~protect:true mu @@ fun () ->
- let fd = Unix.openfile path [Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT] 0o644 in
- Fun.protect ~finally:(fun () -> Unix.close fd) (fun () ->
- Unix.lockf fd Unix.F_LOCK 0;
- let line = line ^ "\n" in
- let len = String.length line in
- let written = ref 0 in
- while !written < len do
- written := !written + Unix.write_substring fd line !written (len - !written)
- done)
+ let fd =
+ Unix.openfile path [ Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT ] 0o644
+ in
+ Fun.protect
+ ~finally:(fun () -> Unix.close fd)
+ (fun () ->
+ Unix.lockf fd Unix.F_LOCK 0;
+ let line = line ^ "\n" in
+ let len = String.length line in
+ let written = ref 0 in
+ while !written < len do
+ written :=
+ !written + Unix.write_substring fd line !written (len - !written)
+ done)
let read ~packages_dir ~pkg_str =
let path = history_path ~packages_dir ~pkg_str in
if not (Sys.file_exists path) then []
- else begin
+ else
let ic = open_in path in
- Fun.protect ~finally:(fun () -> close_in ic) (fun () ->
- let entries = ref [] in
- (try while true do
- let line = input_line ic in
- if String.length line > 0 then begin
- let json = Yojson.Safe.from_string line in
- match entry_of_json json with
- | Some e -> entries := e :: !entries
- | None -> ()
- end
- done with End_of_file -> ());
- !entries)
- end
+ Fun.protect
+ ~finally:(fun () -> close_in ic)
+ (fun () ->
+ let entries = ref [] in
+ (try
+ while true do
+ let line = input_line ic in
+ if String.length line > 0 then
+ let json = Yojson.Safe.from_string line in
+ match entry_of_json json with
+ | Some e -> entries := e :: !entries
+ | None -> ()
+ done
+ with End_of_file -> ());
+ !entries)
let read_latest ~packages_dir ~pkg_str =
let entries = read ~packages_dir ~pkg_str in
let seen = Hashtbl.create 16 in
- List.filter (fun (e : entry) ->
- if Hashtbl.mem seen e.build_hash then false
- else begin Hashtbl.add seen e.build_hash true; true end
- ) entries
+ List.filter
+ (fun (e : entry) ->
+ if Hashtbl.mem seen e.build_hash then false
+ else (
+ Hashtbl.add seen e.build_hash true;
+ true))
+ entries
let read_blessed ~packages_dir ~pkg_str =
let entries = read ~packages_dir ~pkg_str in
@@ -139,65 +154,64 @@ let read_blessed ~packages_dir ~pkg_str =
let parse_iso8601 s =
try
- Scanf.sscanf s "%4d-%2d-%2dT%2d:%2d:%2d"
- (fun year month day hour min sec ->
- let tm = {
- Unix.tm_sec = sec;
- tm_min = min;
- tm_hour = hour;
- tm_mday = day;
- tm_mon = month - 1;
- tm_year = year - 1900;
- tm_wday = 0;
- tm_yday = 0;
- tm_isdst = false;
- } in
- let (t, _) = Unix.mktime tm in
+ Scanf.sscanf s "%4d-%2d-%2dT%2d:%2d:%2d" (fun year month day hour min sec ->
+ let tm =
+ {
+ Unix.tm_sec = sec;
+ tm_min = min;
+ tm_hour = hour;
+ tm_mday = day;
+ tm_mon = month - 1;
+ tm_year = year - 1900;
+ tm_wday = 0;
+ tm_yday = 0;
+ tm_isdst = false;
+ }
+ in
+ let t, _ = Unix.mktime tm in
t)
with _ -> 0.0
let compact ~packages_dir ~pkg_str ~max_age_days =
let path = history_path ~packages_dir ~pkg_str in
if not (Sys.file_exists path) then ()
- else begin
+ else
let entries = List.rev (read ~packages_dir ~pkg_str) in
let now = Unix.gettimeofday () in
let cutoff = now -. (float_of_int max_age_days *. 86400.0) in
let rec process acc = function
| [] -> List.rev acc
- | e :: rest ->
- let is_old = parse_iso8601 e.ts < cutoff in
- if not is_old then
- process (e :: acc) rest
- else begin
- let rec collect_run run remaining =
- match remaining with
- | next :: tail
- when next.status = e.status
- && next.build_hash = e.build_hash
- && parse_iso8601 next.ts < cutoff ->
- collect_run (next :: run) tail
- | _ -> (List.rev run, remaining)
- in
- let (run, remaining) = collect_run [e] rest in
- match run with
- | [single] -> process (single :: acc) remaining
- | first :: _ ->
- let last = List.nth run (List.length run - 1) in
- if first == last then
- process (first :: acc) remaining
- else
- process (last :: first :: acc) remaining
- | [] -> process acc remaining
- end
+ | e :: rest -> (
+ let is_old = parse_iso8601 e.ts < cutoff in
+ if not is_old then process (e :: acc) rest
+ else
+ let rec collect_run run remaining =
+ match remaining with
+ | next :: tail
+ when next.status = e.status
+ && next.build_hash = e.build_hash
+ && parse_iso8601 next.ts < cutoff ->
+ collect_run (next :: run) tail
+ | _ -> (List.rev run, remaining)
+ in
+ let run, remaining = collect_run [ e ] rest in
+ match run with
+ | [ single ] -> process (single :: acc) remaining
+ | first :: _ ->
+ let last = List.nth run (List.length run - 1) in
+ if first == last then process (first :: acc) remaining
+ else process (last :: first :: acc) remaining
+ | [] -> process acc remaining)
in
let compacted = process [] entries in
let tmp_path = path ^ ".tmp" in
let oc = open_out tmp_path in
- Fun.protect ~finally:(fun () -> close_out oc) (fun () ->
- List.iter (fun e ->
- output_string oc (Yojson.Safe.to_string (entry_to_json e));
- output_char oc '\n'
- ) compacted);
+ Fun.protect
+ ~finally:(fun () -> close_out oc)
+ (fun () ->
+ List.iter
+ (fun e ->
+ output_string oc (Yojson.Safe.to_string (entry_to_json e));
+ output_char oc '\n')
+ compacted);
Sys.rename tmp_path path
- end
File "day11/lib/status_index.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/status_index.ml b/_build/default/day11/lib/.formatted/status_index.ml
index 95277d..565677b 100644
--- a/_build/default/day11/lib/status_index.ml
+++ b/_build/default/day11/lib/.formatted/status_index.ml
@@ -1,5 +1,7 @@
-let src = Logs.Src.create "day11.status_index"
+let src =
+ Logs.Src.create "day11.status_index"
~doc:"Status index (status.json) read/write"
+
module Log = (val Logs.src_log src)
type change = {
@@ -25,99 +27,109 @@ let totals_to_json (t : (string * int) list) : Yojson.Safe.t =
let totals_of_json (json : Yojson.Safe.t) : (string * int) list =
match json with
| `Assoc assoc ->
- List.filter_map (fun (k, v) ->
- match v with
- | `Int n -> Some (k, n)
- | _ -> None
- ) assoc
+ List.filter_map
+ (fun (k, v) -> match v with `Int n -> Some (k, n) | _ -> None)
+ assoc
| _ -> []
let change_to_json (c : change) : Yojson.Safe.t =
- `Assoc [
- ("package", `String c.package);
- ("build_hash", `String c.build_hash);
- ("blessed", `Bool c.blessed);
- ("from", `String c.from_status);
- ("to", `String c.to_status);
- ]
+ `Assoc
+ [
+ ("package", `String c.package);
+ ("build_hash", `String c.build_hash);
+ ("blessed", `Bool c.blessed);
+ ("from", `String c.from_status);
+ ("to", `String c.to_status);
+ ]
let change_of_json (json : Yojson.Safe.t) : change option =
match json with
- | `Assoc assoc ->
- let s key =
- match List.assoc_opt key assoc with
- | Some (`String s) -> Some s
- | _ -> None
- in
- let b key =
- match List.assoc_opt key assoc with
- | Some (`Bool b) -> Some b
- | _ -> None
- in
- (match s "package", s "build_hash", b "blessed", s "from", s "to" with
- | Some package, Some build_hash, Some blessed, Some from_status, Some to_status ->
- Some { package; build_hash; blessed; from_status; to_status }
- | _ -> None)
+ | `Assoc assoc -> (
+ let s key =
+ match List.assoc_opt key assoc with
+ | Some (`String s) -> Some s
+ | _ -> None
+ in
+ let b key =
+ match List.assoc_opt key assoc with
+ | Some (`Bool b) -> Some b
+ | _ -> None
+ in
+ match (s "package", s "build_hash", b "blessed", s "from", s "to") with
+ | ( Some package,
+ Some build_hash,
+ Some blessed,
+ Some from_status,
+ Some to_status ) ->
+ Some { package; build_hash; blessed; from_status; to_status }
+ | _ -> None)
| _ -> None
let to_json (t : t) : Yojson.Safe.t =
- `Assoc [
- ("generated", `String t.generated);
- ("run_id", `String t.run_id);
- ("blessed_totals", totals_to_json t.blessed_totals);
- ("non_blessed_totals", totals_to_json t.non_blessed_totals);
- ("changes_since_last", `List (List.map change_to_json t.changes));
- ("new_packages", `List (List.map (fun s -> `String s) t.new_packages));
- ]
+ `Assoc
+ [
+ ("generated", `String t.generated);
+ ("run_id", `String t.run_id);
+ ("blessed_totals", totals_to_json t.blessed_totals);
+ ("non_blessed_totals", totals_to_json t.non_blessed_totals);
+ ("changes_since_last", `List (List.map change_to_json t.changes));
+ ("new_packages", `List (List.map (fun s -> `String s) t.new_packages));
+ ]
let of_json (json : Yojson.Safe.t) : t option =
match json with
- | `Assoc assoc ->
- let s key =
- match List.assoc_opt key assoc with
- | Some (`String s) -> Some s
- | _ -> None
- in
- (match s "generated", s "run_id" with
- | Some generated, Some run_id ->
- let changes =
- match List.assoc_opt "changes_since_last" assoc with
- | Some (`List l) -> List.filter_map change_of_json l
- | _ -> []
- in
- let new_packages =
- match List.assoc_opt "new_packages" assoc with
- | Some (`List l) ->
- List.filter_map (fun j ->
- match j with `String s -> Some s | _ -> None
- ) l
- | _ -> []
- in
- Some {
- generated;
- run_id;
- blessed_totals = totals_of_json
- (match List.assoc_opt "blessed_totals" assoc with
- | Some j -> j | None -> `Assoc []);
- non_blessed_totals = totals_of_json
- (match List.assoc_opt "non_blessed_totals" assoc with
- | Some j -> j | None -> `Assoc []);
- changes;
- new_packages;
- }
- | _ -> None)
+ | `Assoc assoc -> (
+ let s key =
+ match List.assoc_opt key assoc with
+ | Some (`String s) -> Some s
+ | _ -> None
+ in
+ match (s "generated", s "run_id") with
+ | Some generated, Some run_id ->
+ let changes =
+ match List.assoc_opt "changes_since_last" assoc with
+ | Some (`List l) -> List.filter_map change_of_json l
+ | _ -> []
+ in
+ let new_packages =
+ match List.assoc_opt "new_packages" assoc with
+ | Some (`List l) ->
+ List.filter_map
+ (fun j -> match j with `String s -> Some s | _ -> None)
+ l
+ | _ -> []
+ in
+ Some
+ {
+ generated;
+ run_id;
+ blessed_totals =
+ totals_of_json
+ (match List.assoc_opt "blessed_totals" assoc with
+ | Some j -> j
+ | None -> `Assoc []);
+ non_blessed_totals =
+ totals_of_json
+ (match List.assoc_opt "non_blessed_totals" assoc with
+ | Some j -> j
+ | None -> `Assoc []);
+ changes;
+ new_packages;
+ }
+ | _ -> None)
| _ -> None
let iso8601_now () =
let t = Unix.gettimeofday () in
let tm = Unix.gmtime t in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
- (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
- tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (tm.Unix.tm_year + 1900)
+ (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
+ tm.Unix.tm_sec
let incr_totals totals category =
match List.assoc_opt category totals with
- | Some n -> (category, n + 1) :: List.filter (fun (k, _) -> k <> category) totals
+ | Some n ->
+ (category, n + 1) :: List.filter (fun (k, _) -> k <> category) totals
| None -> (category, 1) :: totals
let list_subdirs dir =
@@ -127,8 +139,8 @@ let list_subdirs dir =
Sys.readdir dir_s
|> Array.to_list
|> List.filter (fun name ->
- let path = Filename.concat dir_s name in
- try Sys.is_directory path with Sys_error _ -> false)
+ let path = Filename.concat dir_s name in
+ try Sys.is_directory path with Sys_error _ -> false)
let generate ~packages_dir ~run_id ~previous:_ =
let pkg_dirs = list_subdirs packages_dir in
@@ -138,76 +150,95 @@ let generate ~packages_dir ~run_id ~previous:_ =
let new_packages = ref [] in
let os_dir = Fpath.parent packages_dir in
let effective_category (e : History.entry) =
- if e.category = "build_failure" && String.length e.build_hash > 0 && e.build_hash <> "none" then
- let layer_json = Fpath.to_string Fpath.(os_dir / e.build_hash / "layer.json") in
+ if
+ e.category = "build_failure"
+ && String.length e.build_hash > 0
+ && e.build_hash <> "none"
+ then
+ let layer_json =
+ Fpath.to_string Fpath.(os_dir / e.build_hash / "layer.json")
+ in
match Yojson.Safe.from_file layer_json with
- | `Assoc assoc ->
- (match List.assoc_opt "exit_status" assoc with
- | Some (`Int (-1)) -> "dependency_failure"
- | _ -> e.category)
+ | `Assoc assoc -> (
+ match List.assoc_opt "exit_status" assoc with
+ | Some (`Int -1) -> "dependency_failure"
+ | _ -> e.category)
| _ -> e.category
| exception _ -> e.category
- else
- e.category
+ else e.category
in
- List.iter (fun pkg_str ->
- let latest_entries = History.read_latest ~packages_dir ~pkg_str in
- (* "Live" blessing = most recent blessed=true entry from the
+ List.iter
+ (fun pkg_str ->
+ let latest_entries = History.read_latest ~packages_dir ~pkg_str in
+ (* "Live" blessing = most recent blessed=true entry from the
current run. A build_hash that was blessed in an older run but
isn't part of the current solution is superseded — it's no
longer the canonical universe for this package, so we count it
with the non-blessed siblings rather than as a live-blessed. *)
- let live_blessed = List.find_opt (fun (e : History.entry) ->
- e.blessed && e.run = run_id
- ) latest_entries in
- (match live_blessed with
- | Some e -> blessed_totals := incr_totals !blessed_totals (effective_category e)
- | None -> ());
- List.iter (fun (e : History.entry) ->
- let is_live = match live_blessed with
- | Some lb -> lb.build_hash = e.build_hash
- | None -> false
+ let live_blessed =
+ List.find_opt
+ (fun (e : History.entry) -> e.blessed && e.run = run_id)
+ latest_entries
+ in
+ (match live_blessed with
+ | Some e ->
+ blessed_totals := incr_totals !blessed_totals (effective_category e)
+ | None -> ());
+ List.iter
+ (fun (e : History.entry) ->
+ let is_live =
+ match live_blessed with
+ | Some lb -> lb.build_hash = e.build_hash
+ | None -> false
+ in
+ if not is_live then
+ non_blessed_totals :=
+ incr_totals !non_blessed_totals (effective_category e))
+ latest_entries;
+ let all_entries = History.read ~packages_dir ~pkg_str in
+ let seen_hashes = Hashtbl.create 16 in
+ List.iter
+ (fun (e : History.entry) ->
+ if not (Hashtbl.mem seen_hashes e.build_hash) then (
+ Hashtbl.add seen_hashes e.build_hash true;
+ if e.run = run_id then
+ let prev =
+ List.find_opt
+ (fun (e2 : History.entry) ->
+ e2.build_hash = e.build_hash && e2.run <> run_id)
+ all_entries
+ in
+ match prev with
+ | Some prev_entry
+ when effective_category prev_entry <> effective_category e ->
+ changes :=
+ {
+ package = pkg_str;
+ build_hash = e.build_hash;
+ blessed = e.blessed;
+ from_status = effective_category prev_entry;
+ to_status = effective_category e;
+ }
+ :: !changes
+ | _ -> ()))
+ all_entries;
+ let has_old_entries =
+ List.exists (fun (e : History.entry) -> e.run <> run_id) all_entries
in
- if not is_live then
- non_blessed_totals := incr_totals !non_blessed_totals (effective_category e)
- ) latest_entries;
- let all_entries = History.read ~packages_dir ~pkg_str in
- let seen_hashes = Hashtbl.create 16 in
- List.iter (fun (e : History.entry) ->
- if not (Hashtbl.mem seen_hashes e.build_hash) then begin
- Hashtbl.add seen_hashes e.build_hash true;
- if e.run = run_id then begin
- let prev = List.find_opt (fun (e2 : History.entry) ->
- e2.build_hash = e.build_hash && e2.run <> run_id
- ) all_entries in
- match prev with
- | Some prev_entry when (effective_category prev_entry) <> (effective_category e) ->
- changes := {
- package = pkg_str;
- build_hash = e.build_hash;
- blessed = e.blessed;
- from_status = effective_category prev_entry;
- to_status = effective_category e;
- } :: !changes
- | _ -> ()
- end
- end
- ) all_entries;
- let has_old_entries = List.exists (fun (e : History.entry) ->
- e.run <> run_id
- ) all_entries in
- if (not has_old_entries) && all_entries <> [] then
- new_packages := pkg_str :: !new_packages
- ) pkg_dirs;
+ if (not has_old_entries) && all_entries <> [] then
+ new_packages := pkg_str :: !new_packages)
+ pkg_dirs;
let sum totals = List.fold_left (fun acc (_, n) -> acc + n) 0 totals in
(* App level: always shown regardless of --verbosity, so build
progress (and whether generate_status runs incrementally or only
at completion) is visible in the daemon log by default. *)
- Log.app (fun f -> f "generated status (run %s): %d pkg-dirs scanned, \
- blessed=%d non_blessed=%d changes=%d new=%d"
- run_id (List.length pkg_dirs) (sum !blessed_totals)
- (sum !non_blessed_totals) (List.length !changes)
- (List.length !new_packages));
+ Log.app (fun f ->
+ f
+ "generated status (run %s): %d pkg-dirs scanned, blessed=%d \
+ non_blessed=%d changes=%d new=%d"
+ run_id (List.length pkg_dirs) (sum !blessed_totals)
+ (sum !non_blessed_totals) (List.length !changes)
+ (List.length !new_packages));
{
generated = iso8601_now ();
run_id;
@@ -224,32 +255,36 @@ let write ~dir t =
let json_str = Yojson.Safe.pretty_to_string (to_json t) in
let tmp_path = path ^ ".tmp" in
let oc = open_out tmp_path in
- Fun.protect ~finally:(fun () -> close_out oc) (fun () ->
- output_string oc json_str;
- output_char oc '\n');
+ Fun.protect
+ ~finally:(fun () -> close_out oc)
+ (fun () ->
+ output_string oc json_str;
+ output_char oc '\n');
Sys.rename tmp_path path
let read ~dir =
let path = status_path dir in
- if not (Sys.file_exists path) then begin
+ if not (Sys.file_exists path) then (
(* Normal early in a fresh run: status.json isn't written until the
first [generate_status] pass completes. At info so "page shows
no totals" is explainable from the log (file genuinely absent vs.
a parse failure below). *)
Log.info (fun f -> f "status.json not present yet: %s" path);
- None
- end
+ None)
else
match Yojson.Safe.from_file path with
| exception exn ->
- Log.warn (fun f -> f "status.json unreadable / invalid JSON (%s): %s"
- path (Printexc.to_string exn));
- None
- | json ->
- match of_json json with
- | Some _ as r -> r
- | None ->
- Log.warn (fun f -> f "status.json parsed as JSON but failed \
- structural validation (missing or non-string generated/run_id?): \
- %s" path);
+ Log.warn (fun f ->
+ f "status.json unreadable / invalid JSON (%s): %s" path
+ (Printexc.to_string exn));
None
+ | json -> (
+ match of_json json with
+ | Some _ as r -> r
+ | None ->
+ Log.warn (fun f ->
+ f
+ "status.json parsed as JSON but failed structural validation \
+ (missing or non-string generated/run_id?): %s"
+ path);
+ None)
File "day11/lib/run_log.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/run_log.ml b/_build/default/day11/lib/.formatted/run_log.ml
index 63bbcd8..53a0790 100644
--- a/_build/default/day11/lib/run_log.ml
+++ b/_build/default/day11/lib/.formatted/run_log.ml
@@ -1,8 +1,4 @@
-type t = {
- id : string;
- start_time : float;
- run_dir : string;
-}
+type t = { id : string; start_time : float; run_dir : string }
type summary = {
run_id : string;
@@ -17,28 +13,19 @@ type summary = {
}
let log_base_dir = ref "/var/log/day11"
-
let set_log_base_dir dir = log_base_dir := dir
let generate_run_id () =
let t = Unix.gettimeofday () in
let tm = Unix.localtime t in
- Printf.sprintf "%04d-%02d-%02d-%02d%02d%02d"
- (tm.Unix.tm_year + 1900)
- (tm.Unix.tm_mon + 1)
- tm.Unix.tm_mday
- tm.Unix.tm_hour
- tm.Unix.tm_min
+ Printf.sprintf "%04d-%02d-%02d-%02d%02d%02d" (tm.Unix.tm_year + 1900)
+ (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
tm.Unix.tm_sec
let format_time t =
let tm = Unix.localtime t in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02d"
- (tm.Unix.tm_year + 1900)
- (tm.Unix.tm_mon + 1)
- tm.Unix.tm_mday
- tm.Unix.tm_hour
- tm.Unix.tm_min
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02d" (tm.Unix.tm_year + 1900)
+ (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
tm.Unix.tm_sec
let get_id (t : t) = t.id
@@ -47,10 +34,9 @@ let get_start_time (t : t) = t.start_time
let mkdir_p path =
let rec create dir =
- if not (Sys.file_exists dir) then begin
+ if not (Sys.file_exists dir) then (
create (Filename.dirname dir);
- try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
- end
+ try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
in
create path
@@ -61,11 +47,7 @@ let start_run () =
mkdir_p run_dir;
mkdir_p (Filename.concat run_dir "build");
mkdir_p (Filename.concat run_dir "docs");
- {
- id;
- start_time = Unix.gettimeofday ();
- run_dir;
- }
+ { id; start_time = Unix.gettimeofday (); run_dir }
let update_latest_symlink run_info =
let latest = Filename.concat !log_base_dir "latest" in
@@ -77,110 +59,131 @@ let update_latest_symlink run_info =
(Unix.error_message err)
let add_build_log run_info ~package ~source_log =
- let dest = Filename.concat run_info.run_dir
- (Filename.concat "build" (package ^ ".log")) in
- if Sys.file_exists source_log then begin
- try
- Unix.symlink source_log dest
- with Unix.Unix_error _ ->
+ let dest =
+ Filename.concat run_info.run_dir
+ (Filename.concat "build" (package ^ ".log"))
+ in
+ if Sys.file_exists source_log then
+ try Unix.symlink source_log dest
+ with Unix.Unix_error _ -> (
try
- let content = In_channel.with_open_text source_log In_channel.input_all in
- Out_channel.with_open_text dest (fun oc -> Out_channel.output_string oc content)
- with _ -> ()
- end
+ let content =
+ In_channel.with_open_text source_log In_channel.input_all
+ in
+ Out_channel.with_open_text dest (fun oc ->
+ Out_channel.output_string oc content)
+ with _ -> ())
let add_doc_log run_info ~package ~source_log ~layer_hash =
let filename =
if layer_hash = "" then package ^ ".log"
else package ^ "." ^ layer_hash ^ ".log"
in
- let dest = Filename.concat run_info.run_dir
- (Filename.concat "docs" filename) in
- if Sys.file_exists source_log then begin
+ let dest =
+ Filename.concat run_info.run_dir (Filename.concat "docs" filename)
+ in
+ if Sys.file_exists source_log then (
(try Unix.unlink dest with Unix.Unix_error _ -> ());
- try
- Unix.symlink source_log dest
- with Unix.Unix_error _ ->
+ try Unix.symlink source_log dest
+ with Unix.Unix_error _ -> (
try
- let content = In_channel.with_open_text source_log In_channel.input_all in
- Out_channel.with_open_text dest (fun oc -> Out_channel.output_string oc content)
- with _ -> ()
- end
+ let content =
+ In_channel.with_open_text source_log In_channel.input_all
+ in
+ Out_channel.with_open_text dest (fun oc ->
+ Out_channel.output_string oc content)
+ with _ -> ()))
(* --- Incremental phase files --- *)
let write_phase_json run_info name json =
let path = Filename.concat run_info.run_dir (name ^ ".json") in
Out_channel.with_open_text path (fun oc ->
- Out_channel.output_string oc (Yojson.Safe.pretty_to_string json))
-
-let write_plan run_info ~repos_with_shas ~n_targets ~ocaml_version
- ~with_doc ~all_versions ~small_universe =
- write_phase_json run_info "plan" (`Assoc [
- ("timestamp", `String (format_time (Unix.gettimeofday ())));
- ("repos", `List (List.map (fun (repo, sha) ->
- `Assoc [ ("path", `String repo); ("commit", `String sha) ]
- ) repos_with_shas));
- ("targets", `Int n_targets);
- ("ocaml_version", match ocaml_version with
- | Some v -> `String v | None -> `Null);
- ("with_doc", `Bool with_doc);
- ("all_versions", `Bool all_versions);
- ("small_universe", `Bool small_universe);
- ])
+ Out_channel.output_string oc (Yojson.Safe.pretty_to_string json))
+
+let write_plan run_info ~repos_with_shas ~n_targets ~ocaml_version ~with_doc
+ ~all_versions ~small_universe =
+ write_phase_json run_info "plan"
+ (`Assoc
+ [
+ ("timestamp", `String (format_time (Unix.gettimeofday ())));
+ ( "repos",
+ `List
+ (List.map
+ (fun (repo, sha) ->
+ `Assoc [ ("path", `String repo); ("commit", `String sha) ])
+ repos_with_shas) );
+ ("targets", `Int n_targets);
+ ( "ocaml_version",
+ match ocaml_version with Some v -> `String v | None -> `Null );
+ ("with_doc", `Bool with_doc);
+ ("all_versions", `Bool all_versions);
+ ("small_universe", `Bool small_universe);
+ ])
let write_solve run_info ~n_solved ~n_failed =
- write_phase_json run_info "solve" (`Assoc [
- ("timestamp", `String (format_time (Unix.gettimeofday ())));
- ("solved", `Int n_solved);
- ("failed", `Int n_failed);
- ])
+ write_phase_json run_info "solve"
+ (`Assoc
+ [
+ ("timestamp", `String (format_time (Unix.gettimeofday ())));
+ ("solved", `Int n_solved);
+ ("failed", `Int n_failed);
+ ])
let write_dag run_info ~n_build ~n_cached ~n_need_build =
- write_phase_json run_info "dag" (`Assoc [
- ("timestamp", `String (format_time (Unix.gettimeofday ())));
- ("build_nodes", `Int n_build);
- ("cached", `Int n_cached);
- ("need_build", `Int n_need_build);
- ])
+ write_phase_json run_info "dag"
+ (`Assoc
+ [
+ ("timestamp", `String (format_time (Unix.gettimeofday ())));
+ ("build_nodes", `Int n_build);
+ ("cached", `Int n_cached);
+ ("need_build", `Int n_need_build);
+ ])
let write_doc_dag run_info ~n_build ~n_tool ~n_doc_all ~n_compile ~n_link =
- write_phase_json run_info "doc_dag" (`Assoc [
- ("timestamp", `String (format_time (Unix.gettimeofday ())));
- ("build_nodes", `Int n_build);
- ("tool_nodes", `Int n_tool);
- ("doc_all_nodes", `Int n_doc_all);
- ("compile_nodes", `Int n_compile);
- ("link_nodes", `Int n_link);
- ("total", `Int (n_build + n_tool + n_doc_all + n_compile + n_link));
- ])
+ write_phase_json run_info "doc_dag"
+ (`Assoc
+ [
+ ("timestamp", `String (format_time (Unix.gettimeofday ())));
+ ("build_nodes", `Int n_build);
+ ("tool_nodes", `Int n_tool);
+ ("doc_all_nodes", `Int n_doc_all);
+ ("compile_nodes", `Int n_compile);
+ ("link_nodes", `Int n_link);
+ ("total", `Int (n_build + n_tool + n_doc_all + n_compile + n_link));
+ ])
let build_log_lock = Mutex.create ()
let build_log_oc : out_channel option ref = ref None
-let log_build_result run_info ~pkg ~hash ~status ~failed_dep
- ?(kind = "build") ?(layer_dir = "") () =
+let log_build_result run_info ~pkg ~hash ~status ~failed_dep ?(kind = "build")
+ ?(layer_dir = "") () =
Mutex.lock build_log_lock;
- let oc = match !build_log_oc with
+ let oc =
+ match !build_log_oc with
| Some oc -> oc
| None ->
- let path = Filename.concat run_info.run_dir "build.jsonl" in
- let oc = open_out_gen
- [ Open_wronly; Open_creat; Open_append ] 0o644 path in
- build_log_oc := Some oc;
- oc
+ let path = Filename.concat run_info.run_dir "build.jsonl" in
+ let oc =
+ open_out_gen [ Open_wronly; Open_creat; Open_append ] 0o644 path
+ in
+ build_log_oc := Some oc;
+ oc
in
- let json = `Assoc ([
- ("t", `String (format_time (Unix.gettimeofday ())));
- ("kind", `String kind);
- ("pkg", `String pkg);
- ("hash", `String hash);
- ("status", `String status);
- ] @ (if layer_dir = "" then [] else
- [ ("layer_dir", `String layer_dir) ])
- @ (match failed_dep with
- | Some d -> [ ("failed_dep", `String d) ]
- | None -> []))
+ let json =
+ `Assoc
+ ([
+ ("t", `String (format_time (Unix.gettimeofday ())));
+ ("kind", `String kind);
+ ("pkg", `String pkg);
+ ("hash", `String hash);
+ ("status", `String status);
+ ]
+ @ (if layer_dir = "" then [] else [ ("layer_dir", `String layer_dir) ])
+ @
+ match failed_dep with
+ | Some d -> [ ("failed_dep", `String d) ]
+ | None -> [])
in
output_string oc (Yojson.Safe.to_string json);
output_char oc '\n';
@@ -190,60 +193,78 @@ let log_build_result run_info ~pkg ~hash ~status ~failed_dep
let close_build_log () =
Mutex.lock build_log_lock;
(match !build_log_oc with
- | Some oc -> close_out_noerr oc; build_log_oc := None
- | None -> ());
+ | Some oc ->
+ close_out_noerr oc;
+ build_log_oc := None
+ | None -> ());
Mutex.unlock build_log_lock
let write_dag_structure run_info (nodes : Day11_opam_layer.Build.t list) =
let path = Filename.concat run_info.run_dir "dag_structure.jsonl" in
Out_channel.with_open_text path (fun oc ->
- List.iter (fun (node : Day11_opam_layer.Build.t) ->
- let json = `Assoc [
- ("hash", `String node.hash);
- ("pkg", `String (OpamPackage.to_string node.pkg));
- ("deps", `List (List.map (fun (dep : Day11_opam_layer.Build.t) ->
- `String dep.hash) node.deps));
- ] in
- output_string oc (Yojson.Safe.to_string json);
- output_char oc '\n'
- ) nodes)
+ List.iter
+ (fun (node : Day11_opam_layer.Build.t) ->
+ let json =
+ `Assoc
+ [
+ ("hash", `String node.hash);
+ ("pkg", `String (OpamPackage.to_string node.pkg));
+ ( "deps",
+ `List
+ (List.map
+ (fun (dep : Day11_opam_layer.Build.t) ->
+ `String dep.hash)
+ node.deps) );
+ ]
+ in
+ output_string oc (Yojson.Safe.to_string json);
+ output_char oc '\n')
+ nodes)
let summary_to_json summary =
- let failures_json = `List (List.map (fun (pkg, err) ->
- `Assoc [("package", `String pkg); ("error", `String err)]
- ) summary.failures) in
- `Assoc [
- ("run_id", `String summary.run_id);
- ("start_time", `Float summary.start_time);
- ("end_time", `Float summary.end_time);
- ("duration", `Float summary.duration);
- ("targets_requested", `Int summary.targets_requested);
- ("packages_built", `Int summary.packages_built);
- ("packages_failed", `Int summary.packages_failed);
- ("docs_generated", `Int summary.docs_generated);
- ("failures", failures_json);
- ]
+ let failures_json =
+ `List
+ (List.map
+ (fun (pkg, err) ->
+ `Assoc [ ("package", `String pkg); ("error", `String err) ])
+ summary.failures)
+ in
+ `Assoc
+ [
+ ("run_id", `String summary.run_id);
+ ("start_time", `Float summary.start_time);
+ ("end_time", `Float summary.end_time);
+ ("duration", `Float summary.duration);
+ ("targets_requested", `Int summary.targets_requested);
+ ("packages_built", `Int summary.packages_built);
+ ("packages_failed", `Int summary.packages_failed);
+ ("docs_generated", `Int summary.docs_generated);
+ ("failures", failures_json);
+ ]
let write_summary run_info summary =
let path = Filename.concat run_info.run_dir "summary.json" in
let json = summary_to_json summary in
let content = Yojson.Safe.pretty_to_string json in
- Out_channel.with_open_text path (fun oc -> Out_channel.output_string oc content)
+ Out_channel.with_open_text path (fun oc ->
+ Out_channel.output_string oc content)
let finish_run (run_info : t) ~targets_requested ~packages_built
~packages_failed ~docs_generated ~failures =
let finish_time = Unix.gettimeofday () in
- let summary : summary = {
- run_id = run_info.id;
- start_time = run_info.start_time;
- end_time = finish_time;
- duration = finish_time -. run_info.start_time;
- targets_requested;
- packages_built;
- packages_failed;
- docs_generated;
- failures;
- } in
+ let summary : summary =
+ {
+ run_id = run_info.id;
+ start_time = run_info.start_time;
+ end_time = finish_time;
+ duration = finish_time -. run_info.start_time;
+ targets_requested;
+ packages_built;
+ packages_failed;
+ docs_generated;
+ failures;
+ }
+ in
write_summary run_info summary;
update_latest_symlink run_info;
summary
File "day11/lib/universe_manifest.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/universe_manifest.ml b/_build/default/day11/lib/.formatted/universe_manifest.ml
index 5c72bc0..7c70eb5 100644
--- a/_build/default/day11/lib/universe_manifest.ml
+++ b/_build/default/day11/lib/.formatted/universe_manifest.ml
@@ -1,67 +1,79 @@
-let src = Logs.Src.create "day11.universe_manifest"
+let src =
+ Logs.Src.create "day11.universe_manifest"
~doc:"Per-snapshot universe manifests read/write"
+
module Log = (val Logs.src_log src)
-type t = {
- hash : string;
- packages : string list;
-}
+type t = { hash : string; packages : string list }
let dir snapshot_dir = Fpath.(snapshot_dir / "universes")
let index_path snapshot_dir = Fpath.(dir snapshot_dir / "index.json")
+
let manifest_path snapshot_dir hash =
Fpath.(dir snapshot_dir / (hash ^ ".json"))
let write_all ~snapshot_dir universes =
match Bos.OS.Dir.create ~path:true (dir snapshot_dir) with
| Error _ as e -> e
- | Ok _ ->
- let hashes = List.map fst universes in
- let index =
- `Assoc [ "universes",
- `List (List.map (fun h -> `String h) hashes) ] in
- match Bos.OS.File.write (index_path snapshot_dir)
- (Yojson.Safe.to_string index) with
- | Error _ as e -> e
- | Ok () ->
- List.fold_left (fun acc (hash, packages) ->
- match acc with
- | Error _ as e -> e
- | Ok () ->
- let json = `Assoc [
- "universe_hash", `String hash;
- "packages",
- `List (List.map (fun p -> `String p) packages) ] in
- Bos.OS.File.write (manifest_path snapshot_dir hash)
- (Yojson.Safe.to_string json)
- ) (Ok ()) universes
+ | Ok _ -> (
+ let hashes = List.map fst universes in
+ let index =
+ `Assoc [ ("universes", `List (List.map (fun h -> `String h) hashes)) ]
+ in
+ match
+ Bos.OS.File.write (index_path snapshot_dir)
+ (Yojson.Safe.to_string index)
+ with
+ | Error _ as e -> e
+ | Ok () ->
+ List.fold_left
+ (fun acc (hash, packages) ->
+ match acc with
+ | Error _ as e -> e
+ | Ok () ->
+ let json =
+ `Assoc
+ [
+ ("universe_hash", `String hash);
+ ( "packages",
+ `List (List.map (fun p -> `String p) packages) );
+ ]
+ in
+ Bos.OS.File.write
+ (manifest_path snapshot_dir hash)
+ (Yojson.Safe.to_string json))
+ (Ok ()) universes)
let read_index ~snapshot_dir =
match Bos.OS.File.read (index_path snapshot_dir) with
| Error _ -> []
- | Ok s ->
- (try
- let json = Yojson.Safe.from_string s in
- let open Yojson.Safe.Util in
- json |> member "universes" |> to_list |> List.map to_string
- with exn ->
- Log.warn (fun f -> f "universes/index.json parse failed (%s): %s"
- (Fpath.to_string (index_path snapshot_dir)) (Printexc.to_string exn));
- [])
+ | Ok s -> (
+ try
+ let json = Yojson.Safe.from_string s in
+ let open Yojson.Safe.Util in
+ json |> member "universes" |> to_list |> List.map to_string
+ with exn ->
+ Log.warn (fun f ->
+ f "universes/index.json parse failed (%s): %s"
+ (Fpath.to_string (index_path snapshot_dir))
+ (Printexc.to_string exn));
+ [])
let read_manifest ~snapshot_dir ~hash =
match Bos.OS.File.read (manifest_path snapshot_dir hash) with
| Error _ -> None
- | Ok s ->
- (try
- let json = Yojson.Safe.from_string s in
- let open Yojson.Safe.Util in
- let hash = json |> member "universe_hash" |> to_string in
- let packages =
- json |> member "packages" |> to_list |> List.map to_string in
- Some { hash; packages }
- with exn ->
- Log.warn (fun f -> f "universes/%s.json parse failed (%s): %s"
- hash (Fpath.to_string (manifest_path snapshot_dir hash))
- (Printexc.to_string exn));
- None)
+ | Ok s -> (
+ try
+ let json = Yojson.Safe.from_string s in
+ let open Yojson.Safe.Util in
+ let hash = json |> member "universe_hash" |> to_string in
+ let packages =
+ json |> member "packages" |> to_list |> List.map to_string
+ in
+ Some { hash; packages }
+ with exn ->
+ Log.warn (fun f ->
+ f "universes/%s.json parse failed (%s): %s" hash
+ (Fpath.to_string (manifest_path snapshot_dir hash))
+ (Printexc.to_string exn));
+ None)
File "day11/doc/combine.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/combine.ml b/_build/default/day11/doc/.formatted/combine.ml
index f0de826..f81f45e 100644
--- a/_build/default/day11/doc/combine.ml
+++ b/_build/default/day11/doc/.formatted/combine.ml
@@ -8,58 +8,60 @@ type doc_layer = {
let is_doc_layer name =
Astring.String.is_prefix ~affix:"doc-" name
- && not (Astring.String.is_prefix ~affix:"doc-driver-" name)
+ && (not (Astring.String.is_prefix ~affix:"doc-driver-" name))
&& not (Astring.String.is_prefix ~affix:"doc-odoc-" name)
let scan_cache env ~os_dir =
let layers = Day11_layer.Scan.list_layers env os_dir in
- List.filter_map (fun (name, layer_path) ->
- if not (is_doc_layer name) then None
- else
- let json_path = Fpath.(layer_path / "layer.json") in
- match
- try Some (Yojson.Safe.from_file (Fpath.to_string json_path))
- with _ -> None
- with
- | None -> None
- | Some json ->
- try
- let open Yojson.Safe.Util in
- let pkg_str = json |> member "package" |> to_string in
- let pkg = OpamPackage.of_string pkg_str in
- let doc = json |> member "doc" in
- let status = doc |> member "status" |> to_string in
- if status <> "success" then None
- else
- let _html_path =
- doc |> member "html_path" |> to_string in
- let blessed = doc |> member "blessed" |> to_bool in
- let dep_hashes =
- json |> member "dep_doc_hashes"
- |> to_list |> List.map to_string in
- let universe =
- Command.compute_universe_hash dep_hashes in
- Some {
- pkg;
- layer_hash = name;
- prep_path = Fpath.(layer_path / "prep");
- universe;
- blessed;
- }
+ List.filter_map
+ (fun (name, layer_path) ->
+ if not (is_doc_layer name) then None
+ else
+ let json_path = Fpath.(layer_path / "layer.json") in
+ match
+ try Some (Yojson.Safe.from_file (Fpath.to_string json_path))
with _ -> None
- ) layers
+ with
+ | None -> None
+ | Some json -> (
+ try
+ let open Yojson.Safe.Util in
+ let pkg_str = json |> member "package" |> to_string in
+ let pkg = OpamPackage.of_string pkg_str in
+ let doc = json |> member "doc" in
+ let status = doc |> member "status" |> to_string in
+ if status <> "success" then None
+ else
+ let _html_path = doc |> member "html_path" |> to_string in
+ let blessed = doc |> member "blessed" |> to_bool in
+ let dep_hashes =
+ json
+ |> member "dep_doc_hashes"
+ |> to_list
+ |> List.map to_string
+ in
+ let universe = Command.compute_universe_hash dep_hashes in
+ Some
+ {
+ pkg;
+ layer_hash = name;
+ prep_path = Fpath.(layer_path / "prep");
+ universe;
+ blessed;
+ }
+ with _ -> None))
+ layers
let mount_overlay ~sw env ~layers ~mount_point ~work_dir =
- if layers = [] then
- Rresult.R.error_msgf "Combine: no layers to mount"
+ if layers = [] then Rresult.R.error_msgf "Combine: no layers to mount"
else
let lower_dirs = List.map (fun l -> l.prep_path) layers in
let upper = Fpath.(work_dir / "upper") in
let work = Fpath.(work_dir / "work") in
Bos.OS.Dir.create ~path:true upper |> ignore;
Bos.OS.Dir.create ~path:true work |> ignore;
- Day11_container.Overlay.mount ~sw env ~lower:lower_dirs
- ~upper ~work ~target:mount_point
+ Day11_container.Overlay.mount ~sw env ~lower:lower_dirs ~upper ~work
+ ~target:mount_point
let unmount ~sw env mount_point =
Day11_container.Overlay.umount ~sw env mount_point
File "day11/doc/doc_build.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/doc_build.ml b/_build/default/day11/doc/.formatted/doc_build.ml
index 2ad730b..8634ff0 100644
--- a/_build/default/day11/doc/doc_build.ml
+++ b/_build/default/day11/doc/.formatted/doc_build.ml
@@ -11,14 +11,15 @@ type doc_config = {
blessed : bool;
}
-let has_documentable_libs layer_dir =
- Installed_files.scan_libs ~layer_dir <> []
+let has_documentable_libs layer_dir = Installed_files.scan_libs ~layer_dir <> []
(* Re-exports from {!Day11_opam_build.Compiler_pkg} so doc-side
code that already imports [Day11_doc.Doc_build] keeps working. *)
let concrete_compiler_names = Day11_opam_build.Compiler_pkg.names
let is_compiler_pkg = Day11_opam_build.Compiler_pkg.is_compiler
-let check_stdlib_installed = Day11_opam_build.Compiler_pkg.check_stdlib_installed
+
+let check_stdlib_installed =
+ Day11_opam_build.Compiler_pkg.check_stdlib_installed
(* Solver-based check: a package is "ocaml" (i.e. a real OCaml
library worth documenting) iff its solved deps include the
@@ -31,31 +32,47 @@ let check_stdlib_installed = Day11_opam_build.Compiler_pkg.check_stdlib_installe
let is_ocaml_package (node : Build.t) =
let ocaml = OpamPackage.Name.of_string "ocaml" in
is_compiler_pkg node.pkg
- || List.exists (fun (d : Build.t) ->
- OpamPackage.Name.equal (OpamPackage.name d.pkg) ocaml
- ) node.deps
+ || List.exists
+ (fun (d : Build.t) ->
+ OpamPackage.Name.equal (OpamPackage.name d.pkg) ocaml)
+ node.deps
(** Create tool binary mounts from driver and odoc tools. *)
let make_tool_mounts ~os_dir ~(driver_tool : Day11_opam_layer.Tool.t)
~(odoc_tool : Day11_opam_layer.Tool.t) =
let find name builds =
let switch = Day11_opam_build.Types.switch in
- match List.find_map (fun (bl : Build.t) ->
- let bin = Fpath.(Build.dir ~os_dir bl / "fs" / "home" / "opam"
- / ".opam" / switch / "bin" / name) in
- if Bos.OS.File.exists bin |> Result.get_ok then Some bin
- else None
- ) builds with
+ match
+ List.find_map
+ (fun (bl : Build.t) ->
+ let bin =
+ Fpath.(
+ Build.dir ~os_dir bl
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / switch
+ / "bin"
+ / name)
+ in
+ if Bos.OS.File.exists bin |> Result.get_ok then Some bin else None)
+ builds
+ with
| Some p -> p
| None -> failwith (Printf.sprintf "Doc tool binary %s not found" name)
in
- let mount src dst = Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string src) dst in
- [ mount (find "odoc" odoc_tool.builds) "/home/opam/doc-tools/bin/odoc";
+ let mount src dst =
+ Day11_container.Mount.bind_ro ~src:(Fpath.to_string src) dst
+ in
+ [
+ mount (find "odoc" odoc_tool.builds) "/home/opam/doc-tools/bin/odoc";
mount (find "odoc-md" driver_tool.builds) "/home/opam/doc-tools/bin/odoc-md";
- mount (find "odoc_driver_voodoo" driver_tool.builds)
+ mount
+ (find "odoc_driver_voodoo" driver_tool.builds)
"/home/opam/doc-tools/bin/odoc_driver_voodoo";
- mount (find "sherlodoc" driver_tool.builds)
+ mount
+ (find "sherlodoc" driver_tool.builds)
"/home/opam/doc-tools/bin/sherlodoc";
(* [ocamlobjinfo] is what voodoo invokes via [Eio.Process] to
extract source-file references from [.cmt] files. Comes from
@@ -66,8 +83,10 @@ let make_tool_mounts ~os_dir ~(driver_tool : Day11_opam_layer.Tool.t)
the compiler on PATH; for self-documenting [ocaml-compiler]
it isn't (build_deps is empty), so this dedicated mount is
the uniform fix. *)
- mount (find "ocamlobjinfo" odoc_tool.builds)
- "/home/opam/doc-tools/bin/ocamlobjinfo" ]
+ mount
+ (find "ocamlobjinfo" odoc_tool.builds)
+ "/home/opam/doc-tools/bin/ocamlobjinfo";
+ ]
(** Pre-mount prep for doc containers: create /home/opam/odoc-out and
/home/opam/html mount points, chown to build user. *)
@@ -75,42 +94,49 @@ let doc_prep_upper ~sw env ~uid ~gid ~upper ~lowers:_ =
let mkdir path = Bos.OS.Dir.create ~path:true path |> ignore in
let odoc_out = Fpath.(upper / "home" / "opam" / "odoc-out") in
let html = Fpath.(upper / "home" / "opam" / "html") in
- mkdir odoc_out; mkdir html;
- ignore (Day11_sys.Sudo.run ~sw env
- Bos.Cmd.(v "chown" % Printf.sprintf "%d:%d" uid gid
- % Fpath.to_string odoc_out % Fpath.to_string html))
+ mkdir odoc_out;
+ mkdir html;
+ ignore
+ (Day11_sys.Sudo.run ~sw env
+ Bos.Cmd.(
+ v "chown"
+ % Printf.sprintf "%d:%d" uid gid
+ % Fpath.to_string odoc_out
+ % Fpath.to_string html))
let doc_cleanup ~sw env upper =
- ignore (Day11_sys.Sudo.rm_rf ~sw env
- Fpath.(upper / "home" / "opam" / "doc-tools"))
+ ignore
+ (Day11_sys.Sudo.rm_rf ~sw env Fpath.(upper / "home" / "opam" / "doc-tools"))
-(** Set up the prep structure and mounts for a doc container.
- Returns [(universe, mounts, prep_dir)] or [None] only on a hard
- [Prep.create_with_mounts] failure. Packages with no installed
- libs and no [.mld] files still go through, with [Prep] dropping
- a stub [index.mld] so [odoc_driver_voodoo] has something to
- process — that produces a real (almost-empty) layer instead of
- the previous "skip with no on-disk artefact" path that left
- [inspect_layer]'s [Layer.is_ok] disagreeing with the
- [layer_status.jsonl] truth source. Caller must clean up
- [prep_dir]. *)
+(** Set up the prep structure and mounts for a doc container. Returns
+ [(universe, mounts, prep_dir)] or [None] only on a hard
+ [Prep.create_with_mounts] failure. Packages with no installed libs and no
+ [.mld] files still go through, with [Prep] dropping a stub [index.mld] so
+ [odoc_driver_voodoo] has something to process — that produces a real
+ (almost-empty) layer instead of the previous "skip with no on-disk artefact"
+ path that left [inspect_layer]'s [Layer.is_ok] disagreeing with the
+ [layer_status.jsonl] truth source. Caller must clean up [prep_dir]. *)
let prepare ~(config : doc_config) ~build_layer pkg =
let installed_libs = Installed_files.scan_libs ~layer_dir:build_layer in
let installed_docs = Installed_files.scan_docs ~layer_dir:build_layer in
- let universe = Command.compute_universe_hash
- [ Fpath.basename build_layer ] in
- let tool_mounts = make_tool_mounts ~os_dir:config.os_dir
- ~driver_tool:config.driver_tool ~odoc_tool:config.odoc_tool in
+ let universe = Command.compute_universe_hash [ Fpath.basename build_layer ] in
+ let tool_mounts =
+ make_tool_mounts ~os_dir:config.os_dir ~driver_tool:config.driver_tool
+ ~odoc_tool:config.odoc_tool
+ in
let prep_dir = Bos.OS.Dir.tmp "day11_doc_%s" |> Result.get_ok in
- match Prep.create_with_mounts ~source_layer_dir:build_layer
- ~dest_layer_dir:prep_dir ~universe ~pkg
- ~installed_libs ~installed_docs with
+ match
+ Prep.create_with_mounts ~source_layer_dir:build_layer
+ ~dest_layer_dir:prep_dir ~universe ~pkg ~installed_libs ~installed_docs
+ with
| Ok (_prep_root, lib_mounts) ->
- let prep_mount = Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
- "/home/opam/prep" in
- let mounts = tool_mounts @ [ prep_mount ] @ lib_mounts in
- Some (universe, mounts, prep_dir)
+ let prep_mount =
+ Day11_container.Mount.bind_ro
+ ~src:(Fpath.to_string Fpath.(prep_dir / "prep"))
+ "/home/opam/prep"
+ in
+ let mounts = tool_mounts @ [ prep_mount ] @ lib_mounts in
+ Some (universe, mounts, prep_dir)
| Error _ -> None
(* Pre-voodoo inventory of what's visible inside the container:
@@ -120,14 +146,13 @@ let prepare ~(config : doc_config) ~build_layer pkg =
voodoo's classify step will look at)
Output goes to layer.log via the build container's stdout. *)
let debug_inspect_image =
- "echo '=== DEBUG: pre-voodoo image inventory ==='; \
- echo '-- pkg markers (.odoc_pkg_marker) --'; \
- find /home/opam/odoc-out -name '.odoc_pkg_marker' 2>/dev/null | sort; \
- echo '-- lib markers (.odoc_lib_marker) --'; \
- find /home/opam/odoc-out -name '.odoc_lib_marker' 2>/dev/null | sort; \
- echo '-- prep universes (universe/pkg/version) --'; \
- ls -d /home/opam/prep/universes/*/*/*/ 2>/dev/null | sort; \
- echo '=== END DEBUG ==='; "
+ "echo '=== DEBUG: pre-voodoo image inventory ==='; echo '-- pkg markers \
+ (.odoc_pkg_marker) --'; find /home/opam/odoc-out -name '.odoc_pkg_marker' \
+ 2>/dev/null | sort; echo '-- lib markers (.odoc_lib_marker) --'; find \
+ /home/opam/odoc-out -name '.odoc_lib_marker' 2>/dev/null | sort; echo '-- \
+ prep universes (universe/pkg/version) --'; ls -d \
+ /home/opam/prep/universes/*/*/*/ 2>/dev/null | sort; echo '=== END DEBUG \
+ ==='; "
(* Shared body of the three doc phases (compile / link / doc-all). They
differ only in the voodoo [actions], the [Doc_meta] phase + recorded
@@ -136,75 +161,84 @@ let debug_inspect_image =
wrappers map that to the layer dir (compile/doc-all) or unit (link).
Layer dirs are stacked build-deps first (build-time tooling) then
compile layers (.odoc files) — order matters for overlayfs. *)
-let run_doc_phase ~sw env benv ~(config : doc_config) ~build_layer
- ~actions ~phase ~meta_deps ~html_dir ~build_dirs ~label ~hash pkg
- : (Build.t, string) result =
+let run_doc_phase ~sw env benv ~(config : doc_config) ~build_layer ~actions
+ ~phase ~meta_deps ~html_dir ~build_dirs ~label ~hash pkg :
+ (Build.t, string) result =
match prepare ~config ~build_layer pkg with
| None -> Error "no documentable libraries"
| Some (universe, mounts, prep_dir) ->
- (* The HTML output dir is a bind-mount source; runc won't start if it
+ (* The HTML output dir is a bind-mount source; runc won't start if it
doesn't exist, so ensure it (top-level callers usually do too). *)
- let mounts = match html_dir with
- | None -> mounts
- | Some dir ->
- ignore (Bos.OS.Dir.create ~path:true dir);
- mounts @ [ Day11_container.Mount.bind_rw
- ~src:(Fpath.to_string dir) Odoc_store.container_html ]
- in
- let cmd =
- "export PATH=/home/opam/doc-tools/bin:$PATH && eval $(opam env) && " ^
- debug_inspect_image ^
- Command.odoc_driver_voodoo ~pkg ~universe
- ~blessed:config.blessed ~actions ~odoc_bin ~odoc_md_bin in
- let node : Build.t =
- { hash; pkg; deps = []; universe = Day11_solution.Universe.dummy } in
- let on_extract ~layer_dir ~success:_ =
- let dm : Doc_meta.t =
- { package = OpamPackage.to_string pkg; phase; deps = meta_deps } in
- ignore (Doc_meta.save layer_dir dm)
- in
- let result =
- match Day11_opam_build.Build_layer.build ~sw env benv
- ~opam_repositories:[] ~mounts ~build_dirs
- ~prep_upper:(doc_prep_upper ~sw env ~uid:benv.uid ~gid:benv.gid)
- ~on_extract node
- ~strategy:{ cmd; cleanup = doc_cleanup } () with
- | Day11_opam_build.Types.Success _ -> Ok node
- | _ ->
- Error (Printf.sprintf "%s failed for %s" label
- (OpamPackage.to_string pkg))
- in
- ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir);
- result
+ let mounts =
+ match html_dir with
+ | None -> mounts
+ | Some dir ->
+ ignore (Bos.OS.Dir.create ~path:true dir);
+ mounts
+ @ [
+ Day11_container.Mount.bind_rw ~src:(Fpath.to_string dir)
+ Odoc_store.container_html;
+ ]
+ in
+ let cmd =
+ "export PATH=/home/opam/doc-tools/bin:$PATH && eval $(opam env) && "
+ ^ debug_inspect_image
+ ^ Command.odoc_driver_voodoo ~pkg ~universe ~blessed:config.blessed
+ ~actions ~odoc_bin ~odoc_md_bin
+ in
+ let node : Build.t =
+ { hash; pkg; deps = []; universe = Day11_solution.Universe.dummy }
+ in
+ let on_extract ~layer_dir ~success:_ =
+ let dm : Doc_meta.t =
+ { package = OpamPackage.to_string pkg; phase; deps = meta_deps }
+ in
+ ignore (Doc_meta.save layer_dir dm)
+ in
+ let result =
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[]
+ ~mounts ~build_dirs
+ ~prep_upper:(doc_prep_upper ~sw env ~uid:benv.uid ~gid:benv.gid)
+ ~on_extract node
+ ~strategy:{ cmd; cleanup = doc_cleanup }
+ ()
+ with
+ | Day11_opam_build.Types.Success _ -> Ok node
+ | _ ->
+ Error
+ (Printf.sprintf "%s failed for %s" label
+ (OpamPackage.to_string pkg))
+ in
+ ignore (Day11_sys.Sudo.rm_rf ~sw env prep_dir);
+ result
-let compile ~sw env benv ~(config : doc_config) ~build_layer
- ~build_deps_layers ~dep_compile_layers ~hash pkg =
- run_doc_phase ~sw env benv ~config ~build_layer
- ~actions:"compile-only" ~phase:Doc_meta.Compile
+let compile ~sw env benv ~(config : doc_config) ~build_layer ~build_deps_layers
+ ~dep_compile_layers ~hash pkg =
+ run_doc_phase ~sw env benv ~config ~build_layer ~actions:"compile-only"
+ ~phase:Doc_meta.Compile
~meta_deps:(List.map Fpath.basename dep_compile_layers)
~html_dir:None
~build_dirs:(build_deps_layers @ dep_compile_layers)
~label:"compile" ~hash pkg
|> Result.map (fun node ->
- Day11_opam_layer.Build.dir ~os_dir:config.os_dir node)
+ Day11_opam_layer.Build.dir ~os_dir:config.os_dir node)
-let link ~sw env benv ~(config : doc_config) ~build_layer
- ~build_deps_layers ~compile_layer ~dep_compile_layers ~html_dir ~hash pkg =
- run_doc_phase ~sw env benv ~config ~build_layer
- ~actions:"link-and-gen" ~phase:Doc_meta.Link ~meta_deps:[]
- ~html_dir:(Some html_dir)
+let link ~sw env benv ~(config : doc_config) ~build_layer ~build_deps_layers
+ ~compile_layer ~dep_compile_layers ~html_dir ~hash pkg =
+ run_doc_phase ~sw env benv ~config ~build_layer ~actions:"link-and-gen"
+ ~phase:Doc_meta.Link ~meta_deps:[] ~html_dir:(Some html_dir)
~build_dirs:(build_deps_layers @ (compile_layer :: dep_compile_layers))
~label:"link" ~hash pkg
|> Result.map ignore
-let doc_all ~sw env benv ~(config : doc_config) ~build_layer
- ~build_deps_layers ~dep_compile_layers ~html_dir ~hash pkg =
- run_doc_phase ~sw env benv ~config ~build_layer
- ~actions:"all" ~phase:Doc_meta.Doc_all
+let doc_all ~sw env benv ~(config : doc_config) ~build_layer ~build_deps_layers
+ ~dep_compile_layers ~html_dir ~hash pkg =
+ run_doc_phase ~sw env benv ~config ~build_layer ~actions:"all"
+ ~phase:Doc_meta.Doc_all
~meta_deps:(List.map Fpath.basename dep_compile_layers)
~html_dir:(Some html_dir)
~build_dirs:(build_deps_layers @ dep_compile_layers)
~label:"doc-all" ~hash pkg
|> Result.map (fun node ->
- Day11_opam_layer.Build.dir ~os_dir:config.os_dir node)
-
+ Day11_opam_layer.Build.dir ~os_dir:config.os_dir node)
File "day11/doc/doc_build.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/doc_build.mli b/_build/default/day11/doc/.formatted/doc_build.mli
index 8e773dc..e80b0ea 100644
--- a/_build/default/day11/doc/doc_build.mli
+++ b/_build/default/day11/doc/.formatted/doc_build.mli
@@ -1,10 +1,10 @@
(** Stateless per-package doc build primitives.
- Each function takes explicit inputs (layer directories, tool
- directories, package metadata) and produces a result. No shared
- mutable state, no DAG knowledge, no hashtable lookups. These are
- the building blocks for both the DAG-based batch executor and
- potential integration with external pipeline systems like OCurrent.
+ Each function takes explicit inputs (layer directories, tool directories,
+ package metadata) and produces a result. No shared mutable state, no DAG
+ knowledge, no hashtable lookups. These are the building blocks for both the
+ DAG-based batch executor and potential integration with external pipeline
+ systems like OCurrent.
All functions follow the same pattern:
- Check preconditions (installed libs, tool availability)
@@ -18,9 +18,9 @@ type doc_config = {
os_dir : Fpath.t;
blessed : bool;
}
-(** Static configuration for a doc build. The tools and blessed status
- are determined before execution and don't change across packages
- within the same compiler universe. *)
+(** Static configuration for a doc build. The tools and blessed status are
+ determined before execution and don't change across packages within the same
+ compiler universe. *)
val compile :
sw:Eio.Switch.t ->
@@ -34,16 +34,16 @@ val compile :
OpamPackage.t ->
(Fpath.t, string) result
(** [compile env benv ~config ~build_layer ~build_deps_layers
- ~dep_compile_layers ~hash pkg] runs the odoc compile phase for [pkg].
- Reads source [.cmti]/[.ml] files from [build_layer], stacks
- [build_deps_layers] (for [ocamlobjinfo] and other build tools) and
- [dep_compile_layers] (for cross-reference resolution), and produces
- a compile layer at [os_dir/<hash>/].
+ ~dep_compile_layers ~hash pkg] runs the odoc compile phase for [pkg]. Reads
+ source [.cmti]/[.ml] files from [build_layer], stacks [build_deps_layers]
+ (for [ocamlobjinfo] and other build tools) and [dep_compile_layers] (for
+ cross-reference resolution), and produces a compile layer at
+ [os_dir/<hash>/].
- {b Dep closure required:} [dep_compile_layers] must be drawn from
- the {b transitive closure of [build_deps]}, never [doc_deps]. The
- compile phase consumes [.cmti] files which only reference packages
- the OCaml compile saw. See {!page-doc_dep_graphs} §2.
+ {b Dep closure required:} [dep_compile_layers] must be drawn from the
+ {b transitive closure of [build_deps]}, never [doc_deps]. The compile phase
+ consumes [.cmti] files which only reference packages the OCaml compile saw.
+ See {!page-doc_dep_graphs} §2.
Returns [Ok layer_dir] on success, [Error msg] on failure. *)
@@ -61,19 +61,19 @@ val link :
OpamPackage.t ->
(unit, string) result
(** [link env benv ~config ~build_layer ~build_deps_layers ~compile_layer
- ~dep_compile_layers ~html_dir ~hash pkg] runs the odoc link phase
- for [pkg]. Reads [.odoc] files from [compile_layer] and
- [dep_compile_layers], writes HTML to [html_dir]. Stacks
- [build_deps_layers] for build-tool access (ocamlobjinfo etc.).
+ ~dep_compile_layers ~html_dir ~hash pkg] runs the odoc link phase for
+ [pkg]. Reads [.odoc] files from [compile_layer] and [dep_compile_layers],
+ writes HTML to [html_dir]. Stacks [build_deps_layers] for build-tool access
+ (ocamlobjinfo etc.).
- {b Dep closure required:} [dep_compile_layers] must be drawn from
- the {b transitive closure of [doc_deps]} (which already includes
- [{post}] and [x-extra-doc-deps]). Cross-references in docstrings
- are resolved here, and may target packages that the compile phase
- didn't see. See {!page-doc_dep_graphs} §3.
+ {b Dep closure required:} [dep_compile_layers] must be drawn from the
+ {b transitive closure of [doc_deps]} (which already includes [{post}] and
+ [x-extra-doc-deps]). Cross-references in docstrings are resolved here, and
+ may target packages that the compile phase didn't see. See
+ {!page-doc_dep_graphs} §3.
- Returns [Ok ()] on success. The link layer itself is ephemeral —
- only the HTML output matters. *)
+ Returns [Ok ()] on success. The link layer itself is ephemeral — only the
+ HTML output matters. *)
val doc_all :
sw:Eio.Switch.t ->
@@ -87,63 +87,53 @@ val doc_all :
hash:string ->
OpamPackage.t ->
(Fpath.t, string) result
-(** [doc_all env benv ~config ~build_layer ~dep_compile_layers
- ~html_dir ~hash pkg] runs compile + link + HTML generation in a
- single container invocation. Returns the compile layer directory
- (which contains the [.odoc] output for use by dependents).
-
- {b Precondition:} only valid for packages where
- [build_deps == doc_deps]
- (see {!Day11_doc.Doc_deps.needs_separate_link}). [dep_compile_layers]
- is drawn from the transitive closure of [build_deps]
- (equivalently, [doc_deps]). See {!page-doc_dep_graphs} §4. *)
-
-val has_documentable_libs :
- Fpath.t -> bool
-(** [has_documentable_libs layer_dir] returns true if the build layer
- has installed libraries that can be documented.
- {b Note:} requires the layer to be built. For doc DAG planning,
- prefer {!is_ocaml_package} which uses the solver result and so
- works on a cold cache. *)
+(** [doc_all env benv ~config ~build_layer ~dep_compile_layers ~html_dir ~hash
+ pkg] runs compile + link + HTML generation in a single container
+ invocation. Returns the compile layer directory (which contains the [.odoc]
+ output for use by dependents).
+
+ {b Precondition:} only valid for packages where [build_deps == doc_deps]
+ (see {!Day11_doc.Doc_deps.needs_separate_link}). [dep_compile_layers] is
+ drawn from the transitive closure of [build_deps] (equivalently,
+ [doc_deps]). See {!page-doc_dep_graphs} §4. *)
+
+val has_documentable_libs : Fpath.t -> bool
+(** [has_documentable_libs layer_dir] returns true if the build layer has
+ installed libraries that can be documented. {b Note:} requires the layer to
+ be built. For doc DAG planning, prefer {!is_ocaml_package} which uses the
+ solver result and so works on a cold cache. *)
val concrete_compiler_names : OpamPackage.Name.t list
-(** Names of the real-compiler packages — the ones whose build
- installs [lib/ocaml/stdlib*.cmti]. The actual package per name
- depends on version (see {!is_compiler_pkg}); this list is just
- the {e set of names} for cheap prefilter matching. *)
+(** Names of the real-compiler packages — the ones whose build installs
+ [lib/ocaml/stdlib*.cmti]. The actual package per name depends on version
+ (see {!is_compiler_pkg}); this list is just the {e set of names} for cheap
+ prefilter matching. *)
val is_compiler_pkg : OpamPackage.t -> bool
-(** [is_compiler_pkg pkg] returns true when [pkg] is the real
- compiler (the one that installs stdlib) for its release line:
- {ul
- {- [ocaml-compiler] {b ≥} 5.3.0 — modern mainline.}
- {- [ocaml-base-compiler] {b <} 5.3.0 — pre-split mainline.}
- {- [oxcaml-compiler] (any version).}}
+(** [is_compiler_pkg pkg] returns true when [pkg] is the real compiler (the one
+ that installs stdlib) for its release line:
+ - [ocaml-compiler] {b ≥} 5.3.0 — modern mainline.
+ - [ocaml-base-compiler] {b <} 5.3.0 — pre-split mainline.
+ - [oxcaml-compiler] (any version).
+
Returns false for wrappers ([ocaml-variants], post-5.3.0
- [ocaml-base-compiler], [ocaml-system]) which are tagged
- [flags: compiler] in opam but have empty installs. *)
-
-val is_ocaml_package :
- Day11_opam_layer.Build.t -> bool
-(** [is_ocaml_package node] returns true if [node] depends on the
- virtual package [ocaml], OR is one of the
- {!concrete_compiler_names} (which {e provides} [ocaml]). The
- second disjunct ensures the compiler's stdlib is documented;
- without it, every package's [Stdlib.*] xref in the rendered
- HTML lands as [xref-unresolved]. [conf-*] system packages,
- [ocaml-options-*], and [ocaml-config] still don't depend on
- [ocaml] and so are skipped. Unlike {!has_documentable_libs},
- this works without the layer being built — useful for the first
- run on a cold cache. *)
+ [ocaml-base-compiler], [ocaml-system]) which are tagged [flags: compiler] in
+ opam but have empty installs. *)
+
+val is_ocaml_package : Day11_opam_layer.Build.t -> bool
+(** [is_ocaml_package node] returns true if [node] depends on the virtual
+ package [ocaml], OR is one of the {!concrete_compiler_names} (which
+ {e provides} [ocaml]). The second disjunct ensures the compiler's stdlib is
+ documented; without it, every package's [Stdlib.*] xref in the rendered HTML
+ lands as [xref-unresolved]. [conf-*] system packages, [ocaml-options-*], and
+ [ocaml-config] still don't depend on [ocaml] and so are skipped. Unlike
+ {!has_documentable_libs}, this works without the layer being built — useful
+ for the first run on a cold cache. *)
val check_stdlib_installed :
- build_layer:Fpath.t ->
- OpamPackage.t ->
- (unit, [> Rresult.R.msg ]) result
+ build_layer:Fpath.t -> OpamPackage.t -> (unit, [> Rresult.R.msg ]) result
(** Post-build invariant: a package classified as a compiler by
- {!is_compiler_pkg} is expected to have left
- [lib/ocaml/stdlib.cmti] in its build layer. Return [Ok ()] for
- non-compiler packages, [Ok ()] when the file is present, and
- [Error] otherwise — flagging either a broken upstream build or
- a misclassification in {!is_compiler_pkg}. *)
-
+ {!is_compiler_pkg} is expected to have left [lib/ocaml/stdlib.cmti] in its
+ build layer. Return [Ok ()] for non-compiler packages, [Ok ()] when the file
+ is present, and [Error] otherwise — flagging either a broken upstream build
+ or a misclassification in {!is_compiler_pkg}. *)
File "day11/doc/doc_deps.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/doc_deps.mli b/_build/default/day11/doc/.formatted/doc_deps.mli
index 4555b8c..5bc7d30 100644
--- a/_build/default/day11/doc/doc_deps.mli
+++ b/_build/default/day11/doc/.formatted/doc_deps.mli
@@ -1,18 +1,13 @@
(** Determine whether a package needs separate compile and link phases.
- Compares a package's dependencies in the build graph (no [{post}]
- deps) versus the doc graph (with [{post}] deps and
- [x-extra-doc-deps]). If they differ, the package needs separate
- compile and link phases; the link phase needs odoc output from the
- extra deps that aren't available at compile time.
+ Compares a package's dependencies in the build graph (no [{post}] deps)
+ versus the doc graph (with [{post}] deps and [x-extra-doc-deps]). If they
+ differ, the package needs separate compile and link phases; the link phase
+ needs odoc output from the extra deps that aren't available at compile time.
- See {!page-doc_dep_graphs} for the full description of the two
- graphs and what each pipeline step consumes. *)
+ See {!page-doc_dep_graphs} for the full description of the two graphs and
+ what each pipeline step consumes. *)
-val needs_separate_link :
- Day11_solution.Solve_result.t ->
- OpamPackage.t ->
- bool
-(** [needs_separate_link result pkg] returns [true] when [pkg]'s
- dependencies differ between [result.build_deps] and
- [result.doc_deps]. *)
+val needs_separate_link : Day11_solution.Solve_result.t -> OpamPackage.t -> bool
+(** [needs_separate_link result pkg] returns [true] when [pkg]'s dependencies
+ differ between [result.build_deps] and [result.doc_deps]. *)
File "day11/doc/doc_meta.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/doc_meta.ml b/_build/default/day11/doc/.formatted/doc_meta.ml
index cf0c62e..9653ed8 100644
--- a/_build/default/day11/doc/doc_meta.ml
+++ b/_build/default/day11/doc/.formatted/doc_meta.ml
@@ -17,13 +17,10 @@ type wire = {
package : string;
phase : string;
deps : string list; [@default []]
-} [@@deriving yojson { strict = false }]
-
-type t = {
- package : string;
- phase : phase;
- deps : string list;
}
+[@@deriving yojson { strict = false }]
+
+type t = { package : string; phase : phase; deps : string list }
let to_wire (t : t) : wire =
{ package = t.package; phase = string_of_phase t.phase; deps = t.deps }
@@ -39,19 +36,19 @@ let save layer_dir t =
Yojson.Safe.to_file (Fpath.to_string path) (wire_to_yojson (to_wire t));
Ok ()
with exn ->
- Rresult.R.error_msgf "Doc_meta.save %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ Rresult.R.error_msgf "Doc_meta.save %a: %s" Fpath.pp path
+ (Printexc.to_string exn)
let load layer_dir =
let path = Fpath.(layer_dir / "doc.json") in
try
match wire_of_yojson (Yojson.Safe.from_file (Fpath.to_string path)) with
| Ok w -> Ok (of_wire w)
- | Error msg ->
- Rresult.R.error_msgf "Doc_meta.load %a: %s" Fpath.pp path msg
+ | Error msg -> Rresult.R.error_msgf "Doc_meta.load %a: %s" Fpath.pp path msg
with exn ->
- Rresult.R.error_msgf "Doc_meta.load %a: %s"
- Fpath.pp path (Printexc.to_string exn)
+ Rresult.R.error_msgf "Doc_meta.load %a: %s" Fpath.pp path
+ (Printexc.to_string exn)
let exists layer_dir =
- Bos.OS.File.exists Fpath.(layer_dir / "doc.json") |> Result.value ~default:false
+ Bos.OS.File.exists Fpath.(layer_dir / "doc.json")
+ |> Result.value ~default:false
File "day11/doc/doc_meta.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/doc_meta.mli b/_build/default/day11/doc/.formatted/doc_meta.mli
index ed5f7e2..6bc821d 100644
--- a/_build/default/day11/doc/doc_meta.mli
+++ b/_build/default/day11/doc/.formatted/doc_meta.mli
@@ -1,30 +1,25 @@
-(** odoc doc-pipeline sidecar: per-layer metadata for documentation
- layers (compile / link / doc-all phases of the odoc driver).
+(** odoc doc-pipeline sidecar: per-layer metadata for documentation layers
+ (compile / link / doc-all phases of the odoc driver).
- Written next to {!Day11_layer.Meta} as [doc.json] in the layer
- directory. The presence of this file marks a layer as odoc
- output, as opposed to (e.g.) an opam package build layer marked
- by [build.json] from [day11_opam_layer]. This library is the
- minimal "doc layer" data layer — it depends only on
+ Written next to {!Day11_layer.Meta} as [doc.json] in the layer directory.
+ The presence of this file marks a layer as odoc output, as opposed to (e.g.)
+ an opam package build layer marked by [build.json] from [day11_opam_layer].
+ This library is the minimal "doc layer" data layer — it depends only on
[day11_layer], not on any opam-format types.
The phase distinguishes the three odoc-driver invocation modes:
- {!Compile} produces [.odoc] files (compile-only)
- {!Link} produces [.odocl] linked output
- - {!Doc_all} runs the whole pipeline (compile + link + html)
- in one container, the common case for packages that don't
- need a separate link phase. *)
+ - {!Doc_all} runs the whole pipeline (compile + link + html) in one
+ container, the common case for packages that don't need a separate link
+ phase. *)
type phase = Compile | Link | Doc_all
val string_of_phase : phase -> string
val phase_of_string : string -> phase
-type t = {
- package : string;
- phase : phase;
- deps : string list;
-}
+type t = { package : string; phase : phase; deps : string list }
val filename : string
(** ["doc.json"] *)
File "day11/doc/generate.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/generate.mli b/_build/default/day11/doc/.formatted/generate.mli
index 2c7632b..16af515 100644
--- a/_build/default/day11/doc/generate.mli
+++ b/_build/default/day11/doc/.formatted/generate.mli
@@ -2,32 +2,30 @@
Two-pass process:
- {b Compile}: for each package with installed libraries, run
- [odoc_driver_voodoo --actions compile-only] in a container with
- the package's build layer. Produces [.odoc] files.
+ [odoc_driver_voodoo --actions compile-only] in a container with the
+ package's build layer. Produces [.odoc] files.
- {b Link}: for each compiled package, run
- [odoc_driver_voodoo --actions link-and-gen] with the compile
- layers of all packages in the same solution stacked for
- cross-referencing. Produces HTML.
+ [odoc_driver_voodoo --actions link-and-gen] with the compile layers of all
+ packages in the same solution stacked for cross-referencing. Produces
+ HTML.
Tool binaries (odoc, odoc-md, odoc_driver_voodoo, sherlodoc) are
- bind-mounted from the tool layers at [/home/opam/doc-tools/bin/],
- keeping tool libraries isolated from documented packages.
+ bind-mounted from the tool layers at [/home/opam/doc-tools/bin/], keeping
+ tool libraries isolated from documented packages.
- The per-compiler odoc binary is selected based on which compiler
- appears in each package's solution.
+ The per-compiler odoc binary is selected based on which compiler appears in
+ each package's solution.
- Tool builds are included as nodes in the unified DAG, so they
- run in parallel with regular package builds instead of blocking. *)
+ Tool builds are included as nodes in the unified DAG, so they run in
+ parallel with regular package builds instead of blocking. *)
-val find_compiler :
- Day11_solution.Deps.t -> OpamPackage.t option
+val find_compiler : Day11_solution.Deps.t -> OpamPackage.t option
(** [find_compiler solution] returns the concrete compiler package
- ([ocaml-base-compiler], [ocaml-variants], or [ocaml-system])
- from [solution], or [None] if none is found. *)
+ ([ocaml-base-compiler], [ocaml-variants], or [ocaml-system]) from
+ [solution], or [None] if none is found. *)
val unique_compilers :
- (OpamPackage.t * Day11_solution.Solve_result.t) list ->
- OpamPackage.t list
+ (OpamPackage.t * Day11_solution.Solve_result.t) list -> OpamPackage.t list
(** Extract unique concrete compiler packages from solutions. *)
val run :
@@ -43,46 +41,47 @@ val run :
mounts:Day11_container.Mount.t list ->
run_log:Day11_lib.Run_log.t ->
build_one:(Day11_opam_layer.Build.t -> bool) ->
- ?on_pkg_complete:(Day11_opam_layer.Build.t ->
- cached:bool -> success:bool -> unit) ->
- ?on_doc_complete:(Day11_opam_layer.Build.t ->
- cached:bool -> success:bool -> unit) ->
+ ?on_pkg_complete:
+ (Day11_opam_layer.Build.t -> cached:bool -> success:bool -> unit) ->
+ ?on_doc_complete:
+ (Day11_opam_layer.Build.t -> cached:bool -> success:bool -> unit) ->
?snapshot_dir:Fpath.t ->
nodes:Day11_opam_layer.Build.t list ->
solutions:(OpamPackage.t * Day11_solution.Solve_result.t) list ->
blessing_maps:(OpamPackage.t * bool OpamPackage.Map.t) list ->
unit ->
int * int
-(** Run the unified build+doc DAG with pre-resolved tools.
- Returns [(doc_count, html_file_count)]. Uses {!Day11_opam_build.Dag_executor}
- for parallel execution with priority ordering (link > compile > tool > build). *)
+(** Run the unified build+doc DAG with pre-resolved tools. Returns
+ [(doc_count, html_file_count)]. Uses {!Day11_opam_build.Dag_executor} for
+ parallel execution with priority ordering (link > compile > tool > build).
+*)
(** {1 Planned doc DAG}
- [plan_doc_dag] constructs the doc DAG nodes without executing them.
- This is useful for external executors (like OCurrent) that want to
- create their own scheduling nodes from the DAG. *)
+ [plan_doc_dag] constructs the doc DAG nodes without executing them. This is
+ useful for external executors (like OCurrent) that want to create their own
+ scheduling nodes from the DAG. *)
type node_kind = Build | Tool | Compile | Doc_all | Link
type doc_plan = {
all_nodes : Day11_opam_layer.Build.t list;
- (** All nodes in the unified DAG (build + tool + doc). *)
+ (** All nodes in the unified DAG (build + tool + doc). *)
node_kind : Day11_opam_layer.Build.t -> node_kind;
- (** Classify a node by its phase. *)
- build_one : sw:Eio.Switch.t -> Eio_unix.Stdenv.base ->
- Day11_opam_layer.Build.t -> bool;
- (** Callback to build a single node. Takes a per-call Eio switch and
- the env; handles dispatch to the correct phase (build, tool,
- compile, link, doc-all). The per-call switch lets external
- executors (e.g. OCurrent nodes) bound the lifetime of spawned
- subprocesses to each build attempt. *)
+ (** Classify a node by its phase. *)
+ build_one :
+ sw:Eio.Switch.t -> Eio_unix.Stdenv.base -> Day11_opam_layer.Build.t -> bool;
+ (** Callback to build a single node. Takes a per-call Eio switch and the
+ env; handles dispatch to the correct phase (build, tool, compile,
+ link, doc-all). The per-call switch lets external executors (e.g.
+ OCurrent nodes) bound the lifetime of spawned subprocesses to each
+ build attempt. *)
epoch_hash : string;
- (** Epoch hash for this doc run (see {!Day11_lib.Epoch.compute}). The
- doc stages write HTML into [epoch_base/epoch-<epoch_hash>/html]. *)
+ (** Epoch hash for this doc run (see {!Day11_lib.Epoch.compute}). The doc
+ stages write HTML into [epoch_base/epoch-<epoch_hash>/html]. *)
epoch_base : Fpath.t;
- (** The profile's HTML base dir, under which epoch dirs and the
- [html-live] symlink live. *)
+ (** The profile's HTML base dir, under which epoch dirs and the
+ [html-live] symlink live. *)
}
val plan_doc_dag :
@@ -99,13 +98,12 @@ val plan_doc_dag :
blessing_maps:(OpamPackage.t * bool OpamPackage.Map.t) list ->
unit ->
doc_plan option
-(** Plan the doc DAG: solve for tools, construct compile/link/doc-all
- nodes with deterministic hashes, and return the unified DAG.
- Returns [None] if tool solving fails. All profile-derived inputs
- (git packages, repos, odoc repo, driver compiler, build env, hash
- cache) come from [ctx]. When [snapshot_dir] is given, the planned
- DAG is written to [<snapshot_dir>/dag.json] for offline cascade
- attribution (see {!Dag_marshal}). *)
+(** Plan the doc DAG: solve for tools, construct compile/link/doc-all nodes with
+ deterministic hashes, and return the unified DAG. Returns [None] if tool
+ solving fails. All profile-derived inputs (git packages, repos, odoc repo,
+ driver compiler, build env, hash cache) come from [ctx]. When [snapshot_dir]
+ is given, the planned DAG is written to [<snapshot_dir>/dag.json] for
+ offline cascade attribution (see {!Dag_marshal}). *)
val build_tools_and_run :
sw:Eio.Switch.t ->
@@ -114,10 +112,10 @@ val build_tools_and_run :
np:int ->
mounts:Day11_container.Mount.t list ->
build_one:(Day11_opam_layer.Build.t -> bool) ->
- ?on_pkg_complete:(Day11_opam_layer.Build.t ->
- cached:bool -> success:bool -> unit) ->
- ?on_doc_complete:(Day11_opam_layer.Build.t ->
- cached:bool -> success:bool -> unit) ->
+ ?on_pkg_complete:
+ (Day11_opam_layer.Build.t -> cached:bool -> success:bool -> unit) ->
+ ?on_doc_complete:
+ (Day11_opam_layer.Build.t -> cached:bool -> success:bool -> unit) ->
?snapshot_dir:Fpath.t ->
run_log:Day11_lib.Run_log.t ->
nodes:Day11_opam_layer.Build.t list ->
@@ -125,9 +123,9 @@ val build_tools_and_run :
blessing_maps:(OpamPackage.t * bool OpamPackage.Map.t) list ->
unit ->
unit
-(** Plan doc tools (driver + per-compiler odoc) and run a unified DAG
- that builds packages, tools, and docs in parallel. Profile-derived
- state comes from [ctx]: when [ctx.driver_compiler] is [None] the
- latest compiler from [solutions] is used; odoc is solved once per
- unique compiler; when [ctx.profile.odoc_repo] is set, odoc
- packages are pinned from that local checkout. *)
+(** Plan doc tools (driver + per-compiler odoc) and run a unified DAG that
+ builds packages, tools, and docs in parallel. Profile-derived state comes
+ from [ctx]: when [ctx.driver_compiler] is [None] the latest compiler from
+ [solutions] is used; odoc is solved once per unique compiler; when
+ [ctx.profile.odoc_repo] is set, odoc packages are pinned from that local
+ checkout. *)
File "day11/doc/odoc_store.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/odoc_store.ml b/_build/default/day11/doc/.formatted/odoc_store.ml
index 376ff84..546dade 100644
--- a/_build/default/day11/doc/odoc_store.ml
+++ b/_build/default/day11/doc/.formatted/odoc_store.ml
@@ -1,15 +1,9 @@
-type pkg_loc = {
- pkg : OpamPackage.t;
- universe : string;
- blessed : bool;
-}
+type pkg_loc = { pkg : OpamPackage.t; universe : string; blessed : bool }
let rel_path loc =
let name = OpamPackage.Name.to_string (OpamPackage.name loc.pkg) in
let version = OpamPackage.Version.to_string (OpamPackage.version loc.pkg) in
- if loc.blessed then
- Fpath.(v "p" / name / version)
- else
- Fpath.(v "u" / loc.universe / name / version)
+ if loc.blessed then Fpath.(v "p" / name / version)
+ else Fpath.(v "u" / loc.universe / name / version)
let container_html = "/home/opam/html"
File "day11/doc/odoc_store.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/odoc_store.mli b/_build/default/day11/doc/.formatted/odoc_store.mli
index 4c90188..74dbaa1 100644
--- a/_build/default/day11/doc/odoc_store.mli
+++ b/_build/default/day11/doc/.formatted/odoc_store.mli
@@ -1,16 +1,11 @@
(** Package location and path utilities for odoc output.
- Used to compute relative paths for HTML output mounts
- and container mount points. *)
+ Used to compute relative paths for HTML output mounts and container mount
+ points. *)
-type pkg_loc = {
- pkg : OpamPackage.t;
- universe : string;
- blessed : bool;
-}
-(** Location info for a package. Determines the path prefix:
- blessed uses [p/<Name>/<version>/], non-blessed uses
- [u/<universe>/<Name>/<version>/]. *)
+type pkg_loc = { pkg : OpamPackage.t; universe : string; blessed : bool }
+(** Location info for a package. Determines the path prefix: blessed uses
+ [p/<Name>/<version>/], non-blessed uses [u/<universe>/<Name>/<version>/]. *)
val rel_path : pkg_loc -> Fpath.t
(** The relative path fragment for a package location. *)
File "day11/doc/phase.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/phase.ml b/_build/default/day11/doc/.formatted/phase.ml
index 27406a1..44cdcca 100644
--- a/_build/default/day11/doc/phase.ml
+++ b/_build/default/day11/doc/.formatted/phase.ml
@@ -12,18 +12,15 @@ let phase_to_string = function
let doc_result_to_yojson = function
| Doc_success { html_path; blessed } ->
- `Assoc [
- ("status", `String "success");
- ("html_path", `String html_path);
- ("blessed", `Bool blessed);
- ]
- | Doc_skipped ->
- `Assoc [ ("status", `String "skipped") ]
+ `Assoc
+ [
+ ("status", `String "success");
+ ("html_path", `String html_path);
+ ("blessed", `Bool blessed);
+ ]
+ | Doc_skipped -> `Assoc [ ("status", `String "skipped") ]
| Doc_failure msg ->
- `Assoc [
- ("status", `String "failure");
- ("message", `String msg);
- ]
+ `Assoc [ ("status", `String "failure"); ("message", `String msg) ]
let doc_result_of_yojson json =
try
File "day11/doc/phase.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/phase.mli b/_build/default/day11/doc/.formatted/phase.mli
index 44f2c07..f49df10 100644
--- a/_build/default/day11/doc/phase.mli
+++ b/_build/default/day11/doc/.formatted/phase.mli
@@ -1,9 +1,6 @@
(** Documentation generation phases and results. *)
-type doc_phase =
- | Doc_all
- | Doc_compile_only
- | Doc_link_only
+type doc_phase = Doc_all | Doc_compile_only | Doc_link_only
type doc_result =
| Doc_success of { html_path : string; blessed : bool }
File "day11/doc/prep.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/prep.ml b/_build/default/day11/doc/.formatted/prep.ml
index 95156ae..4496b0b 100644
--- a/_build/default/day11/doc/prep.ml
+++ b/_build/default/day11/doc/.formatted/prep.ml
@@ -1,12 +1,9 @@
-let doc_relevant_doc_extensions =
- [ ".mld" ]
+let doc_relevant_doc_extensions = [ ".mld" ]
+let doc_relevant_doc_files = [ "odoc-config.sexp" ]
-let doc_relevant_doc_files =
- [ "odoc-config.sexp" ]
-
-(** Create prep directory structure and return bind mounts that map
- build layer lib/doc dirs into the prep layout.
- No file copying — the container sees files directly from cached layers. *)
+(** Create prep directory structure and return bind mounts that map build layer
+ lib/doc dirs into the prep layout. No file copying — the container sees
+ files directly from cached layers. *)
let create_with_mounts ~source_layer_dir ~dest_layer_dir ~universe ~pkg
~installed_libs ~installed_docs =
let switch = "default" in
@@ -22,50 +19,60 @@ let create_with_mounts ~source_layer_dir ~dest_layer_dir ~universe ~pkg
Bos.OS.Dir.create ~path:true lib_dest |> ignore;
Bos.OS.Dir.create ~path:true doc_dest |> ignore;
let lib_src =
- Fpath.(source_layer_dir / "fs" / "home" / "opam" / ".opam"
- / switch / "lib")
+ Fpath.(
+ source_layer_dir / "fs" / "home" / "opam" / ".opam" / switch / "lib")
in
(* Collect unique top-level lib subdirs to mount *)
- let lib_dirs = installed_libs |> List.filter_map (fun rel_path ->
- match String.split_on_char '/' rel_path with
- | dir :: _ -> Some dir
- | [] -> None
- ) |> List.sort_uniq String.compare in
- let lib_mounts = List.filter_map (fun dir ->
- let src = Fpath.(lib_src / dir) in
- if Bos.OS.Dir.exists src |> Result.get_ok then begin
- (* Create mount point dir in prep *)
- Bos.OS.Dir.create ~path:true Fpath.(lib_dest / dir) |> ignore;
- let container_dest = Printf.sprintf
- "/home/opam/prep/universes/%s/%s/%s/lib/%s"
- universe pkg_name pkg_version dir in
- Some (Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string src) container_dest)
- end else
- None
- ) lib_dirs in
+ let lib_dirs =
+ installed_libs
+ |> List.filter_map (fun rel_path ->
+ match String.split_on_char '/' rel_path with
+ | dir :: _ -> Some dir
+ | [] -> None)
+ |> List.sort_uniq String.compare
+ in
+ let lib_mounts =
+ List.filter_map
+ (fun dir ->
+ let src = Fpath.(lib_src / dir) in
+ if Bos.OS.Dir.exists src |> Result.get_ok then (
+ (* Create mount point dir in prep *)
+ Bos.OS.Dir.create ~path:true Fpath.(lib_dest / dir) |> ignore;
+ let container_dest =
+ Printf.sprintf "/home/opam/prep/universes/%s/%s/%s/lib/%s"
+ universe pkg_name pkg_version dir
+ in
+ Some
+ (Day11_container.Mount.bind_ro ~src:(Fpath.to_string src)
+ container_dest))
+ else None)
+ lib_dirs
+ in
let doc_src =
- Fpath.(source_layer_dir / "fs" / "home" / "opam" / ".opam"
- / switch / "doc")
+ Fpath.(
+ source_layer_dir / "fs" / "home" / "opam" / ".opam" / switch / "doc")
in
(* For doc files: only a few .mld files, copy them directly
(too few to justify per-file mounts) *)
let any_mld_copied = ref false in
- List.iter (fun rel_path ->
- let ext = Filename.extension rel_path in
- let name = Filename.basename rel_path in
- if List.mem ext doc_relevant_doc_extensions
- || List.mem name doc_relevant_doc_files then begin
- let src = Fpath.(doc_src // v rel_path) in
- let dst = Fpath.(doc_dest // v rel_path) in
- Bos.OS.Dir.create ~path:true (Fpath.parent dst) |> ignore;
- if Bos.OS.File.exists src |> Result.get_ok then begin
- Bos.OS.File.read src |> Result.get_ok
- |> Bos.OS.File.write dst |> ignore;
- if ext = ".mld" then any_mld_copied := true
- end
- end
- ) installed_docs;
+ List.iter
+ (fun rel_path ->
+ let ext = Filename.extension rel_path in
+ let name = Filename.basename rel_path in
+ if
+ List.mem ext doc_relevant_doc_extensions
+ || List.mem name doc_relevant_doc_files
+ then (
+ let src = Fpath.(doc_src // v rel_path) in
+ let dst = Fpath.(doc_dest // v rel_path) in
+ Bos.OS.Dir.create ~path:true (Fpath.parent dst) |> ignore;
+ if Bos.OS.File.exists src |> Result.get_ok then (
+ Bos.OS.File.read src
+ |> Result.get_ok
+ |> Bos.OS.File.write dst
+ |> ignore;
+ if ext = ".mld" then any_mld_copied := true)))
+ installed_docs;
(* odoc_driver_voodoo crashes ("nothing to compile") when the prep
tree contains neither a findlib lib nor any [.mld]. For packages
that install nothing documentable — ocaml wrappers, [conf-*]
@@ -76,16 +83,16 @@ let create_with_mounts ~source_layer_dir ~dest_layer_dir ~universe ~pkg
package-supplied [.mld] (we only write it when none was copied).
Voodoo's mld discovery walks [doc/<pkg>/], so the file goes
there. *)
- if not !any_mld_copied && lib_mounts = [] then begin
+ if (not !any_mld_copied) && lib_mounts = [] then (
let stub_dir = Fpath.(doc_dest / pkg_name) in
Bos.OS.Dir.create ~path:true stub_dir |> ignore;
let stub = Fpath.(stub_dir / "index.mld") in
- let body = Printf.sprintf
- "{0 %s.%s}\n\nThis package installs no documentable libraries.\n"
- pkg_name pkg_version in
- Bos.OS.File.write stub body |> ignore
- end;
+ let body =
+ Printf.sprintf
+ "{0 %s.%s}\n\nThis package installs no documentable libraries.\n"
+ pkg_name pkg_version
+ in
+ Bos.OS.File.write stub body |> ignore);
Ok (prep_root, lib_mounts)
with exn ->
- Rresult.R.error_msgf "Prep.create_with_mounts: %s"
- (Printexc.to_string exn)
+ Rresult.R.error_msgf "Prep.create_with_mounts: %s" (Printexc.to_string exn)
File "day11/doc/prep.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/prep.mli b/_build/default/day11/doc/.formatted/prep.mli
index 2e513a2..f68c869 100644
--- a/_build/default/day11/doc/prep.mli
+++ b/_build/default/day11/doc/.formatted/prep.mli
@@ -1,9 +1,9 @@
(** Prep structure creation for odoc.
- Creates the directory layout expected by [odoc_driver_voodoo] and
- returns bind mounts that map build layer lib directories directly
- into the prep structure. No file copying — the container sees
- files directly from cached layers. *)
+ Creates the directory layout expected by [odoc_driver_voodoo] and returns
+ bind mounts that map build layer lib directories directly into the prep
+ structure. No file copying — the container sees files directly from cached
+ layers. *)
val create_with_mounts :
source_layer_dir:Fpath.t ->
@@ -14,8 +14,7 @@ val create_with_mounts :
installed_docs:string list ->
(Fpath.t * Day11_container.Mount.t list, [> Rresult.R.msg ]) result
(** [create_with_mounts ~source_layer_dir ~dest_layer_dir ~universe ~pkg
- ~installed_libs ~installed_docs] creates the prep directory
- structure and returns [(prep_root, lib_mounts)]. The [lib_mounts]
- bind-mount each library directory from the build layer directly
- into the container's prep layout. Doc files (few, small) are
- copied directly. *)
+ ~installed_libs ~installed_docs] creates the prep directory structure and
+ returns [(prep_root, lib_mounts)]. The [lib_mounts] bind-mount each library
+ directory from the build layer directly into the container's prep layout.
+ Doc files (few, small) are copied directly. *)
File "day11/doc/sync.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/sync.ml b/_build/default/day11/doc/.formatted/sync.ml
index 9e49a94..2392079 100644
--- a/_build/default/day11/doc/sync.ml
+++ b/_build/default/day11/doc/.formatted/sync.ml
@@ -7,82 +7,92 @@ type doc_entry = {
let scan_cache env ~os_dir =
let layers = Day11_layer.Scan.list_layers env os_dir in
- List.filter_map (fun (name, path) ->
- if not (Astring.String.is_prefix ~affix:"doc-" name)
- || Astring.String.is_prefix ~affix:"doc-driver-" name
- || Astring.String.is_prefix ~affix:"doc-odoc-" name then
- None
- else
- let json_path = Fpath.(path / "layer.json") in
- match
- try Some (Yojson.Safe.from_file (Fpath.to_string json_path))
- with _ -> None
- with
- | None -> None
- | Some json ->
- try
- let open Yojson.Safe.Util in
- let pkg_str = json |> member "package" |> to_string in
- let pkg = OpamPackage.of_string pkg_str in
- let doc = json |> member "doc" in
- let status = doc |> member "status" |> to_string in
- if status <> "success" then None
- else
- let html_path = doc |> member "html_path" |> to_string in
- let blessed = doc |> member "blessed" |> to_bool in
- let dep_hashes =
- json |> member "dep_doc_hashes"
- |> to_list |> List.map to_string in
- let universe = Command.compute_universe_hash dep_hashes in
- Some { pkg; html_path = Fpath.v html_path; universe; blessed }
+ List.filter_map
+ (fun (name, path) ->
+ if
+ (not (Astring.String.is_prefix ~affix:"doc-" name))
+ || Astring.String.is_prefix ~affix:"doc-driver-" name
+ || Astring.String.is_prefix ~affix:"doc-odoc-" name
+ then None
+ else
+ let json_path = Fpath.(path / "layer.json") in
+ match
+ try Some (Yojson.Safe.from_file (Fpath.to_string json_path))
with _ -> None
- ) layers
+ with
+ | None -> None
+ | Some json -> (
+ try
+ let open Yojson.Safe.Util in
+ let pkg_str = json |> member "package" |> to_string in
+ let pkg = OpamPackage.of_string pkg_str in
+ let doc = json |> member "doc" in
+ let status = doc |> member "status" |> to_string in
+ if status <> "success" then None
+ else
+ let html_path = doc |> member "html_path" |> to_string in
+ let blessed = doc |> member "blessed" |> to_bool in
+ let dep_hashes =
+ json
+ |> member "dep_doc_hashes"
+ |> to_list
+ |> List.map to_string
+ in
+ let universe = Command.compute_universe_hash dep_hashes in
+ Some { pkg; html_path = Fpath.v html_path; universe; blessed }
+ with _ -> None))
+ layers
let sync ~sw env ~entries ~destination ?(blessed_only = false)
?(package_filter = fun _ -> true) ?(dry_run = false) ?on_progress () =
let filtered =
entries
|> List.filter (fun e ->
- (not blessed_only || e.blessed)
- && package_filter (OpamPackage.to_string e.pkg))
+ ((not blessed_only) || e.blessed)
+ && package_filter (OpamPackage.to_string e.pkg))
in
let total = List.length filtered in
let done_count = ref 0 in
let results =
- List.map (fun entry ->
- let src = Fpath.to_string entry.html_path ^ "/" in
- let dst_subpath =
- if entry.blessed then
- Printf.sprintf "%s/%s/"
- (OpamPackage.name_to_string entry.pkg)
- (OpamPackage.version_to_string entry.pkg)
- else
- Printf.sprintf "universes/%s/%s/%s/"
- entry.universe
- (OpamPackage.name_to_string entry.pkg)
- (OpamPackage.version_to_string entry.pkg)
- in
- let dst = destination ^ "/" ^ dst_subpath in
- let cmd =
- Bos.Cmd.(v "rsync" % "-av"
- %% (if dry_run then Bos.Cmd.v "--dry-run" else Bos.Cmd.empty)
- % "--delete" % src % dst)
- in
- let result =
- match Day11_sys.Run.run ~sw env cmd None with
- | run when run.Day11_sys.Run.status = `Exited 0 -> Ok ()
- | run ->
- Rresult.R.error_msgf "rsync failed for %s: %s"
- (OpamPackage.to_string entry.pkg) run.errors
- | exception exn ->
- Rresult.R.error_msgf "rsync: %s" (Printexc.to_string exn)
- in
- incr done_count;
- (match on_progress with
- | Some f -> f ~done_count:!done_count ~total ~pkg:entry.pkg
- | None -> ());
- result
- ) filtered
+ List.map
+ (fun entry ->
+ let src = Fpath.to_string entry.html_path ^ "/" in
+ let dst_subpath =
+ if entry.blessed then
+ Printf.sprintf "%s/%s/"
+ (OpamPackage.name_to_string entry.pkg)
+ (OpamPackage.version_to_string entry.pkg)
+ else
+ Printf.sprintf "universes/%s/%s/%s/" entry.universe
+ (OpamPackage.name_to_string entry.pkg)
+ (OpamPackage.version_to_string entry.pkg)
+ in
+ let dst = destination ^ "/" ^ dst_subpath in
+ let cmd =
+ Bos.Cmd.(
+ v "rsync"
+ % "-av"
+ %% (if dry_run then Bos.Cmd.v "--dry-run" else Bos.Cmd.empty)
+ % "--delete"
+ % src
+ % dst)
+ in
+ let result =
+ match Day11_sys.Run.run ~sw env cmd None with
+ | run when run.Day11_sys.Run.status = `Exited 0 -> Ok ()
+ | run ->
+ Rresult.R.error_msgf "rsync failed for %s: %s"
+ (OpamPackage.to_string entry.pkg)
+ run.errors
+ | exception exn ->
+ Rresult.R.error_msgf "rsync: %s" (Printexc.to_string exn)
+ in
+ incr done_count;
+ (match on_progress with
+ | Some f -> f ~done_count:!done_count ~total ~pkg:entry.pkg
+ | None -> ());
+ result)
+ filtered
in
match List.find_opt Result.is_error results with
| Some (Error _ as e) -> e
File "day11/doc/sync.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/sync.mli b/_build/default/day11/doc/.formatted/sync.mli
index 2813f38..394b2f3 100644
--- a/_build/default/day11/doc/sync.mli
+++ b/_build/default/day11/doc/.formatted/sync.mli
@@ -1,7 +1,7 @@
(** Documentation distribution via rsync.
- Syncs generated documentation from the local cache to a remote
- or local destination. *)
+ Syncs generated documentation from the local cache to a remote or local
+ destination. *)
type doc_entry = {
pkg : OpamPackage.t;
@@ -11,11 +11,9 @@ type doc_entry = {
}
(** A documentation entry discovered in the cache. *)
-val scan_cache :
- Eio_unix.Stdenv.base ->
- os_dir:Fpath.t -> doc_entry list
-(** [scan_cache env ~os_dir] scans for doc layers and extracts their
- HTML output paths. *)
+val scan_cache : Eio_unix.Stdenv.base -> os_dir:Fpath.t -> doc_entry list
+(** [scan_cache env ~os_dir] scans for doc layers and extracts their HTML output
+ paths. *)
val sync :
sw:Eio.Switch.t ->
@@ -28,8 +26,7 @@ val sync :
?on_progress:(done_count:int -> total:int -> pkg:OpamPackage.t -> unit) ->
unit ->
(unit, [> Rresult.R.msg ]) result
-(** [sync ~sw env ~entries ~destination ?blessed_only ?package_filter
- ?dry_run ?on_progress ()] rsyncs documentation to [destination].
- [on_progress] is invoked after each package's rsync completes
- (regardless of success) with the running count of processed
- entries. *)
+(** [sync ~sw env ~entries ~destination ?blessed_only ?package_filter ?dry_run
+ ?on_progress ()] rsyncs documentation to [destination]. [on_progress] is
+ invoked after each package's rsync completes (regardless of success) with
+ the running count of processed entries. *)
File "day11/doc/tool_binaries.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/tool_binaries.ml b/_build/default/day11/doc/.formatted/tool_binaries.ml
index fa6656f..2867318 100644
--- a/_build/default/day11/doc/tool_binaries.ml
+++ b/_build/default/day11/doc/.formatted/tool_binaries.ml
@@ -1,35 +1,45 @@
let switch = "default"
let find_binary (tool : Day11_opam_layer.Tool.t) name =
- let path = Fpath.(tool.dir / "fs" / "home" / "opam" / ".opam"
- / switch / "bin" / name) in
+ let path =
+ Fpath.(tool.dir / "fs" / "home" / "opam" / ".opam" / switch / "bin" / name)
+ in
if Bos.OS.File.exists path |> Result.get_ok then Some path
else
(* Try searching across all build layers *)
- List.find_map (fun (b : Day11_opam_layer.Build.t) ->
- let os_dir = Fpath.parent tool.dir in
- let bdir = Day11_opam_layer.Build.dir ~os_dir b in
- let p = Fpath.(bdir / "fs" / "home" / "opam" / ".opam"
- / switch / "bin" / name) in
- if Bos.OS.File.exists p |> Result.get_ok then Some p
- else None
- ) tool.builds
+ List.find_map
+ (fun (b : Day11_opam_layer.Build.t) ->
+ let os_dir = Fpath.parent tool.dir in
+ let bdir = Day11_opam_layer.Build.dir ~os_dir b in
+ let p =
+ Fpath.(
+ bdir / "fs" / "home" / "opam" / ".opam" / switch / "bin" / name)
+ in
+ if Bos.OS.File.exists p |> Result.get_ok then Some p else None)
+ tool.builds
let doc_tool_mounts tool =
let container_bin_dir = "/home/opam/doc-tools/bin" in
let odoc_bin = container_bin_dir ^ "/odoc" in
let odoc_md_bin = container_bin_dir ^ "/odoc-md" in
- let binaries = [
- ("odoc", odoc_bin);
- ("odoc-md", odoc_md_bin);
- ("odoc_driver_voodoo", container_bin_dir ^ "/odoc_driver_voodoo");
- ("sherlodoc", container_bin_dir ^ "/sherlodoc");
- ] in
- let mounts = List.filter_map (fun (name, container_path) ->
- match find_binary tool name with
- | Some host_path ->
- Some (Day11_container.Mount.bind_ro
- ~src:(Fpath.to_string host_path) container_path)
- | None -> None
- ) binaries in
+ let binaries =
+ [
+ ("odoc", odoc_bin);
+ ("odoc-md", odoc_md_bin);
+ ("odoc_driver_voodoo", container_bin_dir ^ "/odoc_driver_voodoo");
+ ("sherlodoc", container_bin_dir ^ "/sherlodoc");
+ ]
+ in
+ let mounts =
+ List.filter_map
+ (fun (name, container_path) ->
+ match find_binary tool name with
+ | Some host_path ->
+ Some
+ (Day11_container.Mount.bind_ro
+ ~src:(Fpath.to_string host_path)
+ container_path)
+ | None -> None)
+ binaries
+ in
(mounts, odoc_bin, odoc_md_bin)
File "day11/doc/tool_binaries.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/tool_binaries.mli b/_build/default/day11/doc/.formatted/tool_binaries.mli
index 21c9ff5..cc14574 100644
--- a/_build/default/day11/doc/tool_binaries.mli
+++ b/_build/default/day11/doc/.formatted/tool_binaries.mli
@@ -1,16 +1,14 @@
(** Extract tool binaries for bind-mounting into containers.
- Instead of stacking all tool build layers (which can be 90+
- layers), we just bind-mount the specific binaries we need. *)
+ Instead of stacking all tool build layers (which can be 90+ layers), we just
+ bind-mount the specific binaries we need. *)
-val find_binary :
- Day11_opam_layer.Tool.t -> string -> Fpath.t option
-(** [find_binary tool name] finds a binary called [name] in the
- tool layer's installed binaries. Returns [None] if not found. *)
+val find_binary : Day11_opam_layer.Tool.t -> string -> Fpath.t option
+(** [find_binary tool name] finds a binary called [name] in the tool layer's
+ installed binaries. Returns [None] if not found. *)
val doc_tool_mounts :
- Day11_opam_layer.Tool.t ->
- (Day11_container.Mount.t list * string * string)
-(** [doc_tool_mounts tool] returns [(mounts, odoc_bin, odoc_md_bin)]
- where [mounts] are bind mounts for the tool binaries and
- [odoc_bin]/[odoc_md_bin] are the container paths. *)
+ Day11_opam_layer.Tool.t -> Day11_container.Mount.t list * string * string
+(** [doc_tool_mounts tool] returns [(mounts, odoc_bin, odoc_md_bin)] where
+ [mounts] are bind mounts for the tool binaries and [odoc_bin]/[odoc_md_bin]
+ are the container paths. *)
File "day11/doc/tool_layer.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/tool_layer.ml b/_uild/default/day11/doc/.formatted/tool_layer.ml
index 90ae56e..e607ff5 100644
--- a/_build/default/day11/doc/tool_layer.ml
+++ b/_build/default/day11/doc/.formatted/tool_layer.ml
@@ -12,16 +12,23 @@ let driver_build_script ~packages ~pin_commands =
let install =
Printf.sprintf "opam install -y %s" (String.concat " " packages)
in
- String.concat "\n" (
- (if pins = "" then [] else [ pins ])
- @ [ install ])
+ String.concat "\n" ((if pins = "" then [] else [ pins ]) @ [ install ])
let driver_exists env ~layer_dir =
Day11_layer.Layer.exists env { hash = ""; dir = layer_dir }
let has_odoc_driver_voodoo ~layer_dir =
- let bin = Fpath.(layer_dir / "fs" / "home" / "opam" / ".opam"
- / "default" / "bin" / "odoc_driver_voodoo") in
+ let bin =
+ Fpath.(
+ layer_dir
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / "default"
+ / "bin"
+ / "odoc_driver_voodoo")
+ in
Sys.file_exists (Fpath.to_string bin)
(* Odoc layer *)
@@ -37,10 +44,11 @@ let odoc_layer_name ~base_hash ~ocaml_version ~compiler_hashes =
let odoc_build_script ~packages ~pin_commands =
driver_build_script ~packages ~pin_commands
-let odoc_exists env ~layer_dir =
- driver_exists env ~layer_dir
+let odoc_exists env ~layer_dir = driver_exists env ~layer_dir
let has_odoc ~layer_dir =
- let bin = Fpath.(layer_dir / "fs" / "home" / "opam" / ".opam"
- / "default" / "bin" / "odoc") in
+ let bin =
+ Fpath.(
+ layer_dir / "fs" / "home" / "opam" / ".opam" / "default" / "bin" / "odoc")
+ in
Sys.file_exists (Fpath.to_string bin)
File "day11/doc/tool_layer.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/tool_layer.mli b/_build/default/day11/doc/.formatted/tool_layer.mli
index 810db50..b5c25d6 100644
--- a/_build/default/day11/doc/tool_layer.mli
+++ b/_build/default/day11/doc/.formatted/tool_layer.mli
@@ -1,8 +1,8 @@
(** Doc tool layer management.
Manages two types of tool layers:
- - {b Driver layer} (shared): [odoc_driver_voodoo], [sherlodoc], [odoc-md]
- — built once with a fixed OCaml version.
+ - {b Driver layer} (shared): [odoc_driver_voodoo], [sherlodoc], [odoc-md] —
+ built once with a fixed OCaml version.
- {b Odoc layer} (per OCaml version): [odoc] — must match the target
compiler since [.cmt]/[.cmti] formats are version-specific.
@@ -20,9 +20,9 @@ val driver_layer_name :
val driver_build_script :
packages:string list -> pin_commands:string list -> string
-(** Generate the shell script to install driver tools. [packages] is
- the list of opam packages to install. [pin_commands] are optional
- [opam pin] commands for local repos. *)
+(** Generate the shell script to install driver tools. [packages] is the list of
+ opam packages to install. [pin_commands] are optional [opam pin] commands
+ for local repos. *)
val driver_exists : Eio_unix.Stdenv.base -> layer_dir:Fpath.t -> bool
(** Check if the driver layer has been built (layer.json exists). *)
File "day11/doc/universe.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/universe.ml b/_build/default/day11/doc/.formatted/universe.ml
index 0790337..ec2fb1a 100644
--- a/_build/default/day11/doc/universe.ml
+++ b/_build/default/day11/doc/.formatted/universe.ml
@@ -1,28 +1,34 @@
let save_manifest path ~universe_hash ~packages =
- let json = `Assoc [
- ("universe_hash", `String universe_hash);
- ("packages", `List (List.map (fun s -> `String s) packages));
- ] in
+ let json =
+ `Assoc
+ [
+ ("universe_hash", `String universe_hash);
+ ("packages", `List (List.map (fun s -> `String s) packages));
+ ]
+ in
Bos.OS.File.write path (Yojson.Safe.to_string json)
let load_manifest path =
match Bos.OS.File.read path with
| Error _ as e -> e
- | Ok data ->
- try
- let json = Yojson.Safe.from_string data in
- let open Yojson.Safe.Util in
- let hash = json |> member "universe_hash" |> to_string in
- let packages = json |> member "packages" |> to_list
- |> List.map to_string in
- Ok (hash, packages)
- with exn ->
- Rresult.R.error_msgf "Universe.load_manifest: %s" (Printexc.to_string exn)
+ | Ok data -> (
+ try
+ let json = Yojson.Safe.from_string data in
+ let open Yojson.Safe.Util in
+ let hash = json |> member "universe_hash" |> to_string in
+ let packages =
+ json |> member "packages" |> to_list |> List.map to_string
+ in
+ Ok (hash, packages)
+ with exn ->
+ Rresult.R.error_msgf "Universe.load_manifest: %s"
+ (Printexc.to_string exn))
let write_package_refs ~pkg_html_dir ~universe_hashes =
- let json = `Assoc [
- ("universes", `List (List.map (fun s -> `String s) universe_hashes));
- ] in
+ let json =
+ `Assoc
+ [ ("universes", `List (List.map (fun s -> `String s) universe_hashes)) ]
+ in
let path = Fpath.(pkg_html_dir / "universes.json") in
Bos.OS.File.write path (Yojson.Safe.to_string json)
@@ -30,45 +36,48 @@ let collect_referenced ~html_dir =
let p_dir = Fpath.(html_dir / "p") in
let p_dir_s = Fpath.to_string p_dir in
if not (Sys.file_exists p_dir_s) then []
- else begin
+ else
let refs = Hashtbl.create 64 in
(* Scan html/p/{pkg}/{ver}/universes.json *)
let scan_pkg pkg_name =
let pkg_dir = Filename.concat p_dir_s pkg_name in
try
- Sys.readdir pkg_dir |> Array.iter (fun ver ->
- let univ_file = Filename.concat
- (Filename.concat pkg_dir ver) "universes.json" in
- if Sys.file_exists univ_file then
- try
- let data = In_channel.with_open_text univ_file In_channel.input_all in
- let json = Yojson.Safe.from_string data in
- let open Yojson.Safe.Util in
- json |> member "universes" |> to_list |> List.iter (fun h ->
- Hashtbl.replace refs (to_string h) ())
- with _ -> ())
+ Sys.readdir pkg_dir
+ |> Array.iter (fun ver ->
+ let univ_file =
+ Filename.concat (Filename.concat pkg_dir ver) "universes.json"
+ in
+ if Sys.file_exists univ_file then
+ try
+ let data =
+ In_channel.with_open_text univ_file In_channel.input_all
+ in
+ let json = Yojson.Safe.from_string data in
+ let open Yojson.Safe.Util in
+ json
+ |> member "universes"
+ |> to_list
+ |> List.iter (fun h -> Hashtbl.replace refs (to_string h) ())
+ with _ -> ())
with Sys_error _ -> ()
in
- (try Sys.readdir p_dir_s |> Array.iter scan_pkg
- with Sys_error _ -> ());
+ (try Sys.readdir p_dir_s |> Array.iter scan_pkg with Sys_error _ -> ());
Hashtbl.fold (fun k () acc -> k :: acc) refs []
- end
let gc ~html_dir =
let u_dir = Fpath.(html_dir / "u") in
let u_dir_s = Fpath.to_string u_dir in
if not (Sys.file_exists u_dir_s) then 0
- else begin
+ else
let referenced = collect_referenced ~html_dir in
let ref_set = Hashtbl.create 64 in
List.iter (fun h -> Hashtbl.replace ref_set h ()) referenced;
let deleted = ref 0 in
(try
- Sys.readdir u_dir_s |> Array.iter (fun name ->
- if not (Hashtbl.mem ref_set name) then begin
- Bos.OS.Dir.delete ~recurse:true Fpath.(u_dir / name) |> ignore;
- incr deleted
- end)
+ Sys.readdir u_dir_s
+ |> Array.iter (fun name ->
+ if not (Hashtbl.mem ref_set name) then (
+ Bos.OS.Dir.delete ~recurse:true Fpath.(u_dir / name) |> ignore;
+ incr deleted))
with Sys_error _ -> ());
!deleted
- end
File "day11/doc/universe.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/universe.mli b/_build/default/day11/doc/.formatted/universe.mli
index ecc8c9b..93d48cc 100644
--- a/_build/default/day11/doc/universe.mli
+++ b/_build/default/day11/doc/.formatted/universe.mli
@@ -1,38 +1,36 @@
(** Universe tracking for documentation GC.
- Each documentation run produces universe directories
- ([html/u/{hash}/...]). A universe stays alive as long as at
- least one blessed package references it. References are stored
- in [universes.json] files alongside each package's docs. *)
+ Each documentation run produces universe directories ([html/u/{hash}/...]).
+ A universe stays alive as long as at least one blessed package references
+ it. References are stored in [universes.json] files alongside each package's
+ docs. *)
val save_manifest :
- Fpath.t -> universe_hash:string -> packages:string list ->
+ Fpath.t ->
+ universe_hash:string ->
+ packages:string list ->
(unit, [> Rresult.R.msg ]) result
-(** [save_manifest path ~universe_hash ~packages] writes a universe
- manifest ([universes/{hash}.json]) listing the packages in
- this universe. *)
+(** [save_manifest path ~universe_hash ~packages] writes a universe manifest
+ ([universes/{hash}.json]) listing the packages in this universe. *)
-val load_manifest :
- Fpath.t -> (string * string list, [> Rresult.R.msg ]) result
+val load_manifest : Fpath.t -> (string * string list, [> Rresult.R.msg ]) result
(** [load_manifest path] reads a universe manifest, returning
[(universe_hash, packages)]. *)
val write_package_refs :
- pkg_html_dir:Fpath.t -> universe_hashes:string list ->
+ pkg_html_dir:Fpath.t ->
+ universe_hashes:string list ->
(unit, [> Rresult.R.msg ]) result
-(** [write_package_refs ~pkg_html_dir ~universe_hashes] writes
- [universes.json] into the package's HTML directory listing which
- universes it references. Moves atomically with the package docs
- during {!Atomic_publish}. *)
+(** [write_package_refs ~pkg_html_dir ~universe_hashes] writes [universes.json]
+ into the package's HTML directory listing which universes it references.
+ Moves atomically with the package docs during {!Atomic_publish}. *)
-val collect_referenced :
- html_dir:Fpath.t -> string list
-(** [collect_referenced ~html_dir] scans all
- [html/p/{pkg}/{ver}/universes.json] files and returns the set of
- universe hashes referenced by any blessed package. *)
+val collect_referenced : html_dir:Fpath.t -> string list
+(** [collect_referenced ~html_dir] scans all [html/p/{pkg}/{ver}/universes.json]
+ files and returns the set of universe hashes referenced by any blessed
+ package. *)
-val gc :
- html_dir:Fpath.t -> int
-(** [gc ~html_dir] deletes universe directories under [html/u/] that
- are not referenced by any blessed package. Returns the number of
- universes deleted. *)
+val gc : html_dir:Fpath.t -> int
+(** [gc ~html_dir] deletes universe directories under [html/u/] that are not
+ referenced by any blessed package. Returns the number of universes deleted.
+*)
File "day11/jtw/build_tools.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/build_tools.ml b/_build/default/day11/jtw/.formatted/build_tools.ml
index 2265578..f9a674d 100644
--- a/_build/default/day11/jtw/build_tools.ml
+++ b/_build/default/day11/jtw/.formatted/build_tools.ml
@@ -3,42 +3,49 @@ let build_per_compiler ~sw env benv ~np ~packages ~repos ~mounts
Printf.printf "\nBuilding JTW tools from %s...\n%!" repo_dir;
let compiler_versions =
let seen = Hashtbl.create 4 in
- List.filter_map (fun (_target, solution) ->
- match Day11_doc.Generate.find_compiler solution with
- | Some c when not (Hashtbl.mem seen (OpamPackage.to_string c)) ->
- Hashtbl.replace seen (OpamPackage.to_string c) ();
- Some c
- | _ -> None
- ) solutions in
- List.filter_map (fun compiler_v ->
- Printf.printf "Building JTW for %s...\n%!"
- (OpamPackage.to_string compiler_v);
- match Day11_opam_build.Tools.build_tool_from_repo ~sw env benv ~np
- ~packages ~repos ~ocaml_version:compiler_v
- ~mounts ~extra_repo_dirs ~repo_dir
- ~extra_target_names:Tool_layer.extra_tool_targets
- ~target_name:Tool_layer.tool_target () with
- | Ok tool ->
- Printf.printf "JTW tools for %s: OK\n%!"
+ List.filter_map
+ (fun (_target, solution) ->
+ match Day11_doc.Generate.find_compiler solution with
+ | Some c when not (Hashtbl.mem seen (OpamPackage.to_string c)) ->
+ Hashtbl.replace seen (OpamPackage.to_string c) ();
+ Some c
+ | _ -> None)
+ solutions
+ in
+ List.filter_map
+ (fun compiler_v ->
+ Printf.printf "Building JTW for %s...\n%!"
(OpamPackage.to_string compiler_v);
- Some (compiler_v, tool)
- | Error (`Msg e) ->
- Printf.printf "JTW tools for %s failed: %s\n%!"
- (OpamPackage.to_string compiler_v) e;
- None
- ) compiler_versions
+ match
+ Day11_opam_build.Tools.build_tool_from_repo ~sw env benv ~np ~packages
+ ~repos ~ocaml_version:compiler_v ~mounts ~extra_repo_dirs ~repo_dir
+ ~extra_target_names:Tool_layer.extra_tool_targets
+ ~target_name:Tool_layer.tool_target ()
+ with
+ | Ok tool ->
+ Printf.printf "JTW tools for %s: OK\n%!"
+ (OpamPackage.to_string compiler_v);
+ Some (compiler_v, tool)
+ | Error (`Msg e) ->
+ Printf.printf "JTW tools for %s failed: %s\n%!"
+ (OpamPackage.to_string compiler_v)
+ e;
+ None)
+ compiler_versions
let build_and_run ~sw env benv ~np ~os_dir ~packages ~repos ~mounts
~extra_repo_dirs ~repo_dir ~output ~nodes ~solutions =
- let jtw_tools = build_per_compiler ~sw env benv ~np ~packages ~repos
- ~mounts ~extra_repo_dirs ~repo_dir ~solutions in
+ let jtw_tools =
+ build_per_compiler ~sw env benv ~np ~packages ~repos ~mounts
+ ~extra_repo_dirs ~repo_dir ~solutions
+ in
if jtw_tools = [] then
Printf.printf "No JTW tools built, skipping generation\n%!"
- else begin
+ else
let jtw_results, worker_layers =
- Generate.run ~sw env benv ~os_dir ~jtw_tools ~nodes ~solutions in
- Generate.assemble ~os_dir ~output ~jtw_results ~worker_layers
- ~solutions;
+ Generate.run ~sw env benv ~os_dir ~jtw_tools ~nodes ~solutions
+ in
+ Generate.assemble ~os_dir ~output ~jtw_results ~worker_layers ~solutions;
Printf.printf "\n=== JTW: %d packages, %d workers ===\n%!"
- (Hashtbl.length jtw_results) (List.length worker_layers)
- end
+ (Hashtbl.length jtw_results)
+ (List.length worker_layers)
File "day11/jtw/build_tools.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/build_tools.mli b/_build/default/day11/jtw/.formatted/build_tools.mli
index 11eaaf2..9853e98 100644
--- a/_build/default/day11/jtw/build_tools.mli
+++ b/_build/default/day11/jtw/.formatted/build_tools.mli
@@ -1,8 +1,8 @@
(** Build JTW tools, generate artifacts, and assemble output.
- Builds [js_top_worker-bin] from a local checkout for each unique
- compiler version, runs per-package and per-solution generation,
- then assembles the content-hashed output directory. *)
+ Builds [js_top_worker-bin] from a local checkout for each unique compiler
+ version, runs per-package and per-solution generation, then assembles the
+ content-hashed output directory. *)
val build_per_compiler :
sw:Eio.Switch.t ->
@@ -33,5 +33,5 @@ val build_and_run :
nodes:Day11_opam_layer.Build.t list ->
solutions:(OpamPackage.t * Day11_solution.Deps.t) list ->
unit
-(** Build tools, generate per-package artifacts and worker.js, then
- assemble the output directory at [output]. *)
+(** Build tools, generate per-package artifacts and worker.js, then assemble the
+ output directory at [output]. *)
File "day11/jtw/gen.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/gen.ml b/_build/default/day11/jtw/.formatted/gen.ml
index 306547f..6f9ddf0 100644
--- a/_build/default/day11/jtw/gen.ml
+++ b/_build/default/day11/jtw/.formatted/gen.ml
@@ -5,15 +5,15 @@ let collect_files_sorted ~base ~pred =
let files = ref [] in
let rec walk rel =
let full = if rel = "" then base else Filename.concat base rel in
- if Sys.file_exists full && Sys.is_directory full then begin
+ if Sys.file_exists full && Sys.is_directory full then
let entries = try Sys.readdir full |> Array.to_list with _ -> [] in
let entries = List.sort String.compare entries in
- List.iter (fun name ->
- let sub = if rel = "" then name else rel ^ "/" ^ name in
- walk sub
- ) entries
- end else if pred rel then
- files := rel :: !files
+ List.iter
+ (fun name ->
+ let sub = if rel = "" then name else rel ^ "/" ^ name in
+ walk sub)
+ entries
+ else if pred rel then files := rel :: !files
in
walk "";
List.rev !files
@@ -26,85 +26,100 @@ let compute_content_hash lib_dir =
in
let files = collect_files_sorted ~base:lib_dir ~pred:is_payload in
let buf = Buffer.create 4096 in
- List.iter (fun rel ->
- Buffer.add_string buf rel;
- Buffer.add_char buf '\000';
- let content =
- In_channel.with_open_bin (Filename.concat lib_dir rel)
- In_channel.input_all in
- Buffer.add_string buf content;
- Buffer.add_char buf '\000';
- ) files;
+ List.iter
+ (fun rel ->
+ Buffer.add_string buf rel;
+ Buffer.add_char buf '\000';
+ let content =
+ In_channel.with_open_bin
+ (Filename.concat lib_dir rel)
+ In_channel.input_all
+ in
+ Buffer.add_string buf content;
+ Buffer.add_char buf '\000')
+ files;
let hash = Digest.to_hex (Digest.string (Buffer.contents buf)) in
String.sub hash 0 16
let compute_compiler_content_hash tools_output_dir =
let buf = Buffer.create 4096 in
let worker_path = Filename.concat tools_output_dir "worker.js" in
- if Sys.file_exists worker_path then begin
+ if Sys.file_exists worker_path then (
Buffer.add_string buf "worker.js";
Buffer.add_char buf '\000';
Buffer.add_string buf
(In_channel.with_open_bin worker_path In_channel.input_all);
- Buffer.add_char buf '\000'
- end;
+ Buffer.add_char buf '\000');
let lib_dir = Filename.concat tools_output_dir "lib" in
- if Sys.file_exists lib_dir then begin
- let is_cmi f = Filename.check_suffix f ".cmi" in
- let files = collect_files_sorted ~base:lib_dir ~pred:is_cmi in
- List.iter (fun rel ->
- Buffer.add_string buf ("lib/" ^ rel);
- Buffer.add_char buf '\000';
- Buffer.add_string buf
- (In_channel.with_open_bin (Filename.concat lib_dir rel)
- In_channel.input_all);
- Buffer.add_char buf '\000';
- ) files
- end;
+ (if Sys.file_exists lib_dir then
+ let is_cmi f = Filename.check_suffix f ".cmi" in
+ let files = collect_files_sorted ~base:lib_dir ~pred:is_cmi in
+ List.iter
+ (fun rel ->
+ Buffer.add_string buf ("lib/" ^ rel);
+ Buffer.add_char buf '\000';
+ Buffer.add_string buf
+ (In_channel.with_open_bin
+ (Filename.concat lib_dir rel)
+ In_channel.input_all);
+ Buffer.add_char buf '\000')
+ files);
let hash = Digest.to_hex (Digest.string (Buffer.contents buf)) in
String.sub hash 0 16
let generate_dynamic_cmis_json ~dcs_url cmi_filenames =
- let all_cmis = List.map (fun s ->
- if Filename.check_suffix s ".cmi"
- then String.sub s 0 (String.length s - 4)
- else s
- ) cmi_filenames in
- let hidden, non_hidden = List.partition (fun x ->
- try let _ = Str.search_forward (Str.regexp_string "__") x 0 in true
- with Not_found -> false
- ) all_cmis in
- let prefixes = List.filter_map (fun x ->
- try
- let pos = Str.search_forward (Str.regexp_string "__") x 0 in
- Some (String.sub x 0 (pos + 2))
- with Not_found -> None
- ) hidden in
+ let all_cmis =
+ List.map
+ (fun s ->
+ if Filename.check_suffix s ".cmi" then
+ String.sub s 0 (String.length s - 4)
+ else s)
+ cmi_filenames
+ in
+ let hidden, non_hidden =
+ List.partition
+ (fun x ->
+ try
+ let _ = Str.search_forward (Str.regexp_string "__") x 0 in
+ true
+ with Not_found -> false)
+ all_cmis
+ in
+ let prefixes =
+ List.filter_map
+ (fun x ->
+ try
+ let pos = Str.search_forward (Str.regexp_string "__") x 0 in
+ Some (String.sub x 0 (pos + 2))
+ with Not_found -> None)
+ hidden
+ in
let prefixes = List.sort_uniq String.compare prefixes in
- let toplevel_modules = List.map String.capitalize_ascii non_hidden
- |> List.sort String.compare in
+ let toplevel_modules =
+ List.map String.capitalize_ascii non_hidden |> List.sort String.compare
+ in
let json_list xs =
- "[" ^ String.concat ","
- (List.map (fun s -> Printf.sprintf "%S" s) xs) ^ "]" in
+ "[" ^ String.concat "," (List.map (fun s -> Printf.sprintf "%S" s) xs) ^ "]"
+ in
Printf.sprintf
- {|{"dcs_url":%S,"dcs_toplevel_modules":%s,"dcs_file_prefixes":%s}|}
- dcs_url (json_list toplevel_modules) (json_list prefixes)
+ {|{"dcs_url":%S,"dcs_toplevel_modules":%s,"dcs_file_prefixes":%s}|} dcs_url
+ (json_list toplevel_modules)
+ (json_list prefixes)
let generate_findlib_index ~compiler meta_paths =
let metas = List.map (fun p -> `String p) meta_paths in
- Yojson.Safe.to_string (`Assoc [
- ("compiler", compiler);
- ("meta_files", `List metas);
- ])
+ Yojson.Safe.to_string
+ (`Assoc [ ("compiler", compiler); ("meta_files", `List metas) ])
let findlib_names_of_installed_libs installed_libs =
- List.filter_map (fun rel_path ->
- if Filename.basename rel_path = "META" then
- match String.split_on_char '/' (Filename.dirname rel_path) with
- | top :: _ -> Some top
- | [] -> None
- else None
- ) installed_libs
+ List.filter_map
+ (fun rel_path ->
+ if Filename.basename rel_path = "META" then
+ match String.split_on_char '/' (Filename.dirname rel_path) with
+ | top :: _ -> Some top
+ | [] -> None
+ else None)
+ installed_libs
|> List.sort_uniq String.compare
let container_script ~pkg ~installed_libs =
@@ -112,24 +127,23 @@ let container_script ~pkg ~installed_libs =
let findlib_names = findlib_names_of_installed_libs installed_libs in
if findlib_names = [] then "true"
else
- let libs = String.concat " "
- (List.map Filename.quote findlib_names) in
- String.concat " && " [
- "eval $(opam env)";
- Printf.sprintf
- "echo 'JTW: Building %s via jtw opam (%d findlib packages)'"
- pkg_name (List.length findlib_names);
- Printf.sprintf "jtw opam --path %s --no-worker -o /home/opam/jtw-output %s"
- (Filename.quote pkg_name) libs;
- "echo 'JTW: Done'";
- ]
+ let libs = String.concat " " (List.map Filename.quote findlib_names) in
+ String.concat " && "
+ [
+ "eval $(opam env)";
+ Printf.sprintf
+ "echo 'JTW: Building %s via jtw opam (%d findlib packages)'" pkg_name
+ (List.length findlib_names);
+ Printf.sprintf
+ "jtw opam --path %s --no-worker -o /home/opam/jtw-output %s"
+ (Filename.quote pkg_name) libs;
+ "echo 'JTW: Done'";
+ ]
type jtw_result = Jtw_success | Jtw_failure of string | Jtw_skipped
let jtw_result_to_yojson = function
- | Jtw_success ->
- `Assoc [ ("status", `String "success") ]
+ | Jtw_success -> `Assoc [ ("status", `String "success") ]
| Jtw_failure msg ->
`Assoc [ ("status", `String "failure"); ("error", `String msg) ]
- | Jtw_skipped ->
- `Assoc [ ("status", `String "skipped") ]
+ | Jtw_skipped -> `Assoc [ ("status", `String "skipped") ]
File "day11/jtw/gen.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/gen.mli b/_build/default/day11/jtw/.formatted/gen.mli
index f97738c..a598a44 100644
--- a/_build/default/day11/jtw/gen.mli
+++ b/_build/default/day11/jtw/.formatted/gen.mli
@@ -1,7 +1,7 @@
(** JTW generation logic.
- Pure functions for computing hashes, generating dynamic_cmis.json,
- findlib indexes, content hashes, and container scripts. *)
+ Pure functions for computing hashes, generating dynamic_cmis.json, findlib
+ indexes, content hashes, and container scripts. *)
(** {2 Hashing} *)
@@ -9,44 +9,39 @@ val compute_layer_hash : build_hash:string -> tools_hash:string -> string
(** Hash for a JTW layer, depending on the build and tools layers. *)
val compute_content_hash : string -> string
-(** [compute_content_hash lib_dir] hashes payload files (.cmi, .cma.js,
- META) in [lib_dir]. Returns first 16 hex chars. *)
+(** [compute_content_hash lib_dir] hashes payload files (.cmi, .cma.js, META) in
+ [lib_dir]. Returns first 16 hex chars. *)
val compute_compiler_content_hash : string -> string
-(** [compute_compiler_content_hash tools_output_dir] hashes worker.js
- and stdlib .cmi files. Returns first 16 hex chars. *)
+(** [compute_compiler_content_hash tools_output_dir] hashes worker.js and stdlib
+ .cmi files. Returns first 16 hex chars. *)
(** {2 JSON generation} *)
val generate_dynamic_cmis_json : dcs_url:string -> string list -> string
(** [generate_dynamic_cmis_json ~dcs_url cmi_filenames] generates the
- [dynamic_cmis.json] content. Partitions modules into toplevel
- (visible) and hidden ([__]-prefixed) with file prefixes. *)
+ [dynamic_cmis.json] content. Partitions modules into toplevel (visible) and
+ hidden ([__]-prefixed) with file prefixes. *)
-val generate_findlib_index :
- compiler:Yojson.Safe.t -> string list -> string
+val generate_findlib_index : compiler:Yojson.Safe.t -> string list -> string
(** [generate_findlib_index ~compiler meta_paths] generates the
[findlib_index.json] content with compiler info and META paths. *)
(** {2 Findlib} *)
val findlib_names_of_installed_libs : string list -> string list
-(** [findlib_names_of_installed_libs installed_libs] extracts top-level
- findlib package names from installed lib file paths by finding
- META files. Returns deduplicated, sorted names. *)
+(** [findlib_names_of_installed_libs installed_libs] extracts top-level findlib
+ package names from installed lib file paths by finding META files. Returns
+ deduplicated, sorted names. *)
(** {2 Container scripts} *)
-val container_script :
- pkg:OpamPackage.t -> installed_libs:string list -> string
-(** Generate the shell script for per-package JTW generation inside
- a container. Returns ["true"] if no findlib packages found. *)
+val container_script : pkg:OpamPackage.t -> installed_libs:string list -> string
+(** Generate the shell script for per-package JTW generation inside a container.
+ Returns ["true"] if no findlib packages found. *)
(** {2 Result type} *)
-type jtw_result =
- | Jtw_success
- | Jtw_failure of string
- | Jtw_skipped
+type jtw_result = Jtw_success | Jtw_failure of string | Jtw_skipped
val jtw_result_to_yojson : jtw_result -> Yojson.Safe.t
File "day11/jtw/generate.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/generate.mli b/_build/default/day11/jtw/.formatted/generate.mli
index 70dc12e..eb19ce4 100644
--- a/_build/default/day11/jtw/generate.mli
+++ b/_build/default/day11/jtw/.formatted/generate.mli
@@ -2,12 +2,12 @@
Three phases:
- {b Per-package}: for each package with findlib libraries, run
- [jtw opam --path <pkg> --no-worker] to produce [.cma.js],
- [.cmi], [META], and [dynamic_cmis.json].
- - {b Worker}: for each solution, run [jtw opam stdlib] with all
- build layers stacked to produce [worker.js] and stdlib artifacts.
- - {b Assembly}: merge per-package and worker outputs into a
- content-hashed directory structure for serving.
+ [jtw opam --path <pkg> --no-worker] to produce [.cma.js], [.cmi], [META],
+ and [dynamic_cmis.json].
+ - {b Worker}: for each solution, run [jtw opam stdlib] with all build layers
+ stacked to produce [worker.js] and stdlib artifacts.
+ - {b Assembly}: merge per-package and worker outputs into a content-hashed
+ directory structure for serving.
JTW tool binaries are bind-mounted from the tool layer. *)
@@ -21,11 +21,10 @@ val run :
solutions:(OpamPackage.t * Day11_solution.Deps.t) list ->
(OpamPackage.t, Day11_opam_layer.Build.t) Hashtbl.t
* (OpamPackage.t * Day11_opam_layer.Build.t) list
-(** [run env benv ~os_dir ~jtw_tools ~nodes ~solutions] generates
- per-package JTW artifacts and per-solution worker.js. Returns
- [(jtw_results, worker_layers)] where [jtw_results] maps packages
- to their JTW layer and [worker_layers] maps compilers to their
- worker layer. *)
+(** [run env benv ~os_dir ~jtw_tools ~nodes ~solutions] generates per-package
+ JTW artifacts and per-solution worker.js. Returns
+ [(jtw_results, worker_layers)] where [jtw_results] maps packages to their
+ JTW layer and [worker_layers] maps compilers to their worker layer. *)
val assemble :
os_dir:Fpath.t ->
@@ -34,6 +33,5 @@ val assemble :
worker_layers:(OpamPackage.t * Day11_opam_layer.Build.t) list ->
solutions:(OpamPackage.t * Day11_solution.Deps.t) list ->
unit
-(** [assemble ~os_dir ~output ~jtw_results ~worker_layers ~solutions]
- copies artifacts into a content-hashed directory structure at
- [output]. *)
+(** [assemble ~os_dir ~output ~jtw_results ~worker_layers ~solutions] copies
+ artifacts into a content-hashed directory structure at [output]. *)
File "day11/jtw/tool_layer.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/tool_layer.ml b/_build/default/day11/jtw/.formatted/tool_layer.ml
index 1994c76..5f54037 100644
--- a/_build/default/day11/jtw/tool_layer.ml
+++ b/_build/default/day11/jtw/.formatted/tool_layer.ml
@@ -1,8 +1,14 @@
let jtw_packages =
- [ "js_top_worker"; "js_top_worker-rpc"; "js_top_worker-bin";
- "js_top_worker-web"; "js_top_worker-widget";
- "js_top_worker-widget-leaflet"; "js_top_worker-client";
- "js_top_worker-unix" ]
+ [
+ "js_top_worker";
+ "js_top_worker-rpc";
+ "js_top_worker-bin";
+ "js_top_worker-web";
+ "js_top_worker-widget";
+ "js_top_worker-widget-leaflet";
+ "js_top_worker-client";
+ "js_top_worker-unix";
+ ]
let layer_hash ~base_hash ~ocaml_version ~compiler_hashes =
Day11_layer.Hash.of_strings
@@ -14,8 +20,7 @@ let layer_name ~base_hash ~ocaml_version ~compiler_hashes =
let build_script ~packages ~pin_commands ~needs_compiler ~compiler_pkg =
let compiler_cmds =
- if needs_compiler then
- [ Printf.sprintf "opam install -y %s" compiler_pkg ]
+ if needs_compiler then [ Printf.sprintf "opam install -y %s" compiler_pkg ]
else []
in
let install_cmd =
@@ -23,43 +28,59 @@ let build_script ~packages ~pin_commands ~needs_compiler ~compiler_pkg =
in
String.concat " && "
(compiler_cmds
- @ pin_commands
- @ [ install_cmd;
- "eval $(opam env) && which js_of_ocaml && which jtw";
- "eval $(opam env) && jtw opam --no-worker -o /home/opam/jtw-tools-output stdlib" ])
+ @ pin_commands
+ @ [
+ install_cmd;
+ "eval $(opam env) && which js_of_ocaml && which jtw";
+ "eval $(opam env) && jtw opam --no-worker -o \
+ /home/opam/jtw-tools-output stdlib";
+ ])
type pin = { package : string; url : string }
let build_cmd ~repo ~branch ~extra_pins =
- let jtw_pin_cmds = List.map (fun pkg ->
- Printf.sprintf "opam pin add -yn %s git+%s#%s" pkg repo branch
- ) jtw_packages in
- let extra_pin_cmds = List.map (fun (p : pin) ->
- Printf.sprintf "opam pin add -yn %s %s" p.package p.url
- ) extra_pins in
+ let jtw_pin_cmds =
+ List.map
+ (fun pkg ->
+ Printf.sprintf "opam pin add -yn %s git+%s#%s" pkg repo branch)
+ jtw_packages
+ in
+ let extra_pin_cmds =
+ List.map
+ (fun (p : pin) -> Printf.sprintf "opam pin add -yn %s %s" p.package p.url)
+ extra_pins
+ in
let install_cmd =
- "opam install -y js_of_ocaml js_top_worker-bin js_top_worker-web js_top_worker-widget"
+ "opam install -y js_of_ocaml js_top_worker-bin js_top_worker-web \
+ js_top_worker-widget"
in
let verify_cmd = "eval $(opam env) && which js_of_ocaml && which jtw" in
let jtw_cmd =
- "eval $(opam env) && jtw opam --no-worker -o /home/opam/jtw-tools-output stdlib"
+ "eval $(opam env) && jtw opam --no-worker -o /home/opam/jtw-tools-output \
+ stdlib"
in
String.concat " && "
(jtw_pin_cmds @ extra_pin_cmds @ [ install_cmd; verify_cmd; jtw_cmd ])
let build_cmd_local ~container_path ~extra_pins =
- let pin_cmds = List.map (fun pkg ->
- Printf.sprintf "opam pin add -yn %s %s" pkg container_path
- ) jtw_packages in
- let extra_pin_cmds = List.map (fun (p : pin) ->
- Printf.sprintf "opam pin add -yn %s %s" p.package p.url
- ) extra_pins in
+ let pin_cmds =
+ List.map
+ (fun pkg -> Printf.sprintf "opam pin add -yn %s %s" pkg container_path)
+ jtw_packages
+ in
+ let extra_pin_cmds =
+ List.map
+ (fun (p : pin) -> Printf.sprintf "opam pin add -yn %s %s" p.package p.url)
+ extra_pins
+ in
let install_cmd =
- "opam install -y js_of_ocaml js_top_worker-bin js_top_worker-web js_top_worker-widget"
+ "opam install -y js_of_ocaml js_top_worker-bin js_top_worker-web \
+ js_top_worker-widget"
in
let verify_cmd = "eval $(opam env) && which js_of_ocaml && which jtw" in
let jtw_cmd =
- "eval $(opam env) && jtw opam --no-worker -o /home/opam/jtw-tools-output stdlib"
+ "eval $(opam env) && jtw opam --no-worker -o /home/opam/jtw-tools-output \
+ stdlib"
in
String.concat " && "
(pin_cmds @ extra_pin_cmds @ [ install_cmd; verify_cmd; jtw_cmd ])
@@ -71,11 +92,22 @@ let exists ~layer_dir =
Bos.OS.File.exists Fpath.(layer_dir / "layer.json") |> Result.get_ok
let has_jsoo ~layer_dir =
- let path = Fpath.(layer_dir / "fs" / "home" / "opam" / ".opam"
- / "default" / "bin" / "js_of_ocaml") in
+ let path =
+ Fpath.(
+ layer_dir
+ / "fs"
+ / "home"
+ / "opam"
+ / ".opam"
+ / "default"
+ / "bin"
+ / "js_of_ocaml")
+ in
Sys.file_exists (Fpath.to_string path)
let has_worker_js ~layer_dir =
- let path = Fpath.(layer_dir / "fs" / "home" / "opam"
- / "jtw-tools-output" / "worker.js") in
+ let path =
+ Fpath.(
+ layer_dir / "fs" / "home" / "opam" / "jtw-tools-output" / "worker.js")
+ in
Sys.file_exists (Fpath.to_string path)
File "day11/jtw/tool_layer.mli", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/tool_layer.mli b/_build/default/day11/jtw/.formatted/tool_layer.mli
index 3ae6175..fdb528e 100644
--- a/_build/default/day11/jtw/tool_layer.mli
+++ b/_build/default/day11/jtw/.formatted/tool_layer.mli
@@ -1,7 +1,7 @@
(** JTW tool layer management.
- Per OCaml version: installs [js_of_ocaml] and [js_top_worker],
- builds [worker.js], extracts stdlib CMIs.
+ Per OCaml version: installs [js_of_ocaml] and [js_top_worker], builds
+ [worker.js], extracts stdlib CMIs.
Hash and name functions are pure. Existence checks do I/O. *)
@@ -9,42 +9,46 @@ val jtw_packages : string list
(** The opam packages that form the JTW toolchain. *)
val layer_hash :
- base_hash:string -> ocaml_version:string ->
- compiler_hashes:string list -> string
+ base_hash:string ->
+ ocaml_version:string ->
+ compiler_hashes:string list ->
+ string
val layer_name :
- base_hash:string -> ocaml_version:string ->
- compiler_hashes:string list -> string
+ base_hash:string ->
+ ocaml_version:string ->
+ compiler_hashes:string list ->
+ string
(** Directory name: [jtw-tools-{hash}]. *)
val build_script :
- packages:string list -> pin_commands:string list ->
- needs_compiler:bool -> compiler_pkg:string -> string
-(** Generate the shell script to install JTW tools and build
- worker.js + stdlib artifacts. *)
+ packages:string list ->
+ pin_commands:string list ->
+ needs_compiler:bool ->
+ compiler_pkg:string ->
+ string
+(** Generate the shell script to install JTW tools and build worker.js + stdlib
+ artifacts. *)
type pin = { package : string; url : string }
-val build_cmd :
- repo:string -> branch:string -> extra_pins:pin list -> string
-(** [build_cmd ~repo ~branch ~extra_pins] returns the shell command that
- pins js_top_worker packages from [repo#branch], pins [extra_pins],
- installs js_of_ocaml and js_top_worker, and builds worker.js +
- stdlib artifacts. *)
+val build_cmd : repo:string -> branch:string -> extra_pins:pin list -> string
+(** [build_cmd ~repo ~branch ~extra_pins] returns the shell command that pins
+ js_top_worker packages from [repo#branch], pins [extra_pins], installs
+ js_of_ocaml and js_top_worker, and builds worker.js + stdlib artifacts. *)
-val build_cmd_local :
- container_path:string -> extra_pins:pin list -> string
-(** [build_cmd_local ~container_path ~extra_pins] returns the shell
- command that pins js_top_worker packages from a local path
- (bind-mounted into the container), pins [extra_pins], installs
- and builds worker.js. The caller must provide the bind mount. *)
+val build_cmd_local : container_path:string -> extra_pins:pin list -> string
+(** [build_cmd_local ~container_path ~extra_pins] returns the shell command that
+ pins js_top_worker packages from a local path (bind-mounted into the
+ container), pins [extra_pins], installs and builds worker.js. The caller
+ must provide the bind mount. *)
val tool_target : string
(** The primary opam package name for the jtw tool binary. *)
val extra_tool_targets : string list
-(** Additional packages needed in the jtw tool layer beyond
- [tool_target] (e.g. [js_top_worker-web] for worker.js). *)
+(** Additional packages needed in the jtw tool layer beyond [tool_target] (e.g.
+ [js_top_worker-web] for worker.js). *)
val exists : layer_dir:Fpath.t -> bool
(** Check if the tool layer has been built. *)
File "src/lib/config.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/config.ml b/_build/default/src/lib/.formatted/config.ml
index bda65b2..ad5b2f9 100644
--- a/_build/default/src/lib/config.ml
+++ b/_build/default/src/lib/.formatted/config.ml
@@ -25,9 +25,7 @@ let take_n_last_versions =
let v jobs track_packages take_n_last_versions =
{ jobs; track_packages; take_n_last_versions }
-let cmdliner =
- Term.(const v $ jobs $ track_packages $ take_n_last_versions)
-
+let cmdliner = Term.(const v $ jobs $ track_packages $ take_n_last_versions)
let jobs t = t.jobs
let track_packages t = t.track_packages
let take_n_last_versions t = t.take_n_last_versions
File "src/lib/day11_base.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/day11_base.ml b/_build/default/src/lib/.formatted/day11_base.ml
index dd883fa..9ac413a 100644
--- a/_build/default/src/lib/day11_base.ml
+++ b/_build/default/src/lib/.formatted/day11_base.ml
@@ -1,16 +1,12 @@
-(** Wrap [Day11_batch.Profile_ctx.ensure_base] as a Current_cache
- op so the Docker build + import show up at [/jobs] with live
- logs. Downstream pipeline stages can then depend on the op's
- [unit Current.t] output instead of polling a background-fiber
- var. *)
+(** Wrap [Day11_batch.Profile_ctx.ensure_base] as a Current_cache op so the
+ Docker build + import show up at [/jobs] with live logs. Downstream pipeline
+ stages can then depend on the op's [unit Current.t] output instead of
+ polling a background-fiber var. *)
module Profile_ctx = Day11_batch.Profile_ctx
module Op = struct
- type t = {
- env : Eio_unix.Stdenv.base;
- ctx : Profile_ctx.t;
- }
+ type t = { env : Eio_unix.Stdenv.base; ctx : Profile_ctx.t }
module Key = struct
type t = {
@@ -27,7 +23,8 @@ module Op = struct
the op re-runs — which is what makes the per-profile
[opam-build-bin-<key>] cache actually get populated. *)
let digest t =
- let obr = match t.opam_build_repo with
+ let obr =
+ match t.opam_build_repo with
| None -> "upstream"
| Some p -> "local:" ^ p
in
@@ -43,37 +40,36 @@ module Op = struct
let id = "day11-ensure-base"
let auto_cancel = false
-
- let pp f (key : Key.t) =
- Fmt.pf f "ensure-base %s" key.profile_name
+ let pp f (key : Key.t) = Fmt.pf f "ensure-base %s" key.profile_name
let build (op_ctx : t) job (key : Key.t) =
let open Lwt.Syntax in
let* () = Current.Job.start job ~level:Current.Level.Average in
- Current.Job.log job
- "Ensuring base image for profile %s (digest %s)"
+ Current.Job.log job "Ensuring base image for profile %s (digest %s)"
key.profile_name key.image_digest;
Lwt_eio.run_eio @@ fun () ->
Eio.Switch.run @@ fun sw ->
let ctx = Profile_ctx.with_base_digest op_ctx.ctx key.image_digest in
match Profile_ctx.ensure_base ~sw op_ctx.env ctx with
| Ok _ready ->
- Current.Job.log job "Base image ready";
- Ok ()
+ Current.Job.log job "Base image ready";
+ Ok ()
| Error (`Msg msg) ->
- Current.Job.log job "Base image build failed: %s" msg;
- Error (`Msg msg)
+ Current.Job.log job "Base image build failed: %s" msg;
+ Error (`Msg msg)
end
module Cache = Current_cache.Make (Op)
let ensure ~env ~digest (ctx : Profile_ctx.t) : unit Current.t =
let open Current.Syntax in
- Current.component "ensure-base %s" ctx.profile.name |>
+ Current.component "ensure-base %s" ctx.profile.name
+ |>
let> image_digest = digest in
Cache.get { env; ctx }
- Op.Key.{
- profile_name = ctx.profile.name;
- image_digest;
- opam_build_repo = ctx.profile.opam_build_repo;
- }
+ Op.Key.
+ {
+ profile_name = ctx.profile.name;
+ image_digest;
+ opam_build_repo = ctx.profile.opam_build_repo;
+ }
File "src/lib/epoch_promote.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/epoch_promote.ml b/_build/default/src/lib/.formatted/epoch_promote.ml
index c2a6259..424bfe2 100644
--- a/_build/default/src/lib/epoch_promote.ml
+++ b/_build/default/src/lib/.formatted/epoch_promote.ml
@@ -1,18 +1,18 @@
(** Manual epoch promotion as a [Dangerous]-level OCurrent output.
- The doc pipeline builds each profile's HTML into a versioned
- [epoch-<hash>/] dir; the live site is served through a [html-live]
- symlink. Promotion swaps that symlink to a freshly-built epoch.
+ The doc pipeline builds each profile's HTML into a versioned [epoch-<hash>/]
+ dir; the live site is served through a [html-live] symlink. Promotion swaps
+ that symlink to a freshly-built epoch.
- This is deliberately a {!Current.Level.Dangerous} op: with the
- engine's confirmation threshold set below [Dangerous] (via
- [Current.Config]), it surfaces in the web UI as a node awaiting a
- manual click before it runs — so a rebuilt epoch goes live only when
- a human promotes it, exactly as the old ocaml-docs-ci did. Each
- distinct epoch hash is a separate output, so a new epoch reappears as
- a fresh "needs confirmation" node. *)
+ This is deliberately a {!Current.Level.Dangerous} op: with the engine's
+ confirmation threshold set below [Dangerous] (via [Current.Config]), it
+ surfaces in the web UI as a node awaiting a manual click before it runs — so
+ a rebuilt epoch goes live only when a human promotes it, exactly as the old
+ ocaml-docs-ci did. Each distinct epoch hash is a separate output, so a new
+ epoch reappears as a fresh "needs confirmation" node. *)
let src = Logs.Src.create "docs-ci.epoch-promote" ~doc:"Epoch promotion"
+
module Log = (val Logs.src_log src)
module Op = struct
@@ -22,6 +22,7 @@ module Op = struct
module Key = struct
type t = { base_dir : string; epoch_hash : string }
+
(* Key on (base_dir, epoch_hash) so each epoch is its own output:
a newly-built epoch surfaces as a fresh node to confirm. *)
let digest { base_dir; epoch_hash } =
@@ -42,8 +43,10 @@ module Op = struct
let* () = Current.Job.start job ~level:Current.Level.Dangerous in
let base_dir = Fpath.v key.base_dir in
let epoch =
- { Day11_lib.Epoch.hash = key.epoch_hash;
- dir = Fpath.(base_dir / ("epoch-" ^ key.epoch_hash)) }
+ {
+ Day11_lib.Epoch.hash = key.epoch_hash;
+ dir = Fpath.(base_dir / ("epoch-" ^ key.epoch_hash));
+ }
in
Lwt.return
(try
@@ -51,24 +54,29 @@ module Op = struct
(* Keep the 3 most-recent epochs (plus the live one — gc never
deletes the current target). *)
let deleted = Day11_lib.Epoch.gc ~base_dir ~keep:3 in
- Current.Job.log job "Promoted epoch %s -> %a/html-live (gc'd %d old epoch%s)"
+ Current.Job.log job
+ "Promoted epoch %s -> %a/html-live (gc'd %d old epoch%s)"
key.epoch_hash Fpath.pp base_dir deleted
(if deleted = 1 then "" else "s");
Ok ()
with exn ->
- Error (`Msg (Printf.sprintf "epoch promote failed: %s"
- (Printexc.to_string exn))))
+ Error
+ (`Msg
+ (Printf.sprintf "epoch promote failed: %s"
+ (Printexc.to_string exn))))
end
module Promote = Current_cache.Output (Op)
-(** [promote ~base_dir ~epoch_hash] is a [Dangerous] OCurrent node that,
- once confirmed in the web UI, points [base_dir/html-live] at
+(** [promote ~base_dir ~epoch_hash] is a [Dangerous] OCurrent node that, once
+ confirmed in the web UI, points [base_dir/html-live] at
[base_dir/epoch-<epoch_hash>/html]. *)
let promote ~base_dir ~epoch_hash : unit Current.t =
let open Current.Syntax in
Current.component "promote epoch %s"
- (String.sub epoch_hash 0 (min 12 (String.length epoch_hash))) |>
+ (String.sub epoch_hash 0 (min 12 (String.length epoch_hash)))
+ |>
let> () = Current.return () in
Promote.set Op.No_context
- { Op.Key.base_dir = Fpath.to_string base_dir; epoch_hash } ()
+ { Op.Key.base_dir = Fpath.to_string base_dir; epoch_hash }
+ ()
File "src/lib/github_pin_overlay.mli", line 1, characters 0-0:
diff --git a/_build/default/src/lib/github_pin_overlay.mli b/_build/default/src/lib/.formatted/github_pin_overlay.mli
index fce771d..48929f1 100644
--- a/_build/default/src/lib/github_pin_overlay.mli
+++ b/_build/default/src/lib/.formatted/github_pin_overlay.mli
@@ -1,14 +1,12 @@
-(** Maintain a synthetic opam-repository overlay built from a github
- URL.
+(** Maintain a synthetic opam-repository overlay built from a github URL.
Tracks an upstream branch (master) of a github repo (e.g.
- [github.com/ocaml/odoc]) and republishes its [.opam] manifests
- as an overlay opam-repository on disk, with each package's [src:]
- rewritten to [git+https://…#<sha>] and [version:] set to
- [<latest-tag>+master.<YYYYMMDD>.<sha7>]. The overlay is itself a
- git repo so day11's existing [Profile_ctx_loader] picks it up
- via the same [repos_with_shas] mechanism as a regular
- opam-repository [--remote].
+ [github.com/ocaml/odoc]) and republishes its [.opam] manifests as an overlay
+ opam-repository on disk, with each package's [src:] rewritten to
+ [git+https://…#<sha>] and [version:] set to
+ [<latest-tag>+master.<YYYYMMDD>.<sha7>]. The overlay is itself a git repo so
+ day11's existing [Profile_ctx_loader] picks it up via the same
+ [repos_with_shas] mechanism as a regular opam-repository [--remote].
The on-disk layout under [path/]:
{v
@@ -18,13 +16,13 @@
packages/<name>/<name>.<version>/opam
v}
- Profiles reference [<path>/repo] in their [opam_repositories]
- list; commits in [<path>/repo] flow through to a re-plan via
- OCurrent the same way mainline opam-repository commits do. *)
+ Profiles reference [<path>/repo] in their [opam_repositories] list; commits
+ in [<path>/repo] flow through to a re-plan via OCurrent the same way
+ mainline opam-repository commits do. *)
type spec = { url : string; path : Fpath.t }
-(** One [--github-pin-overlay URL=PATH] entry: track {!field:url} and
- keep an overlay under {!field:path}. *)
+(** One [--github-pin-overlay URL=PATH] entry: track {!field:url} and keep an
+ overlay under {!field:path}. *)
val spec_of_arg : string -> (spec, [> `Msg of string ]) result
(** Parse a [URL=PATH] CLI argument. Splits on the first [=]. *)
@@ -34,28 +32,25 @@ val maintain :
url:string ->
path:Fpath.t ->
string Current.t
-(** [maintain ~schedule ~url ~path] installs an OCurrent job that on
- each schedule tick:
+(** [maintain ~schedule ~url ~path] installs an OCurrent job that on each
+ schedule tick:
- fetches [url] into [path/upstream/] (clones on first run);
- reads upstream HEAD's SHA and the latest reachable tag;
- - regenerates [path/repo/packages/<name>/<name>.<ver>/opam] for
- each tracked package, with [version:] set to
- [<tag>+master.<YYYYMMDD>.<sha7>] and [src:] pointing at the
- pinned commit;
+ - regenerates [path/repo/packages/<name>/<name>.<ver>/opam] for each tracked
+ package, with [version:] set to [<tag>+master.<YYYYMMDD>.<sha7>] and
+ [src:] pointing at the pinned commit;
- commits the overlay if anything changed.
- Returns the overlay's HEAD SHA after the run. Same SHA across
- no-op ticks; downstream therefore re-plans only on a real
- upstream change. *)
+ Returns the overlay's HEAD SHA after the run. Same SHA across no-op ticks;
+ downstream therefore re-plans only on a real upstream change. *)
val maintain_commit :
schedule:Current_cache.Schedule.t ->
url:string ->
path:Fpath.t ->
Current_git.Commit.t Current.t
-(** Same as {!maintain}, but returns a [Current_git.Commit.t]
- appropriate for stashing in [remote_commits] alongside the
- [--remote] entries. The returned commit's [hash] is the
- overlay's own SHA, not the upstream's — a profile referencing
- the overlay path picks up commits via the existing tracking
+(** Same as {!maintain}, but returns a [Current_git.Commit.t] appropriate for
+ stashing in [remote_commits] alongside the [--remote] entries. The returned
+ commit's [hash] is the overlay's own SHA, not the upstream's — a profile
+ referencing the overlay path picks up commits via the existing tracking
machinery. *)
File "src/lib/remote_opam_repo.mli", line 1, characters 0-0:
diff --git a/_build/default/src/lib/remote_opam_repo.mli b/_build/default/src/lib/.formatted/remote_opam_repo.mli
index c4796a7..df88f10 100644
--- a/_build/default/src/lib/remote_opam_repo.mli
+++ b/_build/default/src/lib/.formatted/remote_opam_repo.mli
@@ -1,14 +1,12 @@
-(** Maintain a local clone of a remote opam-repository at a
- user-specified path.
+(** Maintain a local clone of a remote opam-repository at a user-specified path.
- Kept separate from [Day11_batch.Profile] so the profile schema
- (and therefore [day11 batch]) stays local-paths-only. The day11
- profile references [path]; this module keeps [path] fresh from
- [url]. *)
+ Kept separate from [Day11_batch.Profile] so the profile schema (and
+ therefore [day11 batch]) stays local-paths-only. The day11 profile
+ references [path]; this module keeps [path] fresh from [url]. *)
type spec = { url : string; path : Fpath.t }
-(** One [--remote URL=PATH] entry: "clone {!field:url} into
- {!field:path}, fetching periodically." *)
+(** One [--remote URL=PATH] entry: "clone {!field:url} into {!field:path},
+ fetching periodically." *)
val spec_of_arg : string -> (spec, [> `Msg of string ]) result
(** Parse a [URL=PATH] CLI argument. Split on the first [=]. *)
@@ -20,8 +18,8 @@ val maintain :
string Current.t
(** [maintain ~schedule ~url ~path] installs an OCurrent job that:
- on first run, [git clone --depth=1 URL PATH];
- - on each subsequent schedule fire, [git fetch + git merge
- --ff-only @{u}] in [PATH].
+ - on each subsequent schedule fire, [git fetch + git merge --ff-only @{u}]
+ in [PATH].
Returns the latest commit SHA. *)
@@ -30,9 +28,8 @@ val maintain_commit :
url:string ->
path:Fpath.t ->
Current_git.Commit.t Current.t
-(** Same as {!maintain}, but lifts the SHA into a
- [Current_git.Commit.t] keyed by [path]. Downstream consumers that
- want a [Commit.t] should use this instead of pairing {!maintain}
- with [Current_git.Local.head_commit] — the latter relies on an
- inotify watcher on [path/.git/], which can no-op silently if the
- pull job claims success without actually advancing HEAD. *)
+(** Same as {!maintain}, but lifts the SHA into a [Current_git.Commit.t] keyed
+ by [path]. Downstream consumers that want a [Commit.t] should use this
+ instead of pairing {!maintain} with [Current_git.Local.head_commit] — the
+ latter relies on an inotify watcher on [path/.git/], which can no-op
+ silently if the pull job claims success without actually advancing HEAD. *)
File "src/lib/track.mli", line 1, characters 0-0:
diff --git a/_build/default/src/lib/track.mli b/_build/default/src/lib/.formatted/track.mli
index 4e3c563..0fc343f 100644
--- a/_build/default/src/lib/track.mli
+++ b/_build/default/src/lib/.formatted/track.mli
@@ -9,16 +9,16 @@ val v :
filter:string list ->
Current_git.Commit.t Current.t ->
t list Current.t
-(** [repo_label] is a stable human-readable identifier for the repo
- — typically its filesystem path. It goes into the OCurrent
- component label so the same (filter, limit) can feed from
- multiple repos across one or more profiles without colliding. *)
+(** [repo_label] is a stable human-readable identifier for the repo — typically
+ its filesystem path. It goes into the OCurrent component label so the same
+ (filter, limit) can feed from multiple repos across one or more profiles
+ without colliding. *)
val merge : t list Current.t list -> t list Current.t
-(** Union per-repo tracking results with "later repos override"
- semantics, keyed by [(package_name, version)]. Mirrors opam's
- overlay resolution — an overlay repo that re-publishes the same
- [name.version] with modified content wins over mainline, while
- packages only in the overlay get added to the tracked universe. *)
+(** Union per-repo tracking results with "later repos override" semantics, keyed
+ by [(package_name, version)]. Mirrors opam's overlay resolution — an overlay
+ repo that re-publishes the same [name.version] with modified content wins
+ over mainline, while packages only in the overlay get added to the tracked
+ universe. *)
module Map : OpamStd.MAP with type key = t
File "src/lib/day11_base_digest.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/day11_base_digest.ml b/_build/default/src/lib/.formatted/day11_base_digest.ml
index 94a65be..8f8399c 100644
--- a/_build/default/src/lib/day11_base_digest.ml
+++ b/_build/default/src/lib/.formatted/day11_base_digest.ml
@@ -1,37 +1,34 @@
-(** OCurrent op that resolves the current registry digest of a
- Docker image tag on a periodic schedule.
+(** OCurrent op that resolves the current registry digest of a Docker image tag
+ on a periodic schedule.
- Output is the per-architecture [sha256:...] manifest digest of
- [IMAGE_TAG]. Downstream pipeline stages feed this digest into
- {!Day11_batch.Profile_ctx.with_base_digest}, so the base layer
- hash — and therefore every dependent layer hash — picks up any
- upstream image change automatically. No manual
- [day11 profile refresh-base] needed.
+ Output is the per-architecture [sha256:...] manifest digest of [IMAGE_TAG].
+ Downstream pipeline stages feed this digest into
+ {!Day11_batch.Profile_ctx.with_base_digest}, so the base layer hash — and
+ therefore every dependent layer hash — picks up any upstream image change
+ automatically. No manual [day11 profile refresh-base] needed.
- Runs [docker manifest inspect TAG], parses the multi-arch
- manifest, and picks the entry matching the requested arch. *)
+ Runs [docker manifest inspect TAG], parses the multi-arch manifest, and
+ picks the entry matching the requested arch. *)
module Op = struct
type t = unit
module Key = struct
- type t = {
- image : string;
- arch : string; (* opam arch, e.g. "x86_64" *)
- }
+ type t = { image : string; arch : string (* opam arch, e.g. "x86_64" *) }
+
let digest t = t.image ^ "|" ^ t.arch
end
module Value = struct
- type t = string (* sha256:... *)
+ type t = string (* sha256:... *)
+
let marshal t = t
let unmarshal t = t
end
let id = "day11-base-digest"
let auto_cancel = false
- let pp f (key : Key.t) =
- Fmt.pf f "resolve %s (%s)" key.image key.arch
+ let pp f (key : Key.t) = Fmt.pf f "resolve %s (%s)" key.image key.arch
let docker_arch = function
| "x86_64" | "amd64" -> "amd64"
@@ -40,49 +37,52 @@ module Op = struct
let build () job (key : Key.t) =
let open Lwt.Syntax in
- let* () = Current.Job.start job
- ~level:Current.Level.Mostly_harmless in
- Current.Job.log job
- "docker manifest inspect %s (arch=%s)" key.image key.arch;
+ let* () = Current.Job.start job ~level:Current.Level.Mostly_harmless in
+ Current.Job.log job "docker manifest inspect %s (arch=%s)" key.image
+ key.arch;
(* Use Lwt_process so stdout/stderr flow into the OCurrent job
log in real time. *)
- let cmd = ("", [| "docker"; "manifest"; "inspect";
- key.image |]) in
- let* output =
- Lwt_process.pread ~stderr:`Dev_null cmd
- in
+ let cmd = ("", [| "docker"; "manifest"; "inspect"; key.image |]) in
+ let* output = Lwt_process.pread ~stderr:`Dev_null cmd in
try
let json = Yojson.Safe.from_string output in
let open Yojson.Safe.Util in
let target = docker_arch key.arch in
let manifests = json |> member "manifests" |> to_list in
- let pick = List.find_map (fun m ->
- let plat = m |> member "platform" in
- let m_arch = plat |> member "architecture" |> to_string in
- let m_os = plat |> member "os" |> to_string in
- if m_arch = target && m_os = "linux" then
- Some (m |> member "digest" |> to_string)
- else None
- ) manifests in
+ let pick =
+ List.find_map
+ (fun m ->
+ let plat = m |> member "platform" in
+ let m_arch = plat |> member "architecture" |> to_string in
+ let m_os = plat |> member "os" |> to_string in
+ if m_arch = target && m_os = "linux" then
+ Some (m |> member "digest" |> to_string)
+ else None)
+ manifests
+ in
match pick with
| Some d ->
- Current.Job.log job "Resolved digest: %s" d;
- Lwt.return (Ok d)
+ Current.Job.log job "Resolved digest: %s" d;
+ Lwt.return (Ok d)
| None ->
- Lwt.return (Error (`Msg (Printf.sprintf
- "No %s/linux manifest in %s" target key.image)))
+ Lwt.return
+ (Error
+ (`Msg
+ (Printf.sprintf "No %s/linux manifest in %s" target key.image)))
with exn ->
- Lwt.return (Error (`Msg (Printf.sprintf
- "Failed to parse manifest JSON for %s: %s"
- key.image (Printexc.to_string exn))))
+ Lwt.return
+ (Error
+ (`Msg
+ (Printf.sprintf "Failed to parse manifest JSON for %s: %s"
+ key.image (Printexc.to_string exn))))
end
module Cache = Current_cache.Make (Op)
-(** Resolve the digest of [image] for [arch], refreshed per
- [schedule]. *)
+(** Resolve the digest of [image] for [arch], refreshed per [schedule]. *)
let current ~schedule ~image ~arch : string Current.t =
let open Current.Syntax in
- Current.component "base-digest %s" image |>
+ Current.component "base-digest %s" image
+ |>
let> () = Current.return () in
Cache.get ~schedule () Op.Key.{ image; arch }
File "day11/bin/cmd_disk.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_disk.ml b/_build/default/day11/bin/.formatted/cmd_disk.ml
index 6d70969..3c5682b 100644
--- a/_build/default/day11/bin/cmd_disk.ml
+++ b/_build/default/day11/bin/.formatted/cmd_disk.ml
@@ -4,13 +4,15 @@ open Cmdliner
let run profile_name profile_dir =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
| Ok (_profile, paths) ->
- let os_dir = paths.os_dir in
- let cache_dir = paths.cache_dir in
- let report = Day11_lib.Disk_usage.scan ~os_dir ~cache_dir in
- Fmt.pr "%a\n" Day11_lib.Disk_usage.pp report;
- 0
+ let os_dir = paths.os_dir in
+ let cache_dir = paths.cache_dir in
+ let report = Day11_lib.Disk_usage.scan ~os_dir ~cache_dir in
+ Fmt.pr "%a\n" Day11_lib.Disk_usage.pp report;
+ 0
let cmd =
let info = Cmd.info "disk" ~doc:"Show disk usage breakdown" in
File "day11/bin/cmd_debug.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_debug.ml b/_build/default/day11/bin/.formatted/cmd_debug.ml
index 047dac3..69819bf 100644
--- a/_build/default/day11/bin/cmd_debug.ml
+++ b/_build/default/day11/bin/.formatted/cmd_debug.ml
@@ -4,57 +4,71 @@ open Cmdliner
let run profile_name profile_dir target keep command =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (_profile, paths) ->
- Common.with_eio @@ fun ~sw env ->
- let os_dir = paths.os_dir in
- (* Resolve target: try as a hash first, then as a package name via
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (_profile, paths) -> (
+ Common.with_eio @@ fun ~sw env ->
+ let os_dir = paths.os_dir in
+ (* Resolve target: try as a hash first, then as a package name via
history lookup. [Build_meta.load_tree] reads [build.json] (and
falls back to [layer.json] for legacy layers); both are written
pre-attempt now, so failed builds load just fine. *)
- let node =
- match Day11_opam_layer.Build_meta.load_tree env ~os_dir target with
- | Ok n -> n
- | Error _ ->
- let packages_dir = match Common.latest_snapshot_dir paths with
- | Some sd -> Fpath.(sd / "packages")
- | None -> Fpath.(os_dir / "packages") in
- let entries = Day11_lib.History.read ~packages_dir ~pkg_str:target in
- let failure = List.find_opt (fun (e : Day11_lib.History.entry) ->
- e.status = "failure" && e.build_hash <> "none"
- ) entries in
- match failure with
- | Some e ->
- Printf.printf "Using %s\n%!" e.build_hash;
- (match Day11_opam_layer.Build_meta.load_tree env ~os_dir
- e.build_hash with
- | Ok n -> n
- | Error (`Msg msg) ->
- Printf.eprintf "Cannot load %s: %s\n" target msg;
- exit 1)
- | None ->
- Printf.eprintf "No failed build found for %s\n" target;
- exit 1
- in
- match Day11_opam_build.Debug.setup ~sw env ~os_dir ~keep node with
- | Error (`Msg e) ->
- Printf.eprintf "Setup failed: %s\n" e; 1
- | Ok session ->
- Printf.printf "Debug container for %s\n%!"
- (OpamPackage.to_string session.pkg);
- let result = match command with
- | Some cmd -> Day11_opam_build.Debug.run_command ~sw env session cmd
- | None -> Day11_opam_build.Debug.run_interactive ~sw env session
- in
- if not keep then Day11_opam_build.Debug.teardown ~sw env session;
- if keep then
- Printf.printf "Debug dir kept at: %s\n%!"
- (Fpath.to_string session.temp_dir);
- result
+ let node =
+ match Day11_opam_layer.Build_meta.load_tree env ~os_dir target with
+ | Ok n -> n
+ | Error _ -> (
+ let packages_dir =
+ match Common.latest_snapshot_dir paths with
+ | Some sd -> Fpath.(sd / "packages")
+ | None -> Fpath.(os_dir / "packages")
+ in
+ let entries =
+ Day11_lib.History.read ~packages_dir ~pkg_str:target
+ in
+ let failure =
+ List.find_opt
+ (fun (e : Day11_lib.History.entry) ->
+ e.status = "failure" && e.build_hash <> "none")
+ entries
+ in
+ match failure with
+ | Some e -> (
+ Printf.printf "Using %s\n%!" e.build_hash;
+ match
+ Day11_opam_layer.Build_meta.load_tree env ~os_dir e.build_hash
+ with
+ | Ok n -> n
+ | Error (`Msg msg) ->
+ Printf.eprintf "Cannot load %s: %s\n" target msg;
+ exit 1)
+ | None ->
+ Printf.eprintf "No failed build found for %s\n" target;
+ exit 1)
+ in
+ match Day11_opam_build.Debug.setup ~sw env ~os_dir ~keep node with
+ | Error (`Msg e) ->
+ Printf.eprintf "Setup failed: %s\n" e;
+ 1
+ | Ok session ->
+ Printf.printf "Debug container for %s\n%!"
+ (OpamPackage.to_string session.pkg);
+ let result =
+ match command with
+ | Some cmd -> Day11_opam_build.Debug.run_command ~sw env session cmd
+ | None -> Day11_opam_build.Debug.run_interactive ~sw env session
+ in
+ if not keep then Day11_opam_build.Debug.teardown ~sw env session;
+ if keep then
+ Printf.printf "Debug dir kept at: %s\n%!"
+ (Fpath.to_string session.temp_dir);
+ result)
let target_term =
- Arg.(required & pos 0 (some string) None & info [] ~docv:"TARGET"
- ~doc:"Package name or layer hash to debug")
+ Arg.(
+ required
+ & pos 0 (some string) None
+ & info [] ~docv:"TARGET" ~doc:"Package name or layer hash to debug")
let keep_term =
let doc = "Keep debug container for re-entry" in
@@ -62,10 +76,18 @@ let keep_term =
let command_term =
let doc = "Run command instead of interactive shell" in
- Arg.(value & opt (some string) None & info [ "command"; "c" ] ~docv:"CMD" ~doc)
+ Arg.(
+ value & opt (some string) None & info [ "command"; "c" ] ~docv:"CMD" ~doc)
let cmd =
let info = Cmd.info "debug" ~doc:"Launch interactive debug container" in
- let term = Term.(const run $ Common.profile_term $ Common.profile_dir_term
- $ target_term $ keep_term $ command_term) in
+ let term =
+ Term.(
+ const run
+ $ Common.profile_term
+ $ Common.profile_dir_term
+ $ target_term
+ $ keep_term
+ $ command_term)
+ in
Cmd.v info term
File "day11/bin/cmd_failures.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_failures.ml b/_build/default/day11/bin/.formatted/cmd_failures.ml
index bfaa860..4522156 100644
--- a/_build/default/day11/bin/cmd_failures.ml
+++ b/_build/default/day11/bin/.formatted/cmd_failures.ml
@@ -4,62 +4,77 @@ open Cmdliner
let run profile_name profile_dir =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (_profile, paths) ->
- match Common.latest_snapshot_dir paths with
- | None -> Printf.printf "No snapshots found\n"; 1
- | Some snapshot_dir ->
- let packages_dir = Fpath.(snapshot_dir / "packages") in
- let pkg_dir_s = Fpath.to_string packages_dir in
- let from_history () =
- let pkgs = Sys.readdir pkg_dir_s |> Array.to_list |> List.sort compare in
- List.filter_map (fun pkg_str ->
- let entries = Day11_lib.History.read ~packages_dir ~pkg_str in
- match entries with
- | [] -> None
- | latest :: _ ->
- if latest.status = "failure" then
- Some (pkg_str, latest.category,
- Option.value ~default:"" latest.error)
- else None
- ) pkgs in
- let from_live_view () =
- match Day11_batch.Live_view.load_latest ~snapshot_dir with
- | None -> []
- | Some lv ->
- Hashtbl.fold (fun pkg status acc ->
- match status with
- | "fail" -> (pkg, "build_failure", "") :: acc
- | "cascade" ->
- let dep = try Hashtbl.find lv.failed_dep pkg
- with Not_found -> "" in
- let note = if dep = "" then "cascade"
- else "cascade (blocked by " ^ dep ^ ")" in
- (pkg, note, "") :: acc
- | _ -> acc
- ) lv.pkg_status [] in
- let live = not (Day11_batch.Live_view.is_terminal ~snapshot_dir) in
- let failures =
- if Sys.file_exists pkg_dir_s && not live then from_history ()
- else from_live_view ()
- in
- if live then
- (match Day11_batch.Live_view.load_latest ~snapshot_dir with
- | Some lv ->
- Printf.printf "Run %s (in progress) — %s\n\n" lv.run_id
- (Day11_batch.Live_view.format_progress lv.progress)
- | None -> ());
- if failures = [] then
- Printf.printf "No failures\n"
- else begin
- let failures = List.sort compare failures in
- Printf.printf "%d failures:\n\n" (List.length failures);
- List.iter (fun (pkg, cat, err) ->
- Printf.printf " %-40s %s%s\n" pkg cat
- (if err = "" then "" else " " ^ err)
- ) failures
- end;
- 0
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (_profile, paths) -> (
+ match Common.latest_snapshot_dir paths with
+ | None ->
+ Printf.printf "No snapshots found\n";
+ 1
+ | Some snapshot_dir ->
+ let packages_dir = Fpath.(snapshot_dir / "packages") in
+ let pkg_dir_s = Fpath.to_string packages_dir in
+ let from_history () =
+ let pkgs =
+ Sys.readdir pkg_dir_s |> Array.to_list |> List.sort compare
+ in
+ List.filter_map
+ (fun pkg_str ->
+ let entries = Day11_lib.History.read ~packages_dir ~pkg_str in
+ match entries with
+ | [] -> None
+ | latest :: _ ->
+ if latest.status = "failure" then
+ Some
+ ( pkg_str,
+ latest.category,
+ Option.value ~default:"" latest.error )
+ else None)
+ pkgs
+ in
+ let from_live_view () =
+ match Day11_batch.Live_view.load_latest ~snapshot_dir with
+ | None -> []
+ | Some lv ->
+ Hashtbl.fold
+ (fun pkg status acc ->
+ match status with
+ | "fail" -> (pkg, "build_failure", "") :: acc
+ | "cascade" ->
+ let dep =
+ try Hashtbl.find lv.failed_dep pkg
+ with Not_found -> ""
+ in
+ let note =
+ if dep = "" then "cascade"
+ else "cascade (blocked by " ^ dep ^ ")"
+ in
+ (pkg, note, "") :: acc
+ | _ -> acc)
+ lv.pkg_status []
+ in
+ let live = not (Day11_batch.Live_view.is_terminal ~snapshot_dir) in
+ let failures =
+ if Sys.file_exists pkg_dir_s && not live then from_history ()
+ else from_live_view ()
+ in
+ (if live then
+ match Day11_batch.Live_view.load_latest ~snapshot_dir with
+ | Some lv ->
+ Printf.printf "Run %s (in progress) — %s\n\n" lv.run_id
+ (Day11_batch.Live_view.format_progress lv.progress)
+ | None -> ());
+ (if failures = [] then Printf.printf "No failures\n"
+ else
+ let failures = List.sort compare failures in
+ Printf.printf "%d failures:\n\n" (List.length failures);
+ List.iter
+ (fun (pkg, cat, err) ->
+ Printf.printf " %-40s %s%s\n" pkg cat
+ (if err = "" then "" else " " ^ err))
+ failures);
+ 0)
let cmd =
let info = Cmd.info "failures" ~doc:"List packages with failing builds" in
File "day11/bin/cmd_rdeps.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_rdeps.ml b/_build/default/day11/bin/.formatted/cmd_rdeps.ml
index 52fac21..2f4d383 100644
--- a/_build/default/day11/bin/cmd_rdeps.ml
+++ b/_build/default/day11/bin/.formatted/cmd_rdeps.ml
@@ -4,38 +4,51 @@ open Cmdliner
let run profile_name profile_dir package =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (profile, _paths) ->
- let _git_packages, repos_with_shas, _opam_env =
- Common.setup_solver profile.opam_repositories in
- let pkg = OpamPackage.of_string package in
- let results = Common.with_eio @@ fun ~sw env ->
- Day11_solver_pool.Solver_pool.solve_many ~sw env ~np:1
- ~repos:repos_with_shas [ pkg ] in
- match List.assoc_opt pkg results with
- | Some (Error (diag, _examined)) ->
- Printf.eprintf "Cannot solve %s: %s\n" package diag; 1
- | None ->
- Printf.eprintf "No result for %s\n" package; 1
- | Some (Ok result) ->
- let rdeps = Day11_solution.Rdeps.find
- [ result.Day11_solution.Solve_result.build_deps ] pkg in
- if OpamPackage.Set.is_empty rdeps then
- Printf.printf "No reverse dependencies for %s\n" package
- else begin
- Printf.printf "Reverse dependencies of %s:\n" package;
- OpamPackage.Set.iter (fun p ->
- Printf.printf " %s\n" (OpamPackage.to_string p)
- ) rdeps
- end;
- 0
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (profile, _paths) -> (
+ let _git_packages, repos_with_shas, _opam_env =
+ Common.setup_solver profile.opam_repositories
+ in
+ let pkg = OpamPackage.of_string package in
+ let results =
+ Common.with_eio @@ fun ~sw env ->
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ~np:1
+ ~repos:repos_with_shas [ pkg ]
+ in
+ match List.assoc_opt pkg results with
+ | Some (Error (diag, _examined)) ->
+ Printf.eprintf "Cannot solve %s: %s\n" package diag;
+ 1
+ | None ->
+ Printf.eprintf "No result for %s\n" package;
+ 1
+ | Some (Ok result) ->
+ let rdeps =
+ Day11_solution.Rdeps.find
+ [ result.Day11_solution.Solve_result.build_deps ]
+ pkg
+ in
+ if OpamPackage.Set.is_empty rdeps then
+ Printf.printf "No reverse dependencies for %s\n" package
+ else (
+ Printf.printf "Reverse dependencies of %s:\n" package;
+ OpamPackage.Set.iter
+ (fun p -> Printf.printf " %s\n" (OpamPackage.to_string p))
+ rdeps);
+ 0)
let package_term =
- Arg.(required & pos 0 (some string) None & info [] ~docv:"PACKAGE"
- ~doc:"Package to find rdeps for")
+ Arg.(
+ required
+ & pos 0 (some string) None
+ & info [] ~docv:"PACKAGE" ~doc:"Package to find rdeps for")
let cmd =
let info = Cmd.info "rdeps" ~doc:"Find reverse dependencies" in
- let term = Term.(const run $ Common.profile_term $ Common.profile_dir_term
- $ package_term) in
+ let term =
+ Term.(
+ const run $ Common.profile_term $ Common.profile_dir_term $ package_term)
+ in
Cmd.v info term
File "day11/bin/cmd_rerun.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_rerun.ml b/_build/default/day11/bin/.formatted/cmd_rerun.ml
index cdca708..4fb30a3 100644
--- a/_build/default/day11/bin/cmd_rerun.ml
+++ b/_build/default/day11/bin/.formatted/cmd_rerun.ml
@@ -4,33 +4,41 @@ open Cmdliner
let run profile_name profile_dir layer_hash =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (_profile, paths) ->
- Common.with_eio @@ fun ~sw env ->
- let os_dir = paths.os_dir in
- match Day11_opam_layer.Build_meta.load_tree env ~os_dir layer_hash with
| Error (`Msg e) ->
- Printf.eprintf "Cannot load layer %s: %s\n" layer_hash e;
- 1
- | Ok node ->
- let cache_dir = paths.cache_dir in
- Printf.printf "Rerunning %s (%s)...\n%!"
- (OpamPackage.to_string node.pkg)
- (Day11_opam_layer.Build.dir_name node);
- match Day11_batch.Rerun.rerun ~sw env ~os_dir ~cache_dir node with
- | Day11_opam_build.Types.Success _ ->
- Printf.printf "Success\n"; 0
- | Day11_opam_build.Types.Failure msg ->
- Printf.printf "Failed: %s\n" msg; 1
- | _ ->
- Printf.printf "Unexpected result\n"; 1
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (_profile, paths) -> (
+ Common.with_eio @@ fun ~sw env ->
+ let os_dir = paths.os_dir in
+ match Day11_opam_layer.Build_meta.load_tree env ~os_dir layer_hash with
+ | Error (`Msg e) ->
+ Printf.eprintf "Cannot load layer %s: %s\n" layer_hash e;
+ 1
+ | Ok node -> (
+ let cache_dir = paths.cache_dir in
+ Printf.printf "Rerunning %s (%s)...\n%!"
+ (OpamPackage.to_string node.pkg)
+ (Day11_opam_layer.Build.dir_name node);
+ match Day11_batch.Rerun.rerun ~sw env ~os_dir ~cache_dir node with
+ | Day11_opam_build.Types.Success _ ->
+ Printf.printf "Success\n";
+ 0
+ | Day11_opam_build.Types.Failure msg ->
+ Printf.printf "Failed: %s\n" msg;
+ 1
+ | _ ->
+ Printf.printf "Unexpected result\n";
+ 1))
let hash_term =
- Arg.(required & pos 0 (some string) None & info [] ~docv:"HASH"
- ~doc:"Full layer hash to rerun")
+ Arg.(
+ required
+ & pos 0 (some string) None
+ & info [] ~docv:"HASH" ~doc:"Full layer hash to rerun")
let cmd =
let info = Cmd.info "rerun" ~doc:"Retry a failed build" in
- let term = Term.(const run $ Common.profile_term $ Common.profile_dir_term
- $ hash_term) in
+ let term =
+ Term.(const run $ Common.profile_term $ Common.profile_dir_term $ hash_term)
+ in
Cmd.v info term
File "day11/jtw/generate.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/jtw/generate.ml b/_build/default/day11/jtw/.formatted/generate.ml
index ae346cb..7d474f7 100644
--- a/_build/default/day11/jtw/generate.ml
+++ b/_build/default/day11/jtw/.formatted/generate.ml
@@ -1,118 +1,151 @@
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
+
type build = Build.t
let generate_package ~sw env benv ~os_dir ~(jtw_tool : Tool.t) (node : build) =
let pkg_dir = Build.dir ~os_dir node in
- let installed_libs = Day11_opam_layer.Installed_files.scan_libs
- ~layer_dir:pkg_dir in
+ let installed_libs =
+ Day11_opam_layer.Installed_files.scan_libs ~layer_dir:pkg_dir
+ in
if installed_libs = [] then None
else
- let findlib_names = Gen.findlib_names_of_installed_libs installed_libs in
- if findlib_names = [] then None
- else begin
- (* JTW needs the full tool layer stacked (not just bind-mounted binaries)
+ let findlib_names = Gen.findlib_names_of_installed_libs installed_libs in
+ if findlib_names = [] then None
+ else
+ (* JTW needs the full tool layer stacked (not just bind-mounted binaries)
because jtw uses ocamlfind at runtime to discover libraries *)
- let cmd =
- "eval $(opam env) && " ^
- Gen.container_script ~pkg:node.pkg ~installed_libs in
- let hash = Gen.compute_layer_hash
- ~build_hash:node.hash ~tools_hash:jtw_tool.hash in
- let jtw_node : build =
- { hash; pkg = node.pkg;
- deps = jtw_tool.builds @ [ node ]; universe = Day11_solution.Universe.dummy } in
- match Day11_opam_build.Build_layer.build ~sw env benv
- ~opam_repositories:[]
- jtw_node
- ~strategy:{ cmd; cleanup = fun ~sw:_ _ _ -> () } () with
- | Day11_opam_build.Types.Success bl ->
- Printf.printf " %s: OK\n%!" (OpamPackage.to_string node.pkg);
- Some bl
- | _ ->
- Printf.printf " %s: FAILED\n%!" (OpamPackage.to_string node.pkg);
- None
- end
+ let cmd =
+ "eval $(opam env) && "
+ ^ Gen.container_script ~pkg:node.pkg ~installed_libs
+ in
+ let hash =
+ Gen.compute_layer_hash ~build_hash:node.hash ~tools_hash:jtw_tool.hash
+ in
+ let jtw_node : build =
+ {
+ hash;
+ pkg = node.pkg;
+ deps = jtw_tool.builds @ [ node ];
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[]
+ jtw_node
+ ~strategy:{ cmd; cleanup = (fun ~sw:_ _ _ -> ()) }
+ ()
+ with
+ | Day11_opam_build.Types.Success bl ->
+ Printf.printf " %s: OK\n%!" (OpamPackage.to_string node.pkg);
+ Some bl
+ | _ ->
+ Printf.printf " %s: FAILED\n%!" (OpamPackage.to_string node.pkg);
+ None
-(** Build worker.js for a solution. Stacks all build layers from the
- solution and runs [jtw opam -o ... stdlib]. *)
+(** Build worker.js for a solution. Stacks all build layers from the solution
+ and runs [jtw opam -o ... stdlib]. *)
let build_worker ~sw env benv ~(jtw_tool : Tool.t) ~solution_nodes =
let cmd =
- "eval $(opam env) && " ^
- "jtw opam -o /home/opam/jtw-worker-output stdlib" in
+ "eval $(opam env) && " ^ "jtw opam -o /home/opam/jtw-worker-output stdlib"
+ in
let dep_hashes = List.map (fun (n : build) -> n.hash) solution_nodes in
- let hash = Day11_layer.Hash.of_strings
- ([ "jtw-worker"; jtw_tool.hash ] @ dep_hashes) in
+ let hash =
+ Day11_layer.Hash.of_strings ([ "jtw-worker"; jtw_tool.hash ] @ dep_hashes)
+ in
let dummy_pkg = OpamPackage.of_string "jtw-worker.0" in
let worker_node : build =
- { hash; pkg = dummy_pkg;
- deps = jtw_tool.builds @ solution_nodes; universe = Day11_solution.Universe.dummy } in
- match Day11_opam_build.Build_layer.build ~sw env benv
- ~opam_repositories:[]
- worker_node
- ~strategy:{ cmd; cleanup = fun ~sw:_ _ _ -> () } () with
+ {
+ hash;
+ pkg = dummy_pkg;
+ deps = jtw_tool.builds @ solution_nodes;
+ universe = Day11_solution.Universe.dummy;
+ }
+ in
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[]
+ worker_node
+ ~strategy:{ cmd; cleanup = (fun ~sw:_ _ _ -> ()) }
+ ()
+ with
| Day11_opam_build.Types.Success bl ->
- Printf.printf " worker.js: OK\n%!";
- Some bl
+ Printf.printf " worker.js: OK\n%!";
+ Some bl
| _ ->
- Printf.printf " worker.js: FAILED\n%!";
- None
+ Printf.printf " worker.js: FAILED\n%!";
+ None
let run ~sw env benv ~os_dir ~jtw_tools ~nodes ~solutions =
(* Map each (pkg, universe) build_hash to its compiler. Keying by
[pkg] alone would collapse universes: the same (name, version)
can build against different compilers in different solutions. *)
let bh_compiler = Hashtbl.create 64 in
- List.iter (fun (_target, solution) ->
- match Day11_doc.Generate.find_compiler solution with
- | None -> ()
- | Some compiler ->
- let trans = Day11_solution.Deps.transitive_deps solution in
- OpamPackage.Map.iter (fun pkg deps ->
- let u_s = Day11_solution.Universe.to_string
- (Day11_solution.Universe.of_deps deps) in
- Hashtbl.replace bh_compiler
- (OpamPackage.to_string pkg, u_s) compiler
- ) trans
- ) solutions;
+ List.iter
+ (fun (_target, solution) ->
+ match Day11_doc.Generate.find_compiler solution with
+ | None -> ()
+ | Some compiler ->
+ let trans = Day11_solution.Deps.transitive_deps solution in
+ OpamPackage.Map.iter
+ (fun pkg deps ->
+ let u_s =
+ Day11_solution.Universe.to_string
+ (Day11_solution.Universe.of_deps deps)
+ in
+ Hashtbl.replace bh_compiler
+ (OpamPackage.to_string pkg, u_s)
+ compiler)
+ trans)
+ solutions;
let find_jtw_tool (node : build) =
let u_s = Day11_solution.Universe.to_string node.universe in
- match Hashtbl.find_opt bh_compiler
- (OpamPackage.to_string node.pkg, u_s) with
+ match
+ Hashtbl.find_opt bh_compiler (OpamPackage.to_string node.pkg, u_s)
+ with
| None -> None
| Some compiler ->
- List.find_opt (fun (c, _) ->
- OpamPackage.equal c compiler) jtw_tools
- |> Option.map snd
+ List.find_opt (fun (c, _) -> OpamPackage.equal c compiler) jtw_tools
+ |> Option.map snd
in
(* Per-package generation *)
Printf.printf " JTW per-package (%d packages)...\n%!" (List.length nodes);
let jtw_results : (OpamPackage.t, build) Hashtbl.t = Hashtbl.create 64 in
- List.iter (fun (node : build) ->
- match find_jtw_tool node with
- | None -> ()
- | Some jtw_tool ->
- match generate_package ~sw env benv ~os_dir ~jtw_tool node with
- | Some bl -> Hashtbl.replace jtw_results node.pkg bl
+ List.iter
+ (fun (node : build) ->
+ match find_jtw_tool node with
| None -> ()
- ) nodes;
+ | Some jtw_tool -> (
+ match generate_package ~sw env benv ~os_dir ~jtw_tool node with
+ | Some bl -> Hashtbl.replace jtw_results node.pkg bl
+ | None -> ()))
+ nodes;
Printf.printf " JTW: %d packages processed\n%!" (Hashtbl.length jtw_results);
(* Worker.js per solution *)
Printf.printf " JTW worker.js...\n%!";
- let worker_layers = List.filter_map (fun (_target, solution) ->
- match Day11_doc.Generate.find_compiler solution with
- | None -> None
- | Some compiler ->
- match List.find_opt (fun (c, _) ->
- OpamPackage.equal c compiler) jtw_tools with
- | None -> None
- | Some (_, jtw_tool) ->
- let solution_nodes = List.filter (fun (node : build) ->
- OpamPackage.Map.mem node.pkg solution
- ) nodes in
- match build_worker ~sw env benv ~jtw_tool ~solution_nodes with
- | Some bl -> Some (compiler, bl)
- | None -> None
- ) solutions in
+ let worker_layers =
+ List.filter_map
+ (fun (_target, solution) ->
+ match Day11_doc.Generate.find_compiler solution with
+ | None -> None
+ | Some compiler -> (
+ match
+ List.find_opt
+ (fun (c, _) -> OpamPackage.equal c compiler)
+ jtw_tools
+ with
+ | None -> None
+ | Some (_, jtw_tool) -> (
+ let solution_nodes =
+ List.filter
+ (fun (node : build) ->
+ OpamPackage.Map.mem node.pkg solution)
+ nodes
+ in
+ match build_worker ~sw env benv ~jtw_tool ~solution_nodes with
+ | Some bl -> Some (compiler, bl)
+ | None -> None)))
+ solutions
+ in
(jtw_results, worker_layers)
(** Assemble JTW output from per-package layers and worker layer.
@@ -132,58 +165,89 @@ let run ~sw env benv ~os_dir ~jtw_tools ~nodes ~solutions =
let assemble ~os_dir ~output ~jtw_results ~worker_layers ~solutions =
Bos.OS.Dir.create ~path:true (Fpath.v output) |> ignore;
(* Compiler/worker output *)
- List.iter (fun (compiler_v, worker_bl) ->
- let ocaml_ver = OpamPackage.Version.to_string
- (OpamPackage.version compiler_v) in
- let worker_dir = Fpath.(Build.dir ~os_dir worker_bl / "fs"
- / "home" / "opam" / "jtw-worker-output") in
- let worker_dir_s = Fpath.to_string worker_dir in
- if Sys.file_exists worker_dir_s then begin
- let compiler_hash = Gen.compute_compiler_content_hash worker_dir_s in
- let dst = Fpath.(v output / "compiler" / ocaml_ver / compiler_hash) in
- if not (Bos.OS.Dir.exists dst |> Result.get_ok) then begin
- Bos.OS.Dir.create ~path:true dst |> ignore;
- let worker_js = Fpath.(worker_dir / "worker.js") in
- if Bos.OS.File.exists worker_js |> Result.get_ok then
- ignore (Bos.OS.Cmd.run
- Bos.Cmd.(v "cp" % Fpath.to_string worker_js
- % Fpath.to_string Fpath.(dst / "worker.js")));
- let lib_src = Fpath.(worker_dir / "lib") in
- if Bos.OS.Dir.exists lib_src |> Result.get_ok then
- ignore (Bos.OS.Cmd.run
- Bos.Cmd.(v "cp" % "-a" % Fpath.to_string lib_src
- % Fpath.to_string Fpath.(dst / "lib")))
- end
- end
- ) worker_layers;
+ List.iter
+ (fun (compiler_v, worker_bl) ->
+ let ocaml_ver =
+ OpamPackage.Version.to_string (OpamPackage.version compiler_v)
+ in
+ let worker_dir =
+ Fpath.(
+ Build.dir ~os_dir worker_bl
+ / "fs"
+ / "home"
+ / "opam"
+ / "jtw-worker-output")
+ in
+ let worker_dir_s = Fpath.to_string worker_dir in
+ if Sys.file_exists worker_dir_s then
+ let compiler_hash = Gen.compute_compiler_content_hash worker_dir_s in
+ let dst = Fpath.(v output / "compiler" / ocaml_ver / compiler_hash) in
+ if not (Bos.OS.Dir.exists dst |> Result.get_ok) then (
+ Bos.OS.Dir.create ~path:true dst |> ignore;
+ let worker_js = Fpath.(worker_dir / "worker.js") in
+ if Bos.OS.File.exists worker_js |> Result.get_ok then
+ ignore
+ (Bos.OS.Cmd.run
+ Bos.Cmd.(
+ v "cp"
+ % Fpath.to_string worker_js
+ % Fpath.to_string Fpath.(dst / "worker.js")));
+ let lib_src = Fpath.(worker_dir / "lib") in
+ if Bos.OS.Dir.exists lib_src |> Result.get_ok then
+ ignore
+ (Bos.OS.Cmd.run
+ Bos.Cmd.(
+ v "cp"
+ % "-a"
+ % Fpath.to_string lib_src
+ % Fpath.to_string Fpath.(dst / "lib")))))
+ worker_layers;
(* Per-package output *)
- Hashtbl.iter (fun pkg bl ->
- let pkg_name = OpamPackage.name_to_string pkg in
- let pkg_version = OpamPackage.version_to_string pkg in
- let jtw_output = Fpath.(Build.dir ~os_dir bl / "fs"
- / "home" / "opam" / "jtw-output" / pkg_name / "lib") in
- let jtw_output_s = Fpath.to_string jtw_output in
- if Sys.file_exists jtw_output_s then begin
- let content_hash = Gen.compute_content_hash jtw_output_s in
- let dst = Fpath.(v output / "p" / pkg_name / pkg_version
- / content_hash / "lib") in
- if not (Bos.OS.Dir.exists dst |> Result.get_ok) then begin
- Bos.OS.Dir.create ~path:true dst |> ignore;
- ignore (Bos.OS.Cmd.run
- Bos.Cmd.(v "cp" % "-a" % "--no-target-directory"
- % jtw_output_s % Fpath.to_string dst))
- end
- end
- ) jtw_results;
+ Hashtbl.iter
+ (fun pkg bl ->
+ let pkg_name = OpamPackage.name_to_string pkg in
+ let pkg_version = OpamPackage.version_to_string pkg in
+ let jtw_output =
+ Fpath.(
+ Build.dir ~os_dir bl
+ / "fs"
+ / "home"
+ / "opam"
+ / "jtw-output"
+ / pkg_name
+ / "lib")
+ in
+ let jtw_output_s = Fpath.to_string jtw_output in
+ if Sys.file_exists jtw_output_s then
+ let content_hash = Gen.compute_content_hash jtw_output_s in
+ let dst =
+ Fpath.(v output / "p" / pkg_name / pkg_version / content_hash / "lib")
+ in
+ if not (Bos.OS.Dir.exists dst |> Result.get_ok) then (
+ Bos.OS.Dir.create ~path:true dst |> ignore;
+ ignore
+ (Bos.OS.Cmd.run
+ Bos.Cmd.(
+ v "cp"
+ % "-a"
+ % "--no-target-directory"
+ % jtw_output_s
+ % Fpath.to_string dst))))
+ jtw_results;
(* Universe findlib indexes *)
- List.iter (fun (_target, solution) ->
- let build_hashes = OpamPackage.Map.fold (fun _pkg _deps acc ->
- (* We'd need the build hash from the node — for now use package string *)
- acc
- ) solution [] in
- let universe = Day11_layer.Hash.of_strings
- (List.sort String.compare build_hashes) in
- let u_dir = Fpath.(v output / "u" / universe) in
- Bos.OS.Dir.create ~path:true u_dir |> ignore
- ) solutions;
+ List.iter
+ (fun (_target, solution) ->
+ let build_hashes =
+ OpamPackage.Map.fold
+ (fun _pkg _deps acc ->
+ (* We'd need the build hash from the node — for now use package string *)
+ acc)
+ solution []
+ in
+ let universe =
+ Day11_layer.Hash.of_strings (List.sort String.compare build_hashes)
+ in
+ let u_dir = Fpath.(v output / "u" / universe) in
+ Bos.OS.Dir.create ~path:true u_dir |> ignore)
+ solutions;
Printf.printf " JTW output assembled in %s\n%!" output
File "day11/lib/test/test_lib.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/lib/test/test_lib.ml b/_build/default/day11/lib/test/.formatted/test_lib.ml
index 00d08cf..10f60d4 100644
--- a/_build/default/day11/lib/test/test_lib.ml
+++ b/_build/default/day11/lib/test/.formatted/test_lib.ml
@@ -26,9 +26,13 @@ let test_classify_build_failure () =
Alcotest.(check (option string)) "no specific error" None error
let test_extract_compiler () =
- let json = `Assoc [
- ("deps", `List [ `String "ocaml-base-compiler.5.1.0"; `String "dune.3.0" ])
- ] in
+ let json =
+ `Assoc
+ [
+ ( "deps",
+ `List [ `String "ocaml-base-compiler.5.1.0"; `String "dune.3.0" ] );
+ ]
+ in
let v = Classify.extract_compiler_from_deps json in
Alcotest.(check string) "compiler version" "5.1.0" v
@@ -38,74 +42,111 @@ let test_extract_compiler_missing () =
Alcotest.(check string) "no compiler" "" v
let test_matches_any () =
- Alcotest.(check bool) "match"
- true (Classify.matches_any [ "foo"; "bar" ] "contains FOO here");
- Alcotest.(check bool) "no match"
- false (Classify.matches_any [ "foo"; "bar" ] "contains baz")
+ Alcotest.(check bool)
+ "match" true
+ (Classify.matches_any [ "foo"; "bar" ] "contains FOO here");
+ Alcotest.(check bool)
+ "no match" false
+ (Classify.matches_any [ "foo"; "bar" ] "contains baz")
(* ── Universe_manifest tests ─────────────────────────────────────── *)
-let test_universe_manifest_roundtrip () = with_tmp_dir @@ fun dir ->
- let universes = [
- ("u-aaa", [ "astring.0.8.5"; "fmt.0.9.0" ]);
- ("u-bbb", [ "dune.3.0" ]);
- ] in
+let test_universe_manifest_roundtrip () =
+ with_tmp_dir @@ fun dir ->
+ let universes =
+ [ ("u-aaa", [ "astring.0.8.5"; "fmt.0.9.0" ]); ("u-bbb", [ "dune.3.0" ]) ]
+ in
(match Universe_manifest.write_all ~snapshot_dir:dir universes with
- | Ok () -> () | Error (`Msg m) -> Alcotest.fail m);
+ | Ok () -> ()
+ | Error (`Msg m) -> Alcotest.fail m);
let idx =
- List.sort compare (Universe_manifest.read_index ~snapshot_dir:dir) in
+ List.sort compare (Universe_manifest.read_index ~snapshot_dir:dir)
+ in
Alcotest.(check (list string)) "index" [ "u-aaa"; "u-bbb" ] idx;
- (match Universe_manifest.read_manifest ~snapshot_dir:dir ~hash:"u-aaa" with
- | Some m ->
- Alcotest.(check string) "hash" "u-aaa" m.hash;
- Alcotest.(check (list string)) "packages"
- [ "astring.0.8.5"; "fmt.0.9.0" ] m.packages
- | None -> Alcotest.fail "manifest u-aaa missing")
-
-let test_universe_manifest_missing () = with_tmp_dir @@ fun dir ->
- Alcotest.(check (list string)) "empty index" []
+ match Universe_manifest.read_manifest ~snapshot_dir:dir ~hash:"u-aaa" with
+ | Some m ->
+ Alcotest.(check string) "hash" "u-aaa" m.hash;
+ Alcotest.(check (list string))
+ "packages"
+ [ "astring.0.8.5"; "fmt.0.9.0" ]
+ m.packages
+ | None -> Alcotest.fail "manifest u-aaa missing"
+
+let test_universe_manifest_missing () =
+ with_tmp_dir @@ fun dir ->
+ Alcotest.(check (list string))
+ "empty index" []
(Universe_manifest.read_index ~snapshot_dir:dir);
- Alcotest.(check bool) "missing manifest" true
+ Alcotest.(check bool)
+ "missing manifest" true
(Universe_manifest.read_manifest ~snapshot_dir:dir ~hash:"nope" = None)
(* ── Dag_marshal universe tests ──────────────────────────────────── *)
-let test_dag_marshal_universe_roundtrip () = with_tmp_dir @@ fun dir ->
- let entries = [
- { Dag_marshal.hash = "h1"; pkg = OpamPackage.of_string "astring.0.8.5";
- kind = Build; deps = []; universe = "u-aaa"; blessed = false };
- { Dag_marshal.hash = "h2"; pkg = OpamPackage.of_string "fmt.0.9.0";
- kind = Compile; deps = [ "h1" ]; universe = "u-bbb"; blessed = true };
- ] in
+let test_dag_marshal_universe_roundtrip () =
+ with_tmp_dir @@ fun dir ->
+ let entries =
+ [
+ {
+ Dag_marshal.hash = "h1";
+ pkg = OpamPackage.of_string "astring.0.8.5";
+ kind = Build;
+ deps = [];
+ universe = "u-aaa";
+ blessed = false;
+ };
+ {
+ Dag_marshal.hash = "h2";
+ pkg = OpamPackage.of_string "fmt.0.9.0";
+ kind = Compile;
+ deps = [ "h1" ];
+ universe = "u-bbb";
+ blessed = true;
+ };
+ ]
+ in
(match Dag_marshal.write ~snapshot_dir:dir entries with
- | Ok () -> () | Error (`Msg m) -> Alcotest.fail m);
- (match Dag_marshal.read ~snapshot_dir:dir with
- | Ok [ e1; e2 ] ->
- Alcotest.(check string) "u1" "u-aaa" e1.universe;
- Alcotest.(check string) "u2" "u-bbb" e2.universe
- | Ok _ -> Alcotest.fail "wrong entry count"
- | Error (`Msg m) -> Alcotest.fail m)
-
-let test_dag_marshal_universe_default () = with_tmp_dir @@ fun dir ->
+ | Ok () -> ()
+ | Error (`Msg m) -> Alcotest.fail m);
+ match Dag_marshal.read ~snapshot_dir:dir with
+ | Ok [ e1; e2 ] ->
+ Alcotest.(check string) "u1" "u-aaa" e1.universe;
+ Alcotest.(check string) "u2" "u-bbb" e2.universe
+ | Ok _ -> Alcotest.fail "wrong entry count"
+ | Error (`Msg m) -> Alcotest.fail m
+
+let test_dag_marshal_universe_default () =
+ with_tmp_dir @@ fun dir ->
(* A dag.json written before the universe field existed reads as "". *)
let json =
{|{"version":1,"nodes":[{"hash":"h1","pkg":"astring.0.8.5",|}
- ^ {|"kind":"build","deps":[]}]}|} in
+ ^ {|"kind":"build","deps":[]}]}|}
+ in
(match Bos.OS.File.write (Dag_marshal.path dir) json with
- | Ok () -> () | Error (`Msg m) -> Alcotest.fail m);
- (match Dag_marshal.read ~snapshot_dir:dir with
- | Ok [ e ] -> Alcotest.(check string) "default universe" "" e.universe
- | _ -> Alcotest.fail "read failed")
+ | Ok () -> ()
+ | Error (`Msg m) -> Alcotest.fail m);
+ match Dag_marshal.read ~snapshot_dir:dir with
+ | Ok [ e ] -> Alcotest.(check string) "default universe" "" e.universe
+ | _ -> Alcotest.fail "read failed"
(* ── History tests ───────────────────────────────────────────────── *)
let make_entry ?(status = "success") ?(category = "build") pkg =
- { History.ts = "2024-01-01T00:00:00Z"; run = "run1";
- build_hash = "build-abc"; status; category;
- blessed = false; error = None }
- |> fun e -> ignore pkg; e
-
-let test_history_append_read () = with_tmp_dir @@ fun dir ->
+ {
+ History.ts = "2024-01-01T00:00:00Z";
+ run = "run1";
+ build_hash = "build-abc";
+ status;
+ category;
+ blessed = false;
+ error = None;
+ }
+ |> fun e ->
+ ignore pkg;
+ e
+
+let test_history_append_read () =
+ with_tmp_dir @@ fun dir ->
let packages_dir = dir in
let entry = make_entry "astring.0.8.5" in
History.append ~packages_dir ~pkg_str:"astring.0.8.5" entry;
@@ -113,7 +154,8 @@ let test_history_append_read () = with_tmp_dir @@ fun dir ->
Alcotest.(check int) "one entry" 1 (List.length entries);
Alcotest.(check string) "status" "success" (List.hd entries).status
-let test_history_multiple () = with_tmp_dir @@ fun dir ->
+let test_history_multiple () =
+ with_tmp_dir @@ fun dir ->
let packages_dir = dir in
let e1 = make_entry ~status:"success" "x.1" in
let e2 = make_entry ~status:"failure" ~category:"build_failure" "x.1" in
@@ -122,22 +164,29 @@ let test_history_multiple () = with_tmp_dir @@ fun dir ->
let entries = History.read ~packages_dir ~pkg_str:"x.1" in
Alcotest.(check int) "two entries" 2 (List.length entries)
-let test_history_empty () = with_tmp_dir @@ fun dir ->
- let entries = History.read
- ~packages_dir:dir ~pkg_str:"nonexistent.1" in
+let test_history_empty () =
+ with_tmp_dir @@ fun dir ->
+ let entries = History.read ~packages_dir:dir ~pkg_str:"nonexistent.1" in
Alcotest.(check int) "empty" 0 (List.length entries)
(* Two fibers append concurrently to the same history.jsonl.
The per-path Eio.Mutex must serialise them so every entry ends up
on its own line (no interleaved bytes) and no write is lost. *)
-let test_history_concurrent_append () = with_tmp_dir @@ fun dir ->
+let test_history_concurrent_append () =
+ with_tmp_dir @@ fun dir ->
let packages_dir = dir in
let pkg = "astring.0.8.5" in
let n = 50 in
let entry_for i =
- { History.ts = "2024-01-01T00:00:00Z"; run = Pritf.sprintf "r%d" i;
- build_hash = Printf.sprintf "h%d" i; status = "success";
- category = "build"; blessed = false; error = None }
+ {
+ History.ts = "2024-01-01T00:00:00Z";
+ run = Printf.sprintf "r%d" i;
+ build_hash = Printf.sprintf "h%d" i;
+ status = "success";
+ category = "build";
+ blessed = false;
+ error = None;
+ }
in
Eio.Fiber.both
(fun () ->
@@ -152,10 +201,13 @@ let test_history_concurrent_append () = with_tmp_dir @@ fun dir ->
done);
let entries = History.read ~packages_dir ~pkg_str:pkg in
Alcotest.(check int) "all entries written" (2 * n) (List.length entries);
- let hashes = List.map (fun (e : History.entry) -> e.build_hash) entries
- |> List.sort compare in
- let expected = List.init (2 * n)
- (fun i -> Printf.sprintf "h%d" i) |> List.sort compare in
+ let hashes =
+ List.map (fun (e : History.entry) -> e.build_hash) entries
+ |> List.sort compare
+ in
+ let expected =
+ List.init (2 * n) (fun i -> Printf.sprintf "h%d" i) |> List.sort compare
+ in
Alcotest.(check (list string)) "no interleaving or loss" expected hashes
let test_history_json_roundtrip () =
@@ -170,27 +222,30 @@ let test_history_json_roundtrip () =
(* ── Progress tests ──────────────────────────────────────────────── *)
let test_progress_create () =
- let p = Progress.create ~run_id:"run1"
- ~start_time:"2024-01-01" ~targets:[ "astring" ] in
+ let p =
+ Progress.create ~run_id:"run1" ~start_time:"2024-01-01"
+ ~targets:[ "astring" ]
+ in
let json = Progress.to_json p in
- Alcotest.(check bool) "has run_id"
- true (Yojson.Safe.to_string json |> fun s ->
- Astring.String.is_infix ~affix:"run1" s)
+ Alcotest.(check bool)
+ "has run_id" true
+ ( Yojson.Safe.to_string json |> fun s ->
+ Astring.String.is_infix ~affix:"run1" s )
let test_progress_phases () =
- let p = Progress.create ~run_id:"r1"
- ~start_time:"t" ~targets:[] in
+ let p = Progress.create ~run_id:"r1" ~start_time:"t" ~targets:[] in
let p = Progress.set_phase p Progress.Building in
let json = Progress.to_json p in
- Alcotest.(check bool) "has building"
- true (Yojson.Safe.to_string json |> fun s ->
- Astring.String.is_infix ~affix:"building" s
- || Astring.String.is_infix ~affix:"Building" s)
-
-let test_progress_write_delete () = with_tmp_dir @@ fun dir ->
+ Alcotest.(check bool)
+ "has building" true
+ ( Yojson.Safe.to_string json |> fun s ->
+ Astring.String.is_infix ~affix:"building" s
+ || Astring.String.is_infix ~affix:"Building" s )
+
+let test_progress_write_delete () =
+ with_tmp_dir @@ fun dir ->
let run_dir = Fpath.to_string dir in
- let p = Progress.create ~run_id:"r1"
- ~start_time:"t" ~targets:[] in
+ let p = Progress.create ~run_id:"r1" ~start_time:"t" ~targets:[] in
Progress.write ~run_dir p;
let exists = Sys.file_exists (Filename.concat run_dir "progress.json") in
Alcotest.(check bool) "written" true exists;
@@ -217,34 +272,40 @@ let test_notify_stdout () =
(* ── Build_lock tests ────────────────────────────────────────────── *)
-let test_lock_empty () = with_tmp_dir @@ fun dir ->
+let test_lock_empty () =
+ with_tmp_dir @@ fun dir ->
mkdir Fpath.(dir / "locks");
- let locks = Build_lock.list_active
- ~cache_dir:(Fpath.to_string dir) in
+ let locks = Build_lock.list_active ~cache_dir:(Fpath.to_string dir) in
Alcotest.(check int) "no locks" 0 (List.length locks)
(* ── Epoch tests ─────────────────────────────────────────────────── *)
-let test_epoch_create () = with_tmp_dir @@ fun dir ->
+let test_epoch_create () =
+ with_tmp_dir @@ fun dir ->
let epoch = Epoch.create ~base_dir:dir "abc123" in
- Alcotest.(check bool) "epoch dir exists"
- true (Bos.OS.Dir.exists epoch.dir |> Result.get_ok);
+ Alcotest.(check bool)
+ "epoch dir exists" true
+ (Bos.OS.Dir.exists epoch.dir |> Result.get_ok);
Alcotest.(check string) "hash" "abc123" epoch.hash
-let test_epoch_promote () = with_tmp_dir @@ fun dir ->
+let test_epoch_promote () =
+ with_tmp_dir @@ fun dir ->
let epoch = Epoch.create ~base_dir:dir "abc123" in
Epoch.promote ~base_dir:dir epoch;
let link_path = Fpath.(dir / "html-live") in
let target = Unix.readlink (Fpath.to_string link_path) in
- Alcotest.(check bool) "symlink target contains epoch hash"
- true (Astring.String.is_infix ~affix:"abc123" target);
+ Alcotest.(check bool)
+ "symlink target contains epoch hash" true
+ (Astring.String.is_infix ~affix:"abc123" target);
(* Target must be relative so it resolves under any mount point
(the daemon's HOME vs. Caddy's /srv). *)
- Alcotest.(check bool) "symlink target is relative"
- true (Filename.is_relative target);
+ Alcotest.(check bool)
+ "symlink target is relative" true
+ (Filename.is_relative target);
Alcotest.(check string) "symlink target" "epoch-abc123/html" target
-let test_epoch_current () = with_tmp_dir @@ fun dir ->
+let test_epoch_current () =
+ with_tmp_dir @@ fun dir ->
(* No epoch yet *)
let none = Epoch.current ~base_dir:dir in
Alcotest.(check bool) "no current epoch" true (none = None);
@@ -252,11 +313,12 @@ let test_epoch_current () = with_tmp_dir @@ fun dir ->
let epoch = Epoch.create ~base_dir:dir "def456" in
Epoch.promote ~base_dir:dir epoch;
let cur = Epoch.current ~base_dir:dir in
- (match cur with
- | Some e -> Alcotest.(check string) "current hash" "def456" e.hash
- | None -> Alcotest.fail "expected Some epoch")
+ match cur with
+ | Some e -> Alcotest.(check string) "current hash" "def456" e.hash
+ | None -> Alcotest.fail "expected Some epoch"
-let test_epoch_gc () = with_tmp_dir @@ fun dir ->
+let test_epoch_gc () =
+ with_tmp_dir @@ fun dir ->
(* Create several epochs *)
let _e1 = Epoch.create ~base_dir:dir "aaa" in
let _e2 = Epoch.create ~base_dir:dir "bbb" in
@@ -267,74 +329,87 @@ let test_epoch_gc () = with_tmp_dir @@ fun dir ->
(* gc must never delete the currently-live epoch, even when it's not
among the [keep] most-recent — e.g. a deliberate rollback-promote. *)
-let test_epoch_gc_keeps_live () = with_tmp_dir @@ fun dir ->
+let test_epoch_gc_keeps_live () =
+ with_tmp_dir @@ fun dir ->
let e1 = Epoch.create ~base_dir:dir "aaa" in
let _e2 = Epoch.create ~base_dir:dir "bbb" in
let _e3 = Epoch.create ~base_dir:dir "ccc" in
- Epoch.promote ~base_dir:dir e1; (* make the oldest live *)
+ Epoch.promote ~base_dir:dir e1;
+ (* make the oldest live *)
let _ = Epoch.gc ~base_dir:dir ~keep:1 in
- Alcotest.(check bool) "live (oldest) epoch survived gc"
- true (Bos.OS.Dir.exists e1.dir |> Result.get_ok);
- Alcotest.(check bool) "current still resolves to the live epoch"
- true (match Epoch.current ~base_dir:dir with
- | Some e -> e.hash = "aaa" | None -> false)
+ Alcotest.(check bool)
+ "live (oldest) epoch survived gc" true
+ (Bos.OS.Dir.exists e1.dir |> Result.get_ok);
+ Alcotest.(check bool)
+ "current still resolves to the live epoch" true
+ (match Epoch.current ~base_dir:dir with
+ | Some e -> e.hash = "aaa"
+ | None -> false)
(* ── Build_config tests ─────────────────────────────────────────── *)
-let test_build_config_roundtrip () = with_tmp_dir @@ fun dir ->
+let test_build_config_roundtrip () =
+ with_tmp_dir @@ fun dir ->
let path = Fpath.(dir / "build-config.json") in
- let config : Build_config.t = {
- opam_repositories = [ Fpath.v "/tmp/opam-repository" ];
- local_repos = [ (Fpath.v "/tmp/my-repo", [ "pkg1"; "pkg2" ]) ];
- with_doc = true;
- with_jtw = false;
- html_output = Some (Fpath.v "/tmp/html");
- jtw_output = None;
- } in
+ let config : Build_config.t =
+ {
+ opam_repositories = [ Fpath.v "/tmp/opam-repository" ];
+ local_repos = [ (Fpath.v "/tmp/my-repo", [ "pkg1"; "pkg2" ]) ];
+ with_doc = true;
+ with_jtw = false;
+ html_output = Some (Fpath.v "/tmp/html");
+ jtw_output = None;
+ }
+ in
Build_config.save path config |> ok_or_fail "save";
let loaded = Build_config.load path |> ok_or_fail "load" in
Alcotest.(check bool) "with_doc" true loaded.with_doc;
Alcotest.(check bool) "with_jtw" false loaded.with_jtw;
- Alcotest.(check (option string)) "html_output"
- (Some "/tmp/html")
+ Alcotest.(check (option string))
+ "html_output" (Some "/tmp/html")
(Option.map Fpath.to_string loaded.html_output);
- Alcotest.(check (option string)) "jtw_output"
- None
+ Alcotest.(check (option string))
+ "jtw_output" None
(Option.map Fpath.to_string loaded.jtw_output)
-let test_build_config_load_missing () = with_tmp_dir @@ fun dir ->
+let test_build_config_load_missing () =
+ with_tmp_dir @@ fun dir ->
let path = Fpath.(dir / "nonexistent.json") in
let result = Build_config.load path in
Alcotest.(check bool) "load fails" true (Result.is_error result)
(* ── Package_list tests ─────────────────────────────────────────── *)
-let test_package_list_roundtrip () = with_tmp_dir @@ fun dir ->
+let test_package_list_roundtrip () =
+ with_tmp_dir @@ fun dir ->
let path = Fpath.(dir / "packages.json") in
let packages = [ "astring.0.8.5"; "fmt.0.9.0"; "yojson.2.2.2" ] in
Package_list.save path packages |> ok_or_fail "save";
let loaded = Package_list.load path |> ok_or_fail "load" in
Alcotest.(check (list string)) "roundtrip" packages loaded
-let test_package_list_generate () = with_tmp_dir @@ fun dir ->
+let test_package_list_generate () =
+ with_tmp_dir @@ fun dir ->
let packages_dir = dir in
(* Create history entries: one success, one failure *)
let success_entry = make_entry ~status:"success" "astring.0.8.5" in
let failure_entry =
- make_entry ~status:"failure" ~category:"build_failure" "broken.1.0" in
+ make_entry ~status:"failure" ~category:"build_failure" "broken.1.0"
+ in
History.append ~packages_dir ~pkg_str:"astring.0.8.5" success_entry;
History.append ~packages_dir ~pkg_str:"broken.1.0" failure_entry;
let generated = Package_list.generate ~packages_dir in
(* The successful package should appear in the list *)
- Alcotest.(check bool) "has successful pkg"
- true (List.mem "astring.0.8.5" generated);
+ Alcotest.(check bool)
+ "has successful pkg" true
+ (List.mem "astring.0.8.5" generated);
(* The failed package should not appear *)
- Alcotest.(check bool) "no failed pkg"
- false (List.mem "broken.1.0" generated)
+ Alcotest.(check bool) "no failed pkg" false (List.mem "broken.1.0" generated)
(* ── Disk_usage tests ───────────────────────────────────────────── *)
-let test_disk_usage_empty () = with_tmp_dir @@ fun dir ->
+let test_disk_usage_empty () =
+ with_tmp_dir @@ fun dir ->
let os_dir = Fpath.(dir / "os") in
let cache_dir = Fpath.(dir / "cache") in
mkdir os_dir;
@@ -351,35 +426,45 @@ let test_disk_usage_empty () = with_tmp_dir @@ fun dir ->
let mkdir path =
ignore (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote path)))
-let test_gc_build_layers () = with_tmp_dir @@ fun dir ->
+let test_gc_build_layers () =
+ with_tmp_dir @@ fun dir ->
let os_dir = Fpath.to_string dir in
mkdir (Filename.concat os_dir "build-aaa111aaa111");
mkdir (Filename.concat os_dir "build-bbb222bbb222");
mkdir (Filename.concat os_dir "build-ccc333ccc333");
(* Also a non-build dir that should be ignored *)
mkdir (Filename.concat os_dir "packages");
- let result = Gc.gc_build_layers ~os_dir ~referenced:["build-aaa111aaa111"] in
+ let result =
+ Gc.gc_build_layers ~os_dir ~referenced:[ "build-aaa111aaa111" ]
+ in
Alcotest.(check int) "total" 3 result.total;
Alcotest.(check int) "kept" 1 result.kept;
Alcotest.(check int) "deleted" 2 result.deleted;
- Alcotest.(check bool) "referenced kept"
- true (Sys.file_exists (Filename.concat os_dir "build-aaa111aaa111"));
- Alcotest.(check bool) "unreferenced deleted"
- false (Sys.file_exists (Filename.concat os_dir "build-bbb222bbb222"));
+ Alcotest.(check bool)
+ "referenced kept" true
+ (Sys.file_exists (Filename.concat os_dir "build-aaa111aaa111"));
+ Alcotest.(check bool)
+ "unreferenced deleted" false
+ (Sys.file_exists (Filename.concat os_dir "build-bbb222bbb222"));
(* Non-build dir untouched *)
- Alcotest.(check bool) "packages untouched"
- true (Sys.file_exists (Filename.concat os_dir "packages"))
+ Alcotest.(check bool)
+ "packages untouched" true
+ (Sys.file_exists (Filename.concat os_dir "packages"))
-let test_gc_build_layers_keeps () = with_tmp_dir @@ fun dir ->
+let test_gc_build_layers_keeps () =
+ with_tmp_dir @@ fun dir ->
let os_dir = Fpath.to_string dir in
mkdir (Filename.concat os_dir "build-aaa111aaa111");
mkdir (Filename.concat os_dir "build-bbb222bbb222");
- let result = Gc.gc_build_layers ~os_dir
- ~referenced:["build-aaa111aaa111"; "build-bbb222bbb222"] in
+ let result =
+ Gc.gc_build_layers ~os_dir
+ ~referenced:[ "build-aaa111aaa111"; "build-bbb222bbb222" ]
+ in
Alcotest.(check int) "none deleted" 0 result.deleted;
Alcotest.(check int) "all kept" 2 result.kept
-let test_gc_odoc_store () = with_tmp_dir @@ fun dir ->
+let test_gc_odoc_store () =
+ with_tmp_dir @@ fun dir ->
let os_dir = Fpath.to_string dir in
(* Set up store with p/ (always kept) and u/ entries *)
mkdir (Filename.concat os_dir "odoc-store/odoc-out/p/fmt/0.11.0");
@@ -387,16 +472,19 @@ let test_gc_odoc_store () = with_tmp_dir @@ fun dir ->
mkdir (Filename.concat os_dir "odoc-store/odoc-out/u/bbb222/fmt/0.11.0");
mkdir (Filename.concat os_dir "odoc-store/html/u/aaa111/fmt/0.11.0");
mkdir (Filename.concat os_dir "odoc-store/html/u/bbb222/fmt/0.11.0");
- let result = Gc.gc_odoc_store ~os_dir ~referenced_universes:["aaa111"] in
+ let result = Gc.gc_odoc_store ~os_dir ~referenced_universes:[ "aaa111" ] in
(* bbb222 deleted from both odoc-out and html *)
Alcotest.(check int) "deleted" 2 result.deleted;
- Alcotest.(check bool) "kept referenced"
- true (Sys.file_exists (Filename.concat os_dir "odoc-store/odoc-out/u/aaa111"));
- Alcotest.(check bool) "deleted unreferenced"
- false (Sys.file_exists (Filename.concat os_dir "odoc-store/odoc-out/u/bbb222"));
+ Alcotest.(check bool)
+ "kept referenced" true
+ (Sys.file_exists (Filename.concat os_dir "odoc-store/odoc-out/u/aaa111"));
+ Alcotest.(check bool)
+ "deleted unreferenced" false
+ (Sys.file_exists (Filename.concat os_dir "odoc-store/odoc-out/u/bbb222"));
(* p/ untouched *)
- Alcotest.(check bool) "p/ untouched"
- true (Sys.file_exists (Filename.concat os_dir "odoc-store/odoc-out/p/fmt"))
+ Alcotest.(check bool)
+ "p/ untouched" true
+ (Sys.file_exists (Filename.concat os_dir "odoc-store/odoc-out/p/fmt"))
(* Wrap all tests in Eio_main.run so History.append's Eio.Mutex can
block cooperatively. Tests that don't touch Eio primitives are
@@ -417,8 +505,7 @@ let () =
] );
( "Universe_manifest",
[
- Alcotest.test_case "roundtrip" `Quick
- test_universe_manifest_roundtrip;
+ Alcotest.test_case "roundtrip" `Quick test_universe_manifest_roundtrip;
Alcotest.test_case "missing" `Quick test_universe_manifest_missing;
] );
( "Dag_marshal",
@@ -434,8 +521,8 @@ let () =
Alcotest.test_case "multiple" `Quick test_history_multiple;
Alcotest.test_case "empty" `Quick test_history_empty;
Alcotest.test_case "json roundtrip" `Quick test_history_json_roundtrip;
- Alcotest.test_case "concurrent append (Eio mutex)"
- `Quick test_history_concurrent_append;
+ Alcotest.test_case "concurrent append (Eio mutex)" `Quick
+ test_history_concurrent_append;
] );
( "Progress",
[
@@ -449,10 +536,7 @@ let () =
test_notify_channel_roundtrip;
Alcotest.test_case "stdout" `Quick test_notify_stdout;
] );
- ( "Build_lock",
- [
- Alcotest.test_case "empty" `Quick test_lock_empty;
- ] );
+ ("Build_lock", [ Alcotest.test_case "empty" `Quick test_lock_empty ]);
( "Epoch",
[
Alcotest.test_case "create" `Quick test_epoch_create;
@@ -476,9 +560,7 @@ let () =
test_package_list_generate;
] );
( "Disk_usage",
- [
- Alcotest.test_case "scan empty dirs" `Quick test_disk_usage_empty;
- ] );
+ [ Alcotest.test_case "scan empty dirs" `Quick test_disk_usage_empty ] );
( "Gc",
[
Alcotest.test_case "build layers" `Quick test_gc_build_layers;
File "src/lib/day11_prep.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/day11_prep.ml b/_build/default/src/lib/.formatted/day11_prep.ml
index ca5a9f7..1486c16 100644
--- a/_build/default/src/lib/day11_prep.ml
+++ b/_build/default/src/lib/.formatted/day11_prep.ml
@@ -1,18 +1,18 @@
(** Day11-based build/doc nodes for the OCurrent pipeline.
- Each DAG node (build, tool, compile, link, doc-all) becomes an
- OCurrent component with its own job log, visible in the web UI.
+ Each DAG node (build, tool, compile, link, doc-all) becomes an OCurrent
+ component with its own job log, visible in the web UI.
- Uses Current_cache for job tracking but delegates all actual
- caching to day11's content-addressed layer store. *)
+ Uses Current_cache for job tracking but delegates all actual caching to
+ day11's content-addressed layer store. *)
type t = {
pkg : OpamPackage.t;
build_hash : string;
layer_dir : Fpath.t;
all_layer_dirs : Fpath.t list;
- (** This layer's dir plus all transitive dep layer dirs.
- Used by parent builds to stack the full dep tree via overlayfs. *)
+ (** This layer's dir plus all transitive dep layer dirs. Used by parent
+ builds to stack the full dep tree via overlayfs. *)
}
let pkg t = t.pkg
@@ -40,7 +40,9 @@ let compare a b = String.compare a.build_hash b.build_hash
(* Per-kind Op modules so job filenames include the node kind
(e.g. "day11-build-XXXXXX.log" instead of "day11-node-XXXXXX.log"). *)
-module type LABEL = sig val label : string end
+module type LABEL = sig
+ val label : string
+end
module Make_op (L : LABEL) = struct
type t = {
@@ -50,26 +52,20 @@ module Make_op (L : LABEL) = struct
env : Eio_unix.Stdenv.base;
pool : unit Current.Pool.t;
profile_name : string;
- (* Tag job logs with the profile that scheduled the run. A
+ (* Tag job logs with the profile that scheduled the run. A
shared layer hash can be scheduled from more than one
profile; the last writer wins here, which is fine for
log-line attribution. *)
}
module Key = struct
- type t = {
- hash : string;
- pkg : OpamPackage.t;
- }
+ type t = { hash : string; pkg : OpamPackage.t }
+
let digest t = t.hash
end
module Value = struct
- type t = {
- pkg : string;
- hash : string;
- layer_dir : string;
- }
+ type t = { pkg : string; hash : string; layer_dir : string }
[@@deriving yojson]
let marshal t = Yojson.Safe.to_string (to_yojson t)
@@ -87,96 +83,122 @@ module Make_op (L : LABEL) = struct
OCurrent "New job:" line and the /jobs dashboard, not just in the
job's body log. *)
let pp f (key : Key.t) =
- Fmt.pf f "%s %s (%s)" label (OpamPackage.to_string key.pkg)
+ Fmt.pf f "%s %s (%s)" label
+ (OpamPackage.to_string key.pkg)
(short_hash key.hash)
let auto_cancel = false
let build (ctx : t) job (key : Key.t) =
let open Lwt.Syntax in
- let* () = Current.Job.start job ~pool:ctx.pool ~level:Current.Level.Average in
- Current.Job.log job "[profile %s] %s %s" ctx.profile_name
- label (OpamPackage.to_string key.pkg);
+ let* () =
+ Current.Job.start job ~pool:ctx.pool ~level:Current.Level.Average
+ in
+ Current.Job.log job "[profile %s] %s %s" ctx.profile_name label
+ (OpamPackage.to_string key.pkg);
let layer = Day11_layer.Layer.of_hash ~os_dir:ctx.os_dir key.hash in
Lwt_eio.run_eio @@ fun () ->
- let cached_ok = match Day11_layer.Meta.load ctx.env (Day11_layer.Layer.meta_path layer) with
+ let cached_ok =
+ match
+ Day11_layer.Meta.load ctx.env (Day11_layer.Layer.meta_path layer)
+ with
| Ok meta when meta.exit_status = 0 -> true
| Ok _ ->
- Current.Job.log job "Clearing failed layer %s" key.hash;
- ignore (Bos.OS.Dir.delete ~recurse:true (Day11_layer.Layer.dir layer));
- false
+ Current.Job.log job "Clearing failed layer %s" key.hash;
+ ignore (Bos.OS.Dir.delete ~recurse:true (Day11_layer.Layer.dir layer));
+ false
| Error _ -> false
in
- if cached_ok then begin
+ if cached_ok then (
(* Hits are high-volume on large profiles — debug level keeps
the default log focused on genuine work. Bump via
[--verbosity debug] to see them. *)
- Log.debug (fun f -> f "[%s] cache hit: %s %s %s"
- ctx.profile_name label
- (OpamPackage.to_string key.pkg)
- (short_hash key.hash));
+ Log.debug (fun f ->
+ f "[%s] cache hit: %s %s %s" ctx.profile_name label
+ (OpamPackage.to_string key.pkg)
+ (short_hash key.hash));
Current.Job.log job "Cached: %s %s (%s)" label
(OpamPackage.to_string key.pkg)
(short_hash key.hash);
- Ok Value.{
- pkg = OpamPackage.to_string key.pkg;
- hash = key.hash;
- layer_dir = Fpath.to_string (Day11_layer.Layer.dir layer);
- }
- end else begin
- Log.info (fun f -> f "[%s] cache miss: %s %s %s"
- ctx.profile_name label
- (OpamPackage.to_string key.pkg)
- (short_hash key.hash));
+ Ok
+ Value.
+ {
+ pkg = OpamPackage.to_string key.pkg;
+ hash = key.hash;
+ layer_dir = Fpath.to_string (Day11_layer.Layer.dir layer);
+ })
+ else (
+ Log.info (fun f ->
+ f "[%s] cache miss: %s %s %s" ctx.profile_name label
+ (OpamPackage.to_string key.pkg)
+ (short_hash key.hash));
Current.Job.log job "%s %s (%s)" label
(OpamPackage.to_string key.pkg)
(short_hash key.hash);
let success = ctx.dispatch ctx.env ctx.dag_node in
(match Bos.OS.File.read (Day11_layer.Layer.log_path layer) with
- | Ok contents -> Current.Job.write job contents
- | Error _ -> ());
- if success then begin
- (match Day11_layer.Meta.load ctx.env (Day11_layer.Layer.meta_path layer) with
- | Ok meta ->
- let tf name = Day11_layer.Meta.timing_field name meta.timing in
- Current.Job.log job "OK: %s %s (runc: %.1fs, disk: %dKB)"
- label (OpamPackage.to_string key.pkg)
- (tf "runc_run") (meta.disk_usage / 1024)
- | Error _ ->
- Current.Job.log job "OK: %s %s" label
- (OpamPackage.to_string key.pkg));
- Ok Value.{
- pkg = OpamPackage.to_string key.pkg;
- hash = key.hash;
- layer_dir = Fpath.to_string (Day11_layer.Layer.dir layer);
- }
- end else begin
+ | Ok contents -> Current.Job.write job contents
+ | Error _ -> ());
+ if success then (
+ (match
+ Day11_layer.Meta.load ctx.env (Day11_layer.Layer.meta_path layer)
+ with
+ | Ok meta ->
+ let tf name = Day11_layer.Meta.timing_field name meta.timing in
+ Current.Job.log job "OK: %s %s (runc: %.1fs, disk: %dKB)" label
+ (OpamPackage.to_string key.pkg)
+ (tf "runc_run") (meta.disk_usage / 1024)
+ | Error _ ->
+ Current.Job.log job "OK: %s %s" label
+ (OpamPackage.to_string key.pkg));
+ Ok
+ Value.
+ {
+ pkg = OpamPackage.to_string key.pkg;
+ hash = key.hash;
+ layer_dir = Fpath.to_string (Day11_layer.Layer.dir layer);
+ })
+ else (
Current.Job.log job "FAILED: %s %s" label
(OpamPackage.to_string key.pkg);
- Error (`Msg (Printf.sprintf "%s failed: %s" label
- (OpamPackage.to_string key.pkg)))
- end
- end
+ Error
+ (`Msg
+ (Printf.sprintf "%s failed: %s" label
+ (OpamPackage.to_string key.pkg)))))
end
-module Op_build = Make_op (struct let label = "build" end)
-module Op_tool = Make_op (struct let label = "tool" end)
-module Op_compile = Make_op (struct let label = "compile" end)
-module Op_doc = Make_op (struct let label = "doc" end)
-module Op_link = Make_op (struct let label = "link" end)
+module Op_build = Make_op (struct
+ let label = "build"
+end)
+
+module Op_tool = Make_op (struct
+ let label = "tool"
+end)
+
+module Op_compile = Make_op (struct
+ let label = "compile"
+end)
+
+module Op_doc = Make_op (struct
+ let label = "doc"
+end)
+
+module Op_link = Make_op (struct
+ let label = "link"
+end)
-module Cache_build = Current_cache.Make (Op_build)
-module Cache_tool = Current_cache.Make (Op_tool)
+module Cache_build = Current_cache.Make (Op_build)
+module Cache_tool = Current_cache.Make (Op_tool)
module Cache_compile = Current_cache.Make (Op_compile)
-module Cache_doc = Current_cache.Make (Op_doc)
-module Cache_link = Current_cache.Make (Op_link)
+module Cache_doc = Current_cache.Make (Op_doc)
+module Cache_link = Current_cache.Make (Op_link)
(* ── Public interface ──────────────────────────────────────────── *)
-(** Run a DAG node as an OCurrent component with job logs.
- [dag_node] is the original DAG node with full deps and universe.
- [dispatch] is called with the original node to execute it.
- [deps] are OCurrent dependencies that must complete first. *)
+(** Run a DAG node as an OCurrent component with job logs. [dag_node] is the
+ original DAG node with full deps and universe. [dispatch] is called with the
+ original node to execute it. [deps] are OCurrent dependencies that must
+ complete first. *)
let run_node ~env ~os_dir ~pool ~dispatch ~label ~profile_name
~(dag_node : Day11_opam_layer.Build.t) ~deps () : t Current.t =
let open Current.Syntax in
@@ -186,53 +208,61 @@ let run_node ~env ~os_dir ~pool ~dispatch ~label ~profile_name
let> deps in
let all_dep_dirs =
let seen = Hashtbl.create 16 in
- List.iter (fun (d : t) ->
- List.iter (fun dir ->
- let s = Fpath.to_string dir in
- if not (Hashtbl.mem seen s) then
- Hashtbl.replace seen s dir
- ) d.all_layer_dirs
- ) deps;
+ List.iter
+ (fun (d : t) ->
+ List.iter
+ (fun dir ->
+ let s = Fpath.to_string dir in
+ if not (Hashtbl.mem seen s) then Hashtbl.replace seen s dir)
+ d.all_layer_dirs)
+ deps;
Hashtbl.fold (fun _ v acc -> v :: acc) seen []
in
let result =
match label with
| "build" ->
- Cache_build.get { os_dir; dag_node; dispatch; env; pool; profile_name }
- Op_build.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
- |> Current.Primitive.map_result
- (Result.map (fun v ->
- (v.Op_build.Value.hash, Fpath.v v.Op_build.Value.layer_dir)))
+ Cache_build.get
+ { os_dir; dag_node; dispatch; env; pool; profile_name }
+ Op_build.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
+ |> Current.Primitive.map_result
+ (Result.map (fun v ->
+ (v.Op_build.Value.hash, Fpath.v v.Op_build.Value.layer_dir)))
| "tool" ->
- Cache_tool.get { os_dir; dag_node; dispatch; env; pool; profile_name }
- Op_tool.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
- |> Current.Primitive.map_result
- (Result.map (fun v ->
- (v.Op_tool.Value.hash, Fpath.v v.Op_tool.Value.layer_dir)))
+ Cache_tool.get
+ { os_dir; dag_node; dispatch; env; pool; profile_name }
+ Op_tool.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
+ |> Current.Primitive.map_result
+ (Result.map (fun v ->
+ (v.Op_tool.Value.hash, Fpath.v v.Op_tool.Value.layer_dir)))
| "compile" ->
- Cache_compile.get { os_dir; dag_node; dispatch; env; pool; profile_name }
- Op_compile.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
- |> Current.Primitive.map_result
- (Result.map (fun v ->
- (v.Op_compile.Value.hash, Fpath.v v.Op_compile.Value.layer_dir)))
+ Cache_compile.get
+ { os_dir; dag_node; dispatch; env; pool; profile_name }
+ Op_compile.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
+ |> Current.Primitive.map_result
+ (Result.map (fun v ->
+ (v.Op_compile.Value.hash, Fpath.v v.Op_compile.Value.layer_dir)))
| "doc" ->
- Cache_doc.get { os_dir; dag_node; dispatch; env; pool; profile_name }
- Op_doc.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
- |> Current.Primitive.map_result
- (Result.map (fun v ->
- (v.Op_doc.Value.hash, Fpath.v v.Op_doc.Value.layer_dir)))
+ Cache_doc.get
+ { os_dir; dag_node; dispatch; env; pool; profile_name }
+ Op_doc.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
+ |> Current.Primitive.map_result
+ (Result.map (fun v ->
+ (v.Op_doc.Value.hash, Fpath.v v.Op_doc.Value.layer_dir)))
| "link" ->
- Cache_link.get { os_dir; dag_node; dispatch; env; pool; profile_name }
- Op_link.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
- |> Current.Primitive.map_result
- (Result.map (fun v ->
- (v.Op_link.Value.hash, Fpath.v v.Op_link.Value.layer_dir)))
+ Cache_link.get
+ { os_dir; dag_node; dispatch; env; pool; profile_name }
+ Op_link.Key.{ hash = dag_node.hash; pkg = dag_node.pkg }
+ |> Current.Primitive.map_result
+ (Result.map (fun v ->
+ (v.Op_link.Value.hash, Fpath.v v.Op_link.Value.layer_dir)))
| l -> Fmt.failwith "Unknown node label: %s" l
in
result
|> Current.Primitive.map_result
(Result.map (fun (hash, own_dir) ->
- { pkg = dag_node.pkg;
- build_hash = hash;
- layer_dir = own_dir;
- all_layer_dirs = own_dir :: all_dep_dirs }))
+ {
+ pkg = dag_node.pkg;
+ build_hash = hash;
+ layer_dir = own_dir;
+ all_layer_dirs = own_dir :: all_dep_dirs;
+ }))
File "src/lib/day11_profile_ctx_loader.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/day11_profile_ctx_loader.ml b/_build/default/src/lib/.formatted/day11_profile_ctx_loader.ml
index 5a9dbcf..dec8bdc 100644
--- a/_build/default/src/lib/day11_profile_ctx_loader.ml
+++ b/_build/default/src/lib/.formatted/day11_profile_ctx_loader.ml
@@ -1,17 +1,16 @@
(** Per-tick [Profile_ctx.t] loader.
- [Profile_ctx.load] calls [Git_packages.of_repositories] which
- internally uses [Lwt_main.run] via git-unix. Running that from
- inside OCurrent's Lwt engine (under [Lwt_eio.with_event_loop])
- would nest event loops — undefined behaviour. We dodge that by
- detaching the load into a thread via [Lwt_preemptive.detach], so
- the git-unix code gets its own fresh Lwt world.
-
- [Profile_ctx.t] isn't marshalable (closures, hashtables), so the
- Op's [Value] is just a digest marker; the actual ctx is stashed
- in a per-profile [ref] and picked up by the caller after the Op
- resolves. Safe because [Current_cache] serialises [build] per-key,
- so the ref update for a given profile never races with itself. *)
+ [Profile_ctx.load] calls [Git_packages.of_repositories] which internally
+ uses [Lwt_main.run] via git-unix. Running that from inside OCurrent's Lwt
+ engine (under [Lwt_eio.with_event_loop]) would nest event loops — undefined
+ behaviour. We dodge that by detaching the load into a thread via
+ [Lwt_preemptive.detach], so the git-unix code gets its own fresh Lwt world.
+
+ [Profile_ctx.t] isn't marshalable (closures, hashtables), so the Op's
+ [Value] is just a digest marker; the actual ctx is stashed in a per-profile
+ [ref] and picked up by the caller after the Op resolves. Safe because
+ [Current_cache] serialises [build] per-key, so the ref update for a given
+ profile never races with itself. *)
module Profile = Day11_batch.Profile
module Profile_ctx = Day11_batch.Profile_ctx
@@ -29,42 +28,36 @@ let process_nonce =
Printf.sprintf "%d-%f" (Unix.getpid ()) (Unix.gettimeofday ())
module Op = struct
- type t = {
- profile : Profile.t;
- cache_dir : Fpath.t;
- }
+ type t = { profile : Profile.t; cache_dir : Fpath.t }
module Key = struct
- type t = {
- profile_name : string;
- repos_with_shas : (string * string) list;
- }
+ type t = { profile_name : string; repos_with_shas : (string * string) list }
let digest k =
let sorted =
List.sort compare
- (List.map (fun (p, s) -> p ^ "@" ^ s) k.repos_with_shas) in
+ (List.map (fun (p, s) -> p ^ "@" ^ s) k.repos_with_shas)
+ in
Digest.to_hex
(Digest.string
- (String.concat "\n"
- (process_nonce :: k.profile_name :: sorted)))
+ (String.concat "\n" (process_nonce :: k.profile_name :: sorted)))
let pp f k =
- Fmt.pf f "profile-ctx %s (%d repos)"
- k.profile_name (List.length k.repos_with_shas)
+ Fmt.pf f "profile-ctx %s (%d repos)" k.profile_name
+ (List.length k.repos_with_shas)
end
module Value = struct
(* The [Profile_ctx.t] isn't marshalable; the Op's value is just
the key digest so [Current_cache] can detect re-runs. *)
type t = string
+
let marshal = Fun.id
let unmarshal = Fun.id
end
let id = "day11-profile-ctx"
let auto_cancel = false
-
let pp f (key : Key.t) = Key.pp f key
(* Snapshots live at [~/.day11/snapshots/<profile>/<key>/].
@@ -81,9 +74,10 @@ module Op = struct
let created =
let t = Unix.gettimeofday () in
let tm = Unix.gmtime t in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
- (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
- tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (tm.Unix.tm_year + 1900)
+ (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
+ tm.Unix.tm_sec
+ in
Day11_batch.Snapshot.{ repos = repos_with_shas; key; created }
in
let dir = Fpath.(snapshots_base / snapshot.key) in
@@ -94,71 +88,69 @@ module Op = struct
let build op job (key : Key.t) =
let open Lwt.Syntax in
let* () = Current.Job.start job ~level:Current.Level.Mostly_harmless in
- Current.Job.log job "[profile %s] loading ctx for %d repos"
- op.profile.name (List.length key.repos_with_shas);
+ Current.Job.log job "[profile %s] loading ctx for %d repos" op.profile.name
+ (List.length key.repos_with_shas);
(* Override the profile's static [opam_repositories] with the
live paths we've just resolved via Current_git. *)
let profile =
- { op.profile with
- opam_repositories = List.map fst key.repos_with_shas } in
+ { op.profile with opam_repositories = List.map fst key.repos_with_shas }
+ in
let* ctx = Profile_ctx.load_lwt profile ~cache_dir:op.cache_dir in
Hashtbl.replace stores op.profile.name ctx;
let snapshot =
write_snapshot_and_run ~cache_dir:op.cache_dir
- ~profile_name:op.profile.name
- ~repos_with_shas:key.repos_with_shas in
- Current.Job.log job "[profile %s] ctx loaded, snapshot=%s"
- op.profile.name snapshot.key;
+ ~profile_name:op.profile.name ~repos_with_shas:key.repos_with_shas
+ in
+ Current.Job.log job "[profile %s] ctx loaded, snapshot=%s" op.profile.name
+ snapshot.key;
Lwt.return (Ok (Key.digest key))
end
module Cache = Current_cache.Make (Op)
(** Read the on-disk HEAD of a local git repo as a one-shot
- [Current_git.Commit.t Current.t]. Used as the fallback when an
- entry has no remote-pull job to drive it (e.g. read-only
- overlays maintained outside the daemon). The commit is captured
- once at pipeline-construction time and never changes — manual
- edits to the repo will require a daemon restart, which is the
- correct trade-off for a static overlay. *)
+ [Current_git.Commit.t Current.t]. Used as the fallback when an entry has no
+ remote-pull job to drive it (e.g. read-only overlays maintained outside the
+ daemon). The commit is captured once at pipeline-construction time and never
+ changes — manual edits to the repo will require a daemon restart, which is
+ the correct trade-off for a static overlay. *)
let one_shot_head_commit (path : Fpath.t) : Current_git.Commit.t Current.t =
let p = Fpath.to_string path in
- let cmd = Printf.sprintf
- "git -C %s rev-parse HEAD" (Filename.quote p) in
+ let cmd = Printf.sprintf "git -C %s rev-parse HEAD" (Filename.quote p) in
let ic = Unix.open_process_in cmd in
let sha =
- try String.trim (input_line ic) with _ -> "0000000000000000000000000000000000000000" in
+ try String.trim (input_line ic)
+ with _ -> "0000000000000000000000000000000000000000"
+ in
ignore (Unix.close_process_in ic);
Current.return
(Current_git.Commit.v ~repo:path
- ~id:(Current_git.Commit_id.v
- ~repo:p ~gref:"refs/heads/master" ~hash:sha))
+ ~id:(Current_git.Commit_id.v ~repo:p ~gref:"refs/heads/master" ~hash:sha))
(** Resolve one [opam_repositories] entry to a live
[Current_git.Commit.t Current.t].
- Entries are local paths. If the path is in [remote_commits] (i.e.
- a remote was declared via [--remote URL=PATH]), the commit comes
- directly from the {!Docs_ci_lib.Remote_opam_repo.maintain_commit}
- output for that remote — no inotify, no filesystem watcher; the
- pull job's post-fetch SHA flows straight through OCurrent. Local-
- only entries (no [--remote]) fall back to {!one_shot_head_commit}.
-
- The previous version watched every entry with [Current_git.Local],
- which decoupled solver triggers from pull-job outcomes — and
- silently masked bugs where the pull "succeeded" but didn't move
- HEAD (detached-HEAD, no upstream tracking, etc.). Reading the SHA
- from the pull job directly makes the dependency edge explicit. *)
+ Entries are local paths. If the path is in [remote_commits] (i.e. a remote
+ was declared via [--remote URL=PATH]), the commit comes directly from the
+ {!Docs_ci_lib.Remote_opam_repo.maintain_commit} output for that remote — no
+ inotify, no filesystem watcher; the pull job's post-fetch SHA flows straight
+ through OCurrent. Local- only entries (no [--remote]) fall back to
+ {!one_shot_head_commit}.
+
+ The previous version watched every entry with [Current_git.Local], which
+ decoupled solver triggers from pull-job outcomes — and silently masked bugs
+ where the pull "succeeded" but didn't move HEAD (detached-HEAD, no upstream
+ tracking, etc.). Reading the SHA from the pull job directly makes the
+ dependency edge explicit. *)
let repo_commit ~remote_commits entry : Current_git.Commit.t Current.t =
match Hashtbl.find_opt remote_commits entry with
| Some c -> c
| None -> one_shot_head_commit (Fpath.v entry)
(** A live [(path, sha) Current.t] for one entry of a profile's
- [opam_repositories]. Paths are observed via {!Current_git.Local}
- only — URL-based cloning lives in
- {!Docs_ci_lib.Remote_opam_repo}, kept separate so that the
- [Day11_batch.Profile] stays local-path-only across both
+ [opam_repositories]. Paths are observed via {!Current_git.Local} only —
+ URL-based cloning lives in {!Docs_ci_lib.Remote_opam_repo}, kept separate so
+ that the [Day11_batch.Profile] stays local-path-only across both
ocaml-docs-ci and the [day11] CLI. *)
let repo_source ~remote_commits entry : (string * string) Current.t =
let open Current.Syntax in
@@ -170,48 +162,47 @@ let repo_source ~remote_commits entry : (string * string) Current.t =
(** The commits that drive package tracking for a profile.
Returns one [Current_git.Commit.t Current.t] per entry in
- [profile.opam_repositories], in declaration order. Callers merge
- per-repo tracking results with "later entry wins" semantics,
- matching opam's overlay behaviour — so a profile's oxcaml overlay
- can both {e add} new packages (e.g. [oxcaml-compiler]) and {e
- override} mainline entries by name+version. *)
+ [profile.opam_repositories], in declaration order. Callers merge per-repo
+ tracking results with "later entry wins" semantics, matching opam's overlay
+ behaviour — so a profile's oxcaml overlay can both {e add} new packages
+ (e.g. [oxcaml-compiler]) and {e override} mainline entries by name+version.
+*)
let tracking_commits ~remote_commits (profile : Profile.t) =
match profile.opam_repositories with
| [] ->
- failwith (Printf.sprintf
- "profile %s: opam_repositories is empty — nothing to track"
- profile.name)
- | entries ->
- List.map (repo_commit ~remote_commits) entries
+ failwith
+ (Printf.sprintf
+ "profile %s: opam_repositories is empty — nothing to track"
+ profile.name)
+ | entries -> List.map (repo_commit ~remote_commits) entries
(** Full repos_with_shas [Current.t] for a profile. *)
let repos_with_shas ~remote_commits (profile : Profile.t) =
let entries =
- List.map (repo_source ~remote_commits)
- profile.opam_repositories in
+ List.map (repo_source ~remote_commits) profile.opam_repositories
+ in
Current.list_seq entries
-(** The snapshot directory (on disk) for a given
- [(path, sha) list]. Used by callers that want to write
- per-snapshot outputs (status.json, solutions, etc.). *)
+(** The snapshot directory (on disk) for a given [(path, sha) list]. Used by
+ callers that want to write per-snapshot outputs (status.json, solutions,
+ etc.). *)
let snapshot_dir_of ~cache_dir ~profile_name repos_with_shas =
let key = Day11_batch.Snapshot.compute_key repos_with_shas in
Fpath.(Op.snapshots_base_for ~cache_dir profile_name / key)
-(** Bundle of everything a profile's sub-pipeline needs per tick.
- Returned by [resolve]. The [ctx] and [snapshot_dir] currents are
- driven by the same underlying [repos_with_shas] polling, so they
- change together on any opam-repo commit. *)
type resolved = {
ctx : Day11_batch.Profile_ctx.t Current.t;
snapshot_dir : Fpath.t Current.t;
repos_with_shas : (string * string) list Current.t;
tracking_commits : Current_git.Commit.t Current.t list;
- (** One commit per entry in [profile.opam_repositories], in
- declaration order. Callers run [Track.v] per commit and
- merge with "later wins" so overlay repos contribute their
- own packages on top of mainline. *)
+ (** One commit per entry in [profile.opam_repositories], in declaration
+ order. Callers run [Track.v] per commit and merge with "later wins" so
+ overlay repos contribute their own packages on top of mainline. *)
}
+(** Bundle of everything a profile's sub-pipeline needs per tick. Returned by
+ [resolve]. The [ctx] and [snapshot_dir] currents are driven by the same
+ underlying [repos_with_shas] polling, so they change together on any
+ opam-repo commit. *)
let resolve ~remote_commits ~cache_dir (profile : Profile.t) =
let open Current.Syntax in
@@ -221,14 +212,15 @@ let resolve ~remote_commits ~cache_dir (profile : Profile.t) =
Current.component "[%s] profile-ctx" profile.name
|>
let> repos_with_shas = repos in
- Cache.get op Op.Key.{ profile_name = profile.name; repos_with_shas } in
+ Cache.get op Op.Key.{ profile_name = profile.name; repos_with_shas }
+ in
let ctx =
let+ _digest = digest in
match Hashtbl.find_opt stores profile.name with
| Some ctx -> ctx
| None ->
- failwith (Printf.sprintf "profile %s: ctx store unpopulated"
- profile.name)
+ failwith
+ (Printf.sprintf "profile %s: ctx store unpopulated" profile.name)
in
let snapshot_dir =
let+ repos_with_shas = repos in
File "src/lib/day11_solver.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/day11_solver.ml b/_build/default/src/lib/.formatted/day11_solver.ml
index 631f373..e74d10c 100644
--- a/_build/default/src/lib/day11_solver.ml
+++ b/_build/default/src/lib/.formatted/day11_solver.ml
@@ -1,7 +1,7 @@
(** Day11-based solver: in-process solving via solver_pool subprocesses.
- Replaces the Cap'n Proto solver service. Uses day11's solver_worker
- binaries for parallel solving, communicating via JSONL files. *)
+ Replaces the Cap'n Proto solver service. Uses day11's solver_worker binaries
+ for parallel solving, communicating via JSONL files. *)
module SolveOp = struct
type t = {
@@ -11,18 +11,17 @@ module SolveOp = struct
profile_name : string;
ocaml_version : OpamPackage.t option;
pinned_versions : OpamPackage.t list;
- (** Hard version pins fed into the solver as [(`Eq, v)]
- constraints. Empty list = no extra pins beyond
- [ocaml_version]. Surfaced via [Profile.pinned_versions];
- used to propagate a specific +ox / variant flavour
- through transitive deps. *)
+ (** Hard version pins fed into the solver as [(`Eq, v)] constraints.
+ Empty list = no extra pins beyond [ocaml_version]. Surfaced via
+ [Profile.pinned_versions]; used to propagate a specific +ox /
+ variant flavour through transitive deps. *)
cache_dir : Fpath.t;
- (** Used to derive the per-snapshot [solutions/] directory
- ([snapshot_dir/solutions/<pkg>.json]). The on-disk cache lets
- a pipeline restart after [sqlite.db] has been wiped (or after
- OCurrent's primitive cache otherwise loses state) skip the
- ~3-minute solver pass entirely as long as repos haven't moved
- and the compiler / target set is unchanged. *)
+ (** Used to derive the per-snapshot [solutions/] directory
+ ([snapshot_dir/solutions/<pkg>.json]). The on-disk cache lets a
+ pipeline restart after [sqlite.db] has been wiped (or after
+ OCurrent's primitive cache otherwise loses state) skip the ~3-minute
+ solver pass entirely as long as repos haven't moved and the compiler
+ / target set is unchanged. *)
}
module Key = struct
@@ -35,22 +34,26 @@ module SolveOp = struct
cache key ensures a profile compiler change invalidates
prior solves. *)
pinned_versions : string list;
- (* Same shape as [ocaml_version] — string-form pins included
+ (* Same shape as [ocaml_version] — string-form pins included
in the digest so a profile pin change invalidates prior
solves. *)
}
let digest t =
- t.commit ^ "@" ^ t.repos_digest ^ "|" ^ t.ocaml_version ^
- "|" ^ String.concat "," t.pinned_versions ^ ":" ^
- (List.map OpamPackage.to_string t.targets
- |> String.concat ",")
+ t.commit
+ ^ "@"
+ ^ t.repos_digest
+ ^ "|"
+ ^ t.ocaml_version
+ ^ "|"
+ ^ String.concat "," t.pinned_versions
+ ^ ":"
+ ^ (List.map OpamPackage.to_string t.targets |> String.concat ",")
end
module Value = struct
type t = {
- results : (string * string) list;
- (* (pkg_str, solve_result_json) pairs *)
+ results : (string * string) list; (* (pkg_str, solve_result_json) pairs *)
}
[@@deriving yojson]
@@ -61,18 +64,15 @@ module SolveOp = struct
let id = "day11-solver"
let pp f (key : Key.t) =
- Fmt.pf f "solve %d packages @%s"
- (List.length key.targets)
+ Fmt.pf f "solve %d packages @%s" (List.length key.targets)
(String.sub key.commit 0 (min 12 (String.length key.commit)))
let auto_cancel = false
let snapshot_solutions_dir ctx =
let snapshot_dir =
- Day11_profile_ctx_loader.snapshot_dir_of
- ~cache_dir:ctx.cache_dir
- ~profile_name:ctx.profile_name
- ctx.repos_with_shas
+ Day11_profile_ctx_loader.snapshot_dir_of ~cache_dir:ctx.cache_dir
+ ~profile_name:ctx.profile_name ctx.repos_with_shas
in
Fpath.(snapshot_dir / "solutions")
@@ -95,93 +95,99 @@ module SolveOp = struct
writes entries with [cache_key = None]; the load path here
accepts those (treats them as a cache hit) so command-line and
server-side runs share the cache without conflict. *)
- let solution_filename pkg =
- OpamPackage.to_string pkg ^ ".json"
+ let solution_filename pkg = OpamPackage.to_string pkg ^ ".json"
let compute_cache_key ~compiler_tag ~commit ~repos_digest =
- Digest.to_hex (Digest.string
- (compiler_tag ^ "|" ^ commit ^ "|" ^ repos_digest))
+ Digest.to_hex
+ (Digest.string (compiler_tag ^ "|" ^ commit ^ "|" ^ repos_digest))
(* Split [targets] into those whose cached solutions are still
valid (matching [cache_key]) and those that need (re)solving. *)
let partition_cached ~dir ~cache_key targets =
- if not (Bos.OS.Dir.exists dir |> Result.value ~default:false)
- then ([], targets)
+ if not (Bos.OS.Dir.exists dir |> Result.value ~default:false) then
+ ([], targets)
else
- List.fold_left (fun (cached, uncached) pkg ->
- let path = Fpath.(dir / solution_filename pkg) in
- match Day11_batch.Incremental_solver.load path with
- | Ok entry
- when Day11_batch.Incremental_solver.is_cache_key_valid
- ~expected:(Some cache_key) entry ->
- (match entry with
- | Cached_solution { result; _ } ->
- let result_json =
- Yojson.Safe.to_string
- (Day11_solution.Solve_result.to_json result) in
- (OpamPackage.to_string pkg, result_json) :: cached, uncached
- | Cached_failure _ -> cached, pkg :: uncached)
- | _ -> cached, pkg :: uncached
- ) ([], []) targets
+ List.fold_left
+ (fun (cached, uncached) pkg ->
+ let path = Fpath.(dir / solution_filename pkg) in
+ match Day11_batch.Incremental_solver.load path with
+ | Ok entry
+ when Day11_batch.Incremental_solver.is_cache_key_valid
+ ~expected:(Some cache_key) entry -> (
+ match entry with
+ | Cached_solution { result; _ } ->
+ let result_json =
+ Yojson.Safe.to_string
+ (Day11_solution.Solve_result.to_json result)
+ in
+ ((OpamPackage.to_string pkg, result_json) :: cached, uncached)
+ | Cached_failure _ -> (cached, pkg :: uncached))
+ | _ -> (cached, pkg :: uncached))
+ ([], []) targets
let save_result ~dir ~cache_key pkg result =
let path = Fpath.(dir / solution_filename pkg) in
- let entry = Day11_batch.Incremental_solver.Cached_solution {
- package = pkg;
- result;
- cache_key = Some cache_key;
- } in
+ let entry =
+ Day11_batch.Incremental_solver.Cached_solution
+ { package = pkg; result; cache_key = Some cache_key }
+ in
ignore (Day11_batch.Incremental_solver.save path entry)
let build (ctx : t) job (key : Key.t) =
let open Lwt.Syntax in
let* () = Current.Job.start job ~level:Current.Level.Mostly_harmless in
let compiler_tag =
- if key.ocaml_version = "" then "none" else key.ocaml_version in
+ if key.ocaml_version = "" then "none" else key.ocaml_version
+ in
let cache_key =
- compute_cache_key ~compiler_tag
- ~commit:key.commit ~repos_digest:key.repos_digest in
+ compute_cache_key ~compiler_tag ~commit:key.commit
+ ~repos_digest:key.repos_digest
+ in
let dir = snapshot_solutions_dir ctx in
ignore (Bos.OS.Dir.create ~path:true dir);
Lwt_eio.run_eio @@ fun () ->
- let cached, uncached =
- partition_cached ~dir ~cache_key key.targets in
+ let cached, uncached = partition_cached ~dir ~cache_key key.targets in
let n_cached = List.length cached in
let n_uncached = List.length uncached in
let short_commit =
- String.sub key.commit 0 (min 12 (String.length key.commit)) in
- if n_uncached = 0 then begin
+ String.sub key.commit 0 (min 12 (String.length key.commit))
+ in
+ if n_uncached = 0 then (
Current.Job.log job
"[profile %s] All %d solutions cached (commit %s) — skipping solver"
ctx.profile_name n_cached short_commit;
- Ok Value.{ results = cached }
- end else begin
+ Ok Value.{ results = cached })
+ else (
Current.Job.log job
"[profile %s] %d cached, solving %d new/stale targets (commit %s)"
ctx.profile_name n_cached n_uncached short_commit;
Eio.Switch.run @@ fun sw ->
let results =
Day11_solver_pool.Solver_pool.solve_many ~sw ctx.env
- ?ocaml_version:ctx.ocaml_version
- ~constraints:ctx.pinned_versions
+ ?ocaml_version:ctx.ocaml_version ~constraints:ctx.pinned_versions
~on_progress:(fun ~done_count ~total ->
Current.Job.log job "Solving: %d/%d" done_count total)
~np:ctx.np ~repos:ctx.repos_with_shas uncached
in
- let new_pairs = List.filter_map (fun (pkg, result) ->
- match result with
- | Ok solve_result ->
- save_result ~dir ~cache_key pkg solve_result;
- let result_json = Day11_solution.Solve_result.to_json solve_result in
- Some (OpamPackage.to_string pkg, Yojson.Safe.to_string result_json)
- | Error _ -> None
- ) results in
+ let new_pairs =
+ List.filter_map
+ (fun (pkg, result) ->
+ match result with
+ | Ok solve_result ->
+ save_result ~dir ~cache_key pkg solve_result;
+ let result_json =
+ Day11_solution.Solve_result.to_json solve_result
+ in
+ Some
+ (OpamPackage.to_string pkg, Yojson.Safe.to_string result_json)
+ | Error _ -> None)
+ results
+ in
Current.Job.log job
"Solved %d/%d new targets; %d cached → %d total solutions"
(List.length new_pairs) n_uncached n_cached
(List.length new_pairs + n_cached);
- Ok Value.{ results = cached @ new_pairs }
- end
+ Ok Value.{ results = cached @ new_pairs })
end
module Solver_cache = Current_cache.Make (SolveOp)
@@ -191,46 +197,59 @@ type solution = {
solve_result : Day11_solution.Solve_result.t;
}
-(** Solve all tracked packages using day11's solver. Returns solutions
- keyed by target package. *)
+(** Solve all tracked packages using day11's solver. Returns solutions keyed by
+ target package. *)
let repos_digest repos =
- let sorted = List.sort compare
- (List.map (fun (path, sha) -> path ^ "@" ^ sha) repos) in
+ let sorted =
+ List.sort compare (List.map (fun (path, sha) -> path ^ "@" ^ sha) repos)
+ in
Digest.to_hex (Digest.string (String.concat "\n" sorted))
let solve ~env ~np ~profile_name ~repos_with_shas ?ocaml_version
- ?(pinned_versions = [])
- ~cache_dir
+ ?(pinned_versions = []) ~cache_dir
~(opam_commit : Current_git.Commit.t Current.t)
(tracked : Track.t list Current.t) =
let open Current.Syntax in
Current.component "[%s] day11-solve" profile_name
|>
let> tracked and> commit = opam_commit in
- let commit_hash = Current_git.Commit.id commit
- |> Current_git.Commit_id.hash in
+ let commit_hash =
+ Current_git.Commit.id commit |> Current_git.Commit_id.hash
+ in
let targets = List.map Track.pkg tracked in
- let ocaml_version_str = match ocaml_version with
+ let ocaml_version_str =
+ match ocaml_version with
| Some pkg -> OpamPackage.to_string pkg
- | None -> "" in
+ | None -> ""
+ in
let pinned_strs = List.map OpamPackage.to_string pinned_versions in
Solver_cache.get
- { repos_with_shas; env; np; profile_name; ocaml_version;
- pinned_versions; cache_dir }
- SolveOp.Key.{
- targets;
- commit = commit_hash;
- repos_digest = repos_digest repos_with_shas;
- ocaml_version = ocaml_version_str;
- pinned_versions = pinned_strs;
+ {
+ repos_with_shas;
+ env;
+ np;
+ profile_name;
+ ocaml_version;
+ pinned_versions;
+ cache_dir;
}
- |> Current.Primitive.map_result (Result.map (fun v ->
- List.filter_map (fun (pkg_str, json_str) ->
- try
- let pkg = OpamPackage.of_string pkg_str in
- let json = Yojson.Safe.from_string json_str in
- match Day11_solution.Solve_result.of_json json with
- | Ok result -> Some { target = pkg; solve_result = result }
- | Error _ -> None
- with _ -> None
- ) v.SolveOp.Value.results))
+ SolveOp.Key.
+ {
+ targets;
+ commit = commit_hash;
+ repos_digest = repos_digest repos_with_shas;
+ ocaml_version = ocaml_version_str;
+ pinned_versions = pinned_strs;
+ }
+ |> Current.Primitive.map_result
+ (Result.map (fun v ->
+ List.filter_map
+ (fun (pkg_str, json_str) ->
+ try
+ let pkg = OpamPackage.of_string pkg_str in
+ let json = Yojson.Safe.from_string json_str in
+ match Day11_solution.Solve_result.of_json json with
+ | Ok result -> Some { target = pkg; solve_result = result }
+ | Error _ -> None
+ with _ -> None)
+ v.SolveOp.Value.results))
File "src/lib/github_pin_overlay.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/github_pin_overlay.ml b/_build/default/src/lib/.formatted/github_pin_overlay.ml
index 445a4ca..3ca3ed4 100644
--- a/_build/default/src/lib/github_pin_overlay.ml
+++ b/_build/default/src/lib/.formatted/github_pin_overlay.ml
@@ -3,15 +3,15 @@
(* Packages from the upstream root we publish into the overlay.
[odoc-bench] is excluded — it pulls in benchmarking deps that
aren't needed for the doc-tooling closure. *)
-let opam_files_to_publish = [
- "odoc"; "odoc-driver"; "odoc-md"; "odoc-parser"; "sherlodoc"
-]
+let opam_files_to_publish =
+ [ "odoc"; "odoc-driver"; "odoc-md"; "odoc-parser"; "sherlodoc" ]
module Op = struct
type t = unit
module Key = struct
type t = { url : string; path : Fpath.t }
+
let digest t = t.url ^ "|" ^ Fpath.to_string t.path
end
@@ -19,65 +19,65 @@ module Op = struct
(* The overlay's HEAD SHA after regeneration. Same value across
no-op ticks. *)
type t = string
+
let marshal t = t
let unmarshal t = t
end
let id = "docs-ci-github-pin-overlay"
let auto_cancel = false
+
let pp f (key : Key.t) =
Fmt.pf f "github-pin-overlay %s → %a" key.url Fpath.pp key.path
let sh_log job fmt =
- Fmt.kstr (fun s ->
- Current.Job.log job "$ %s" s;
- let cmd = ("", [| "/bin/sh"; "-c"; s |]) in
- let open Lwt.Syntax in
- let* output = Lwt_process.pread_lines cmd
- |> Lwt_stream.to_list in
- List.iter (Current.Job.log job "%s") output;
- Lwt.return (Ok (String.concat "\n" output))
- ) fmt
+ Fmt.kstr
+ (fun s ->
+ Current.Job.log job "$ %s" s;
+ let cmd = ("", [| "/bin/sh"; "-c"; s |]) in
+ let open Lwt.Syntax in
+ let* output = Lwt_process.pread_lines cmd |> Lwt_stream.to_list in
+ List.iter (Current.Job.log job "%s") output;
+ Lwt.return (Ok (String.concat "\n" output)))
+ fmt
let run_sh job fmt =
- Fmt.kstr (fun s ->
- Current.Job.log job "$ %s" s;
- let cmd = ("", [| "/bin/sh"; "-c"; s |]) in
- let open Lwt.Syntax in
- let* status = Lwt_process.exec cmd in
- match status with
- | Unix.WEXITED 0 -> Lwt.return (Ok ())
- | Unix.WEXITED n ->
- Lwt.return (Error (`Msg (Printf.sprintf
- "command exited %d: %s" n s)))
- | _ ->
- Lwt.return (Error (`Msg ("command signalled: " ^ s)))
- ) fmt
+ Fmt.kstr
+ (fun s ->
+ Current.Job.log job "$ %s" s;
+ let cmd = ("", [| "/bin/sh"; "-c"; s |]) in
+ let open Lwt.Syntax in
+ let* status = Lwt_process.exec cmd in
+ match status with
+ | Unix.WEXITED 0 -> Lwt.return (Ok ())
+ | Unix.WEXITED n ->
+ Lwt.return
+ (Error (`Msg (Printf.sprintf "command exited %d: %s" n s)))
+ | _ -> Lwt.return (Error (`Msg ("command signalled: " ^ s))))
+ fmt
let upstream_dir path = Fpath.(path / "upstream")
- let overlay_dir path = Fpath.(path / "repo")
+ let overlay_dir path = Fpath.(path / "repo")
let ensure_upstream_clone job ~url ~upstream =
let p = Fpath.to_string upstream in
let git_dir = Filename.concat p ".git" in
let ( let** ) = Lwt_result.bind in
- if Sys.file_exists git_dir then begin
+ if Sys.file_exists git_dir then
let** _ = sh_log job "git -C %s fetch --prune --tags origin" p in
(* Same dance as Remote_opam_repo: explicit detached-HEAD guard
around [merge --ff-only @{u}], built via Printf because Fmt
eats [@{u}] as a semantic-tag. *)
- let cmd = Printf.sprintf
- "git -C %s symbolic-ref -q HEAD >/dev/null && \
- git -C %s merge --ff-only '@{u}' || { \
- echo \"WARNING: HEAD detached at $(git -C %s rev-parse \
- --short HEAD); not auto-advancing.\" >&2; \
- true; }"
- p p p in
+ let cmd =
+ Printf.sprintf
+ "git -C %s symbolic-ref -q HEAD >/dev/null && git -C %s merge \
+ --ff-only '@{u}' || { echo \"WARNING: HEAD detached at $(git -C %s \
+ rev-parse --short HEAD); not auto-advancing.\" >&2; true; }"
+ p p p
+ in
let** _ = sh_log job "%s" cmd in
Lwt.return (Ok ())
- end else
- run_sh job "git clone %s %s"
- (Filename.quote url) (Filename.quote p)
+ else run_sh job "git clone %s %s" (Filename.quote url) (Filename.quote p)
let read_head_sha job ~upstream =
sh_log job "git -C %s rev-parse HEAD" (Fpath.to_string upstream)
@@ -86,8 +86,7 @@ module Op = struct
(* Latest reachable annotated/lightweight tag. Falls back to
[0.0.0] when the repo has no tags at all so the version
string still parses. *)
- sh_log job
- "git -C %s describe --tags --abbrev=0 2>/dev/null || echo 0.0.0"
+ sh_log job "git -C %s describe --tags --abbrev=0 2>/dev/null || echo 0.0.0"
(Fpath.to_string upstream)
(* Commit-time epoch (UTC). Monotone per-commit and big enough
@@ -99,14 +98,13 @@ module Op = struct
[5]). Using [%ct] (a 10-digit epoch) gives every newer commit
a strictly larger numeric prefix. *)
let read_commit_epoch job ~upstream ~sha =
- sh_log job "git -C %s show -s --format=%%ct %s"
- (Fpath.to_string upstream) sha
+ sh_log job "git -C %s show -s --format=%%ct %s" (Fpath.to_string upstream)
+ sha
(* Build the [git+https://…#sha] URL for opam to clone. *)
let pinned_url ~upstream_url ~sha =
let normalised =
- if String.length upstream_url >= 4
- && String.sub upstream_url 0 4 = "git+"
+ if String.length upstream_url >= 4 && String.sub upstream_url 0 4 = "git+"
then upstream_url
else "git+" ^ upstream_url
in
@@ -117,10 +115,11 @@ module Op = struct
let upstream_opam = Fpath.(upstream / (name ^ ".opam")) in
if not (Bos.OS.File.exists upstream_opam |> Result.value ~default:false)
then ()
- else begin
+ else
let opam =
- let f = OpamFile.make
- (OpamFilename.raw (Fpath.to_string upstream_opam)) in
+ let f =
+ OpamFile.make (OpamFilename.raw (Fpath.to_string upstream_opam))
+ in
OpamFile.OPAM.read f
in
let version = OpamPackage.Version.of_string version_str in
@@ -131,38 +130,38 @@ module Op = struct
in
Bos.OS.Dir.create ~path:true target_dir |> ignore;
let target = Fpath.(target_dir / "opam") in
- let f = OpamFile.make
- (OpamFilename.raw (Fpath.to_string target)) in
+ let f = OpamFile.make (OpamFilename.raw (Fpath.to_string target)) in
OpamFile.OPAM.write f opam
- end
- let regenerate_overlay ~upstream ~overlay ~upstream_url ~sha
- ~version_str =
+ let regenerate_overlay ~upstream ~overlay ~upstream_url ~sha ~version_str =
Bos.OS.Dir.create ~path:true Fpath.(overlay / "packages") |> ignore;
- let url_obj =
- OpamFile.URL.create (pinned_url ~upstream_url ~sha) in
- List.iter (publish_one ~upstream ~overlay ~url_obj ~version_str)
+ let url_obj = OpamFile.URL.create (pinned_url ~upstream_url ~sha) in
+ List.iter
+ (publish_one ~upstream ~overlay ~url_obj ~version_str)
opam_files_to_publish;
(* Repo-level manifest. Written once; a 2.0 stub is enough for
opam to recognise it as a valid repository root. *)
let repo_file = Fpath.(overlay / "repo") in
if not (Bos.OS.File.exists repo_file |> Result.value ~default:false) then
- ignore (Bos.OS.File.write repo_file
- "opam-version: \"2.0\"\nbrowse: \"\"\nupstream: \"\"\n")
+ ignore
+ (Bos.OS.File.write repo_file
+ "opam-version: \"2.0\"\nbrowse: \"\"\nupstream: \"\"\n")
let ensure_overlay_repo job ~overlay =
let p = Fpath.to_string overlay in
let git_dir = Filename.concat p ".git" in
let ( let** ) = Lwt_result.bind in
if Sys.file_exists git_dir then Lwt.return (Ok ())
- else begin
+ else
let** () = run_sh job "git init -q -b master %s" (Filename.quote p) in
- let** () = run_sh job
- "git -C %s config user.email 'docs-ci@invalid'" (Filename.quote p) in
- let** () = run_sh job
- "git -C %s config user.name 'docs-ci'" (Filename.quote p) in
+ let** () =
+ run_sh job "git -C %s config user.email 'docs-ci@invalid'"
+ (Filename.quote p)
+ in
+ let** () =
+ run_sh job "git -C %s config user.name 'docs-ci'" (Filename.quote p)
+ in
Lwt.return (Ok ())
- end
let commit_if_dirty job ~overlay ~sha ~tag ~version_str =
let p = Fpath.to_string overlay in
@@ -172,13 +171,14 @@ module Op = struct
match status with
| Error _ as e -> Lwt.return e
| Ok s when String.trim s = "" ->
- Current.Job.log job "overlay clean, no commit" ;
- Lwt.return (Ok ())
+ Current.Job.log job "overlay clean, no commit";
+ Lwt.return (Ok ())
| Ok _ ->
- let** () = run_sh job "git -C %s add -A" p in
- let msg = Printf.sprintf "Track %s @ %s (version %s)"
- tag sha version_str in
- run_sh job "git -C %s commit -q -m %s" p (Filename.quote msg)
+ let** () = run_sh job "git -C %s add -A" p in
+ let msg =
+ Printf.sprintf "Track %s @ %s (version %s)" tag sha version_str
+ in
+ run_sh job "git -C %s commit -q -m %s" p (Filename.quote msg)
let build () job (key : Key.t) =
let open Lwt.Syntax in
@@ -197,32 +197,30 @@ module Op = struct
let tag = String.trim tag_raw in
let** epoch_raw = read_commit_epoch job ~upstream ~sha in
let epoch = String.trim epoch_raw in
- let sha7 =
- if String.length sha >= 7 then String.sub sha 0 7 else sha in
- let version_str =
- Printf.sprintf "%s+master.%s.%s" tag epoch sha7 in
- Current.Job.log job
- "upstream %s @ %s (tag %s) → version %s"
- key.url sha tag version_str;
- regenerate_overlay
- ~upstream ~overlay
- ~upstream_url:key.url ~sha ~version_str;
+ let sha7 = if String.length sha >= 7 then String.sub sha 0 7 else sha in
+ let version_str = Printf.sprintf "%s+master.%s.%s" tag epoch sha7 in
+ Current.Job.log job "upstream %s @ %s (tag %s) → version %s" key.url sha
+ tag version_str;
+ regenerate_overlay ~upstream ~overlay ~upstream_url:key.url ~sha
+ ~version_str;
let** () = ensure_overlay_repo job ~overlay in
- let** () =
- commit_if_dirty job ~overlay ~sha ~tag ~version_str in
+ let** () = commit_if_dirty job ~overlay ~sha ~tag ~version_str in
sh_log job "git -C %s rev-parse HEAD" (Fpath.to_string overlay)
in
- Lwt_result.map (fun out ->
- let sha = String.trim out in
- Current.Job.log job "%a @ %s" Fpath.pp overlay sha;
- sha) result
+ Lwt_result.map
+ (fun out ->
+ let sha = String.trim out in
+ Current.Job.log job "%a @ %s" Fpath.pp overlay sha;
+ sha)
+ result
end
module Cache = Current_cache.Make (Op)
let maintain ~schedule ~url ~path : string Current.t =
let open Current.Syntax in
- Current.component "github-pin-overlay %s" url |>
+ Current.component "github-pin-overlay %s" url
+ |>
let> () = Current.return () in
Cache.get ~schedule () Op.Key.{ url; path }
@@ -232,21 +230,21 @@ let maintain_commit ~schedule ~url ~path : Current_git.Commit.t Current.t =
let overlay = Op.overlay_dir path in
let p = Fpath.to_string overlay in
Current_git.Commit.v ~repo:overlay
- ~id:(Current_git.Commit_id.v
- ~repo:p ~gref:"refs/heads/master" ~hash:sha)
+ ~id:(Current_git.Commit_id.v ~repo:p ~gref:"refs/heads/master" ~hash:sha)
type spec = { url : string; path : Fpath.t }
let spec_of_arg s =
match String.index_opt s '=' with
| None ->
- Error (`Msg (Printf.sprintf
- "--github-pin-overlay %S: expected URL=PATH" s))
+ Error
+ (`Msg (Printf.sprintf "--github-pin-overlay %S: expected URL=PATH" s))
| Some i ->
- let url = String.sub s 0 i in
- let path = String.sub s (i + 1) (String.length s - i - 1) in
- if url = "" || path = "" then
- Error (`Msg (Printf.sprintf
- "--github-pin-overlay %S: URL and PATH must both be non-empty" s))
- else
- Ok { url; path = Fpath.v path }
+ let url = String.sub s 0 i in
+ let path = String.sub s (i + 1) (String.length s - i - 1) in
+ if url = "" || path = "" then
+ Error
+ (`Msg
+ (Printf.sprintf
+ "--github-pin-overlay %S: URL and PATH must both be non-empty" s))
+ else Ok { url; path = Fpath.v path }
File "src/lib/remote_opam_repo.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/remote_opam_repo.ml b/_build/default/src/lib/.formatted/remote_opam_repo.ml
index 89965ce..90c4066 100644
--- a/_build/default/src/lib/remote_opam_repo.ml
+++ b/_build/default/src/lib/.formatted/remote_opam_repo.ml
@@ -1,64 +1,63 @@
-(** Maintain a local clone of a remote opam-repository at a
- user-specified path.
-
- ocaml-docs-ci reads a list of [{url, path}] pairs from
- [remotes.json] and installs one of these jobs per pair. The job
- performs a [git clone] the first time, and on every subsequent
- schedule tick [git fetch + reset --hard origin/HEAD] — so [path]
- is always a fresh mirror of the remote. Day11 profiles then
- reference [path] as a regular local-path entry; a
- [Current_git.Local] watcher elsewhere in the pipeline picks up
- the updated HEAD via inotify and re-triggers downstream work.
-
- Keeping this separate from [Day11_batch.Profile] means the profile
- schema stays local-paths-only, and [day11 batch] works off the
- same profile files without ever handling URLs. *)
+(** Maintain a local clone of a remote opam-repository at a user-specified path.
+
+ ocaml-docs-ci reads a list of [{url, path}] pairs from [remotes.json] and
+ installs one of these jobs per pair. The job performs a [git clone] the
+ first time, and on every subsequent schedule tick
+ [git fetch + reset --hard origin/HEAD] — so [path] is always a fresh mirror
+ of the remote. Day11 profiles then reference [path] as a regular local-path
+ entry; a [Current_git.Local] watcher elsewhere in the pipeline picks up the
+ updated HEAD via inotify and re-triggers downstream work.
+
+ Keeping this separate from [Day11_batch.Profile] means the profile schema
+ stays local-paths-only, and [day11 batch] works off the same profile files
+ without ever handling URLs. *)
module Op = struct
type t = unit
module Key = struct
type t = { url : string; path : Fpath.t }
+
let digest t = t.url ^ "|" ^ Fpath.to_string t.path
end
module Value = struct
(* Resolved commit SHA after the pull. *)
type t = string
+
let marshal t = t
let unmarshal t = t
end
let id = "docs-ci-remote-opam-repo"
let auto_cancel = false
- let pp f (key : Key.t) =
- Fmt.pf f "pull %s → %a" key.url Fpath.pp key.path
+ let pp f (key : Key.t) = Fmt.pf f "pull %s → %a" key.url Fpath.pp key.path
let sh_log job fmt =
- Fmt.kstr (fun s ->
- Current.Job.log job "$ %s" s;
- let cmd = ("", [| "/bin/sh"; "-c"; s |]) in
- let open Lwt.Syntax in
- let* output = Lwt_process.pread_lines cmd
- |> Lwt_stream.to_list in
- List.iter (Current.Job.log job "%s") output;
- Lwt.return (Ok (String.concat "\n" output))
- ) fmt
+ Fmt.kstr
+ (fun s ->
+ Current.Job.log job "$ %s" s;
+ let cmd = ("", [| "/bin/sh"; "-c"; s |]) in
+ let open Lwt.Syntax in
+ let* output = Lwt_process.pread_lines cmd |> Lwt_stream.to_list in
+ List.iter (Current.Job.log job "%s") output;
+ Lwt.return (Ok (String.concat "\n" output)))
+ fmt
let run_sh job fmt =
- Fmt.kstr (fun s ->
- Current.Job.log job "$ %s" s;
- let cmd = ("", [| "/bin/sh"; "-c"; s |]) in
- let open Lwt.Syntax in
- let* status = Lwt_process.exec cmd in
- match status with
- | Unix.WEXITED 0 -> Lwt.return (Ok ())
- | Unix.WEXITED n ->
- Lwt.return (Error (`Msg (Printf.sprintf
- "command exited %d: %s" n s)))
- | _ ->
- Lwt.return (Error (`Msg ("command signalled: " ^ s)))
- ) fmt
+ Fmt.kstr
+ (fun s ->
+ Current.Job.log job "$ %s" s;
+ let cmd = ("", [| "/bin/sh"; "-c"; s |]) in
+ let open Lwt.Syntax in
+ let* status = Lwt_process.exec cmd in
+ match status with
+ | Unix.WEXITED 0 -> Lwt.return (Ok ())
+ | Unix.WEXITED n ->
+ Lwt.return
+ (Error (`Msg (Printf.sprintf "command exited %d: %s" n s)))
+ | _ -> Lwt.return (Error (`Msg ("command signalled: " ^ s))))
+ fmt
let build () job (key : Key.t) =
let open Lwt.Syntax in
@@ -85,70 +84,70 @@ module Op = struct
because Fmt treats [@{...}] as a semantic-tag command
and would strip the [@{u}] git revspec from our command. *)
let** () = run_sh job "git -C %s fetch --prune origin" path in
- let cmd = Printf.sprintf
- "git -C %s symbolic-ref -q HEAD >/dev/null && \
- git -C %s merge --ff-only '@{u}' || { \
- echo \"WARNING: HEAD detached at $(git -C %s rev-parse \
- --short HEAD); not auto-advancing. Run \
- 'git -C %s checkout master' to recover.\" >&2; \
- true; }"
- path path path path in
+ let cmd =
+ Printf.sprintf
+ "git -C %s symbolic-ref -q HEAD >/dev/null && git -C %s merge \
+ --ff-only '@{u}' || { echo \"WARNING: HEAD detached at $(git -C \
+ %s rev-parse --short HEAD); not auto-advancing. Run 'git -C %s \
+ checkout master' to recover.\" >&2; true; }"
+ path path path path
+ in
run_sh job "%s" cmd
else
- run_sh job "git clone %s %s"
- (Filename.quote key.url) (Filename.quote path)
+ run_sh job "git clone %s %s" (Filename.quote key.url)
+ (Filename.quote path)
in
sh_log job "git -C %s rev-parse HEAD" path
in
- Lwt_result.map (fun output ->
- let sha = String.trim output in
- Current.Job.log job "%a @ %s" Fpath.pp key.path sha;
- sha) result
+ Lwt_result.map
+ (fun output ->
+ let sha = String.trim output in
+ Current.Job.log job "%a @ %s" Fpath.pp key.path sha;
+ sha)
+ result
end
module Cache = Current_cache.Make (Op)
-(** [maintain ~schedule ~url ~path] installs a scheduled puller that
- keeps [path] up to date with [url]. Returns the latest commit SHA
- as a [Current.t]. *)
+(** [maintain ~schedule ~url ~path] installs a scheduled puller that keeps
+ [path] up to date with [url]. Returns the latest commit SHA as a
+ [Current.t]. *)
let maintain ~schedule ~url ~path : string Current.t =
let open Current.Syntax in
- Current.component "pull %s" url |>
+ Current.component "pull %s" url
+ |>
let> () = Current.return () in
Cache.get ~schedule () Op.Key.{ url; path }
(** Same as {!maintain}, but lifts the SHA into a
- [Current_git.Commit.t Current.t]. Downstream consumers that want
- to read the commit's tree should use this instead of pairing
- {!maintain} with [Current_git.Local.head_commit] — the latter
- relies on an inotify watcher on [path/.git/], which can no-op
- silently if the pull job claims success without actually
- advancing HEAD. With this function the post-pull SHA flows
- directly through OCurrent so a no-op pull means the same
- [Commit.t] downstream, no kernel watcher in the loop. *)
+ [Current_git.Commit.t Current.t]. Downstream consumers that want to read the
+ commit's tree should use this instead of pairing {!maintain} with
+ [Current_git.Local.head_commit] — the latter relies on an inotify watcher on
+ [path/.git/], which can no-op silently if the pull job claims success
+ without actually advancing HEAD. With this function the post-pull SHA flows
+ directly through OCurrent so a no-op pull means the same [Commit.t]
+ downstream, no kernel watcher in the loop. *)
let maintain_commit ~schedule ~url ~path : Current_git.Commit.t Current.t =
let open Current.Syntax in
let+ sha = maintain ~schedule ~url ~path in
Current_git.Commit.v ~repo:path
- ~id:(Current_git.Commit_id.v
- ~repo:url ~gref:"refs/heads/master" ~hash:sha)
+ ~id:(Current_git.Commit_id.v ~repo:url ~gref:"refs/heads/master" ~hash:sha)
-(** One remote-mirror entry, passed via [--remote URL=PATH]. *)
type spec = { url : string; path : Fpath.t }
+(** One remote-mirror entry, passed via [--remote URL=PATH]. *)
-(** Parse a [URL=PATH] argument. The [=] separator is the first
- one in the string, so URLs containing [=] survive (paths
- shouldn't — but if they do, quote them per shell rules). *)
+(** Parse a [URL=PATH] argument. The [=] separator is the first one in the
+ string, so URLs containing [=] survive (paths shouldn't — but if they do,
+ quote them per shell rules). *)
let spec_of_arg s =
match String.index_opt s '=' with
- | None ->
- Error (`Msg (Printf.sprintf
- "--remote %S: expected URL=PATH" s))
+ | None -> Error (`Msg (Printf.sprintf "--remote %S: expected URL=PATH" s))
| Some i ->
- let url = String.sub s 0 i in
- let path = String.sub s (i + 1) (String.length s - i - 1) in
- if url = "" || path = "" then
- Error (`Msg (Printf.sprintf
- "--remote %S: URL and PATH must both be non-empty" s))
- else
- Ok { url; path = Fpath.v path }
+ let url = String.sub s 0 i in
+ let path = String.sub s (i + 1) (String.length s - i - 1) in
+ if url = "" || path = "" then
+ Error
+ (`Msg
+ (Printf.sprintf "--remote %S: URL and PATH must both be non-empty"
+ s))
+ else Ok { url; path = Fpath.v path }
File "src/lib/startup_diagnostics.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/startup_diagnostics.ml b/_build/default/src/lib/.formatted/startup_diagnostics.ml
index 60cf7be..f464ad6 100644
--- a/_build/default/src/lib/startup_diagnostics.ml
+++ b/_build/default/src/lib/.formatted/startup_diagnostics.ml
@@ -1,23 +1,23 @@
(** Start-of-day environment checks for the ocaml-docs-ci daemon.
- Runs once at process startup, logs anything that would prevent
- or degrade normal operation, and never raises. Each check writes
- [Logs.app] for the OK case and [Logs.warn] / [Logs.err] for
- problems — picking the level by whether the daemon will limp on
- (warn) or behave incorrectly (err).
+ Runs once at process startup, logs anything that would prevent or degrade
+ normal operation, and never raises. Each check writes [Logs.app] for the OK
+ case and [Logs.warn] / [Logs.err] for problems — picking the level by
+ whether the daemon will limp on (warn) or behave incorrectly (err).
- Visible via [docker-compose logs daemon] (or
- [docker logs <id>], or the json-file at
- [/var/lib/docker/containers/<id>/<id>-json.log]).
+ Visible via [docker-compose logs daemon] (or [docker logs <id>], or the
+ json-file at [/var/lib/docker/containers/<id>/<id>-json.log]).
Why so many checks: the things that bite are mostly environmental
(bind-mount ownership, missing helper binary, an inaccessible
/var/run/docker.sock) and the daemon manifests them deep in a
- runc/git/sqlite call several layers down. Surfacing them up front
- saves a debugging round-trip. *)
+ runc/git/sqlite call several layers down. Surfacing them up front saves a
+ debugging round-trip. *)
-let src = Logs.Src.create "ocaml-docs-ci.startup"
+let src =
+ Logs.Src.create "ocaml-docs-ci.startup"
~doc:"Startup diagnostics for the ocaml-docs-ci daemon"
+
module Log = (val Logs.src_log src)
(* ── helpers ─────────────────────────────────────────────────── *)
@@ -29,7 +29,9 @@ let stat_owner path =
with _ -> None
let writable path =
- try Unix.access path [Unix.W_OK]; true
+ try
+ Unix.access path [ Unix.W_OK ];
+ true
with Unix.Unix_error _ -> false
let exec_present prog =
@@ -37,31 +39,40 @@ let exec_present prog =
[which] isn't installed in every minimal image. *)
let path = try Sys.getenv "PATH" with Not_found -> "" in
let candidates = String.split_on_char ':' path in
- List.exists (fun dir ->
- let p = Filename.concat dir prog in
- try Unix.access p [Unix.X_OK]; true with _ -> false
- ) candidates
+ List.exists
+ (fun dir ->
+ let p = Filename.concat dir prog in
+ try
+ Unix.access p [ Unix.X_OK ];
+ true
+ with _ -> false)
+ candidates
let exec_version prog args =
- let cmd = Printf.sprintf "%s %s 2>&1"
- (Filename.quote prog) (String.concat " " args) in
+ let cmd =
+ Printf.sprintf "%s %s 2>&1" (Filename.quote prog) (String.concat " " args)
+ in
try
let ic = Unix.open_process_in cmd in
let line = try Some (input_line ic) with End_of_file -> None in
(* Drain rest so close_process_in gets a clean exit code. *)
- (try while true do ignore (input_line ic) done with End_of_file -> ());
- match Unix.close_process_in ic with
- | Unix.WEXITED 0 -> line
- | _ -> None
+ (try
+ while true do
+ ignore (input_line ic)
+ done
+ with End_of_file -> ());
+ match Unix.close_process_in ic with Unix.WEXITED 0 -> line | _ -> None
with _ -> None
let disk_free_gib path =
(* statvfs gives free blocks; multiply by f_frsize. Wrapping in a
[Sys.command] dodge so this file stays dependency-free of
extunix etc.; awk does the maths. *)
- let cmd = Printf.sprintf
- "df -BG --output=avail %s 2>/dev/null | tail -1 | tr -dc '0-9'"
- (Filename.quote path) in
+ let cmd =
+ Printf.sprintf
+ "df -BG --output=avail %s 2>/dev/null | tail -1 | tr -dc '0-9'"
+ (Filename.quote path)
+ in
try
let ic = Unix.open_process_in cmd in
let line = try input_line ic with End_of_file -> "" in
@@ -75,44 +86,48 @@ let check_identity () =
let uid = Unix.getuid () and gid = Unix.getgid () in
let euid = Unix.geteuid () and egid = Unix.getegid () in
let user = try (Unix.getpwuid uid).Unix.pw_name with Not_found -> "?" in
- Log.app (fun f -> f "running as uid=%d gid=%d (user=%s, euid=%d egid=%d)"
- uid gid user euid egid)
+ Log.app (fun f ->
+ f "running as uid=%d gid=%d (user=%s, euid=%d egid=%d)" uid gid user euid
+ egid)
let check_path_writable ~kind path =
let path_s = Fpath.to_string path in
let uid = Unix.getuid () and gid = Unix.getgid () in
match stat_owner path_s with
| None ->
- (* Not a fatal error per se — daemon will try to create it lazily.
+ (* Not a fatal error per se — daemon will try to create it lazily.
But warn so the first creation attempt isn't a surprise. *)
- Log.warn (fun f -> f "%s %a: does not exist (will be created on first use)"
- kind Fpath.pp path)
+ Log.warn (fun f ->
+ f "%s %a: does not exist (will be created on first use)" kind Fpath.pp
+ path)
| Some (o_uid, o_gid) ->
- if writable path_s then
- Log.app (fun f -> f "%s %a: ok (owner=%d:%d, writable)"
- kind Fpath.pp path o_uid o_gid)
- else
- Log.err (fun f -> f "%s %a: NOT WRITABLE — \
- daemon runs as %d:%d but path is %d:%d. \
- Fix with: sudo chown -R %d:%d %a"
- kind Fpath.pp path uid gid o_uid o_gid uid gid Fpath.pp path)
+ if writable path_s then
+ Log.app (fun f ->
+ f "%s %a: ok (owner=%d:%d, writable)" kind Fpath.pp path o_uid o_gid)
+ else
+ Log.err (fun f ->
+ f
+ "%s %a: NOT WRITABLE — daemon runs as %d:%d but path is %d:%d. \
+ Fix with: sudo chown -R %d:%d %a"
+ kind Fpath.pp path uid gid o_uid o_gid uid gid Fpath.pp path)
let check_helper ~name ~kind ~version_args ~severity =
if exec_present name then
match exec_version name version_args with
- | Some line ->
- Log.app (fun f -> f "%s %s: ok (%s)" kind name line)
+ | Some line -> Log.app (fun f -> f "%s %s: ok (%s)" kind name line)
| None ->
- Log.warn (fun f -> f "%s %s: on PATH but failed to produce a version line"
- kind name)
+ Log.warn (fun f ->
+ f "%s %s: on PATH but failed to produce a version line" kind name)
else
match severity with
| `Required ->
- Log.err (fun f -> f "%s %s: NOT FOUND on PATH — daemon will fail \
- when it needs this" kind name)
+ Log.err (fun f ->
+ f "%s %s: NOT FOUND on PATH — daemon will fail when it needs this"
+ kind name)
| `Optional ->
- Log.warn (fun f -> f "%s %s: not found on PATH (some features will \
- be degraded)" kind name)
+ Log.warn (fun f ->
+ f "%s %s: not found on PATH (some features will be degraded)" kind
+ name)
let check_docker_socket () =
(* Used by [resolve_base_digest] via [docker manifest inspect]. The
@@ -123,11 +138,15 @@ let check_docker_socket () =
if writable path then
Log.app (fun f -> f "docker socket %s: ok (writable)" path)
else
- Log.warn (fun f -> f "docker socket %s: present but not writable — \
- check the daemon's gid is in the docker group" path)
+ Log.warn (fun f ->
+ f
+ "docker socket %s: present but not writable — check the daemon's \
+ gid is in the docker group"
+ path)
else
- Log.warn (fun f -> f "docker socket %s: not present — \
- base-image rebuild paths will fail" path)
+ Log.warn (fun f ->
+ f "docker socket %s: not present — base-image rebuild paths will fail"
+ path)
(* OCurrent stores Op_build/Op_tool successes in sqlite with the
layer_dir path as part of the marshalled value. If the cache
@@ -149,8 +168,10 @@ let check_ocurrent_layer_alignment () =
Log.app (fun f -> f "ocurrent db %s: not present (first run)" db)
else if not (exec_present "sqlite3") then
Log.app (fun f ->
- f "ocurrent db %s: present, but sqlite3 not on PATH — \
- skipping cross-check against on-disk layer dirs" db)
+ f
+ "ocurrent db %s: present, but sqlite3 not on PATH — skipping \
+ cross-check against on-disk layer dirs"
+ db)
else
let cmd =
Printf.sprintf
@@ -161,87 +182,87 @@ let check_ocurrent_layer_alignment () =
try
let ic = Unix.open_process_in cmd in
let lines = ref [] in
- (try while true do lines := input_line ic :: !lines done
+ (try
+ while true do
+ lines := input_line ic :: !lines
+ done
with End_of_file -> ());
ignore (Unix.close_process_in ic);
let extract_dir line =
match String.index_opt line '"' with
| None -> None
- | Some _ ->
- (* Quick-and-dirty: pull the layer_dir field. The marshalled
+ | Some _ -> (
+ (* Quick-and-dirty: pull the layer_dir field. The marshalled
value is JSON like {"pkg":"...","hash":"...","layer_dir":"..."}.
A real json parse here would drag yojson into this module;
a substring match is enough for a sanity check. *)
- let needle = "\"layer_dir\":\"" in
- let nlen = String.length needle in
- (match String.index_from_opt line 0 '\"' with
- | None -> None
- | Some _ ->
- let rec find i =
- if i + nlen > String.length line then None
- else if String.sub line i nlen = needle then
- let start = i + nlen in
- match String.index_from_opt line start '"' with
- | None -> None
- | Some endq -> Some (String.sub line start (endq - start))
- else find (i + 1)
- in
- find 0)
+ let needle = "\"layer_dir\":\"" in
+ let nlen = String.length needle in
+ match String.index_from_opt line 0 '\"' with
+ | None -> None
+ | Some _ ->
+ let rec find i =
+ if i + nlen > String.length line then None
+ else if String.sub line i nlen = needle then
+ let start = i + nlen in
+ match String.index_from_opt line start '"' with
+ | None -> None
+ | Some endq -> Some (String.sub line start (endq - start))
+ else find (i + 1)
+ in
+ find 0)
in
let dirs = List.filter_map extract_dir !lines in
let total = List.length dirs in
if total = 0 then
Log.app (fun f ->
- f "ocurrent layer-dir check: no day11-build/tool successes \
- yet (fresh cache)")
- else begin
- let missing = List.filter
- (fun d -> not (Sys.file_exists d)) dirs in
+ f
+ "ocurrent layer-dir check: no day11-build/tool successes yet \
+ (fresh cache)")
+ else
+ let missing = List.filter (fun d -> not (Sys.file_exists d)) dirs in
let n_missing = List.length missing in
let pct = 100 * n_missing / total in
if n_missing = 0 then
Log.app (fun f ->
- f "ocurrent layer-dir check: %d/%d sampled entries point \
- at existing dirs" total total)
+ f
+ "ocurrent layer-dir check: %d/%d sampled entries point at \
+ existing dirs"
+ total total)
else if pct < 25 then
Log.warn (fun f ->
- f "ocurrent layer-dir check: %d of %d sampled entries point \
- at missing layer dirs (%d%%) — some cache eviction \
- expected, but watch for cascading rebuilds"
- n_missing total pct)
+ f
+ "ocurrent layer-dir check: %d of %d sampled entries point at \
+ missing layer dirs (%d%%) — some cache eviction expected, but \
+ watch for cascading rebuilds"
+ n_missing total pct)
else
- let example =
- match missing with
- | d :: _ -> d
- | [] -> ""
- in
+ let example = match missing with d :: _ -> d | [] -> "" in
Log.err (fun f ->
- f "ocurrent layer-dir check: %d of %d sampled entries point \
- at MISSING layer dirs (%d%%). example: %s. \
- The ocurrent db and the day11 cache are out of sync \
- — builds will report cache-hits then fail to mount. \
- Fix with: docker-compose down && \
- docker volume rm <project>_ocurrent-data && \
- docker-compose up -d"
- n_missing total pct example)
- end
+ f
+ "ocurrent layer-dir check: %d of %d sampled entries point at \
+ MISSING layer dirs (%d%%). example: %s. The ocurrent db and \
+ the day11 cache are out of sync — builds will report \
+ cache-hits then fail to mount. Fix with: docker-compose down \
+ && docker volume rm <project>_ocurrent-data && docker-compose \
+ up -d"
+ n_missing total pct example)
with _ ->
- Log.warn (fun f ->
- f "ocurrent layer-dir check: failed to read %s" db)
+ Log.warn (fun f -> f "ocurrent layer-dir check: failed to read %s" db)
let check_disk ~kind path =
match disk_free_gib (Fpath.to_string path) with
| None ->
- Log.warn (fun f -> f "%s %a: could not stat free space"
- kind Fpath.pp path)
+ Log.warn (fun f ->
+ f "%s %a: could not stat free space" kind Fpath.pp path)
| Some g when g < 20 ->
- Log.err (fun f -> f "%s %a: only %d GiB free — \
- layer cache will fill up fast" kind Fpath.pp path g)
+ Log.err (fun f ->
+ f "%s %a: only %d GiB free — layer cache will fill up fast" kind
+ Fpath.pp path g)
| Some g when g < 100 ->
- Log.warn (fun f -> f "%s %a: %d GiB free — keep an eye on it"
- kind Fpath.pp path g)
- | Some g ->
- Log.app (fun f -> f "%s %a: %d GiB free" kind Fpath.pp path g)
+ Log.warn (fun f ->
+ f "%s %a: %d GiB free — keep an eye on it" kind Fpath.pp path g)
+ | Some g -> Log.app (fun f -> f "%s %a: %d GiB free" kind Fpath.pp path g)
(* ── entry point ─────────────────────────────────────────────── *)
@@ -252,22 +273,21 @@ let run ~profile_dir ~cache_dir =
check_path_writable ~kind:"cache-dir " cache_dir;
let tmpdir = try Some (Sys.getenv "TMPDIR") with Not_found -> None in
(match tmpdir with
- | Some d -> check_path_writable ~kind:"TMPDIR " (Fpath.v d)
- | None ->
- Log.app (fun f -> f "TMPDIR unset — using default /tmp"));
+ | Some d -> check_path_writable ~kind:"TMPDIR " (Fpath.v d)
+ | None -> Log.app (fun f -> f "TMPDIR unset — using default /tmp"));
check_disk ~kind:"cache fs " cache_dir;
- check_helper ~name:"runc" ~kind:"helper"
- ~version_args:["--version"] ~severity:`Required;
- check_helper ~name:"git" ~kind:"helper"
- ~version_args:["--version"] ~severity:`Required;
- check_helper ~name:"sudo" ~kind:"helper"
- ~version_args:["--version"] ~severity:`Required;
- check_helper ~name:"docker" ~kind:"helper"
- ~version_args:["--version"] ~severity:`Optional;
- check_helper ~name:"dot" ~kind:"helper"
- ~version_args:["-V"] ~severity:`Optional;
- check_helper ~name:"rsync" ~kind:"helper"
- ~version_args:["--version"] ~severity:`Optional;
+ check_helper ~name:"runc" ~kind:"helper" ~version_args:[ "--version" ]
+ ~severity:`Required;
+ check_helper ~name:"git" ~kind:"helper" ~version_args:[ "--version" ]
+ ~severity:`Required;
+ check_helper ~name:"sudo" ~kind:"helper" ~version_args:[ "--version" ]
+ ~severity:`Required;
+ check_helper ~name:"docker" ~kind:"helper" ~version_args:[ "--version" ]
+ ~severity:`Optional;
+ check_helper ~name:"dot" ~kind:"helper" ~version_args:[ "-V" ]
+ ~severity:`Optional;
+ check_helper ~name:"rsync" ~kind:"helper" ~version_args:[ "--version" ]
+ ~severity:`Optional;
check_docker_socket ();
check_ocurrent_layer_alignment ();
Log.app (fun f -> f "── diagnostics complete ──")
File "src/lib/track.ml", line 1, characters 0-0:
diff --git a/_build/default/src/lib/track.ml b/_build/default/src/lib/.formatted/track.ml
index 060859e..61d2ef4 100644
--- a/_build/default/src/lib/track.ml
+++ b/_build/default/src/lib/.formatted/track.ml
@@ -30,13 +30,13 @@ module Track = struct
end
let pp f { Key.repo; filter; limit } =
- let limit_s = match limit with
- | None -> "all"
- | Some n -> string_of_int n
+ let limit_s =
+ match limit with None -> "all" | Some n -> string_of_int n
in
- Fmt.pf f "opam repo track (limit=%s) %a [%a]"
- limit_s Git.Commit.pp_short repo
- Fmt.(list ~sep:(any ",") string) filter
+ Fmt.pf f "opam repo track (limit=%s) %a [%a]" limit_s Git.Commit.pp_short
+ repo
+ Fmt.(list ~sep:(any ",") string)
+ filter
module Value = struct
type package_definition = { package : OpamPackage.t; digest : string }
@@ -97,7 +97,7 @@ module Track = struct
isn't a package and would crash [get_versions] when it
tries to list versions beneath it. *)
|> List.filter (fun p ->
- match Bos.OS.Dir.exists p with Ok true -> true | _ -> false)
+ match Bos.OS.Dir.exists p with Ok true -> true | _ -> false)
|> List.filter filter
|> Lwt_list.map_s (get_versions ~limit)
|> Lwt.map (fun v -> List.flatten v)
@@ -110,16 +110,21 @@ end
module LatchedBuilder (B : Current_cache.S.BUILDER) = struct
module Adaptor = struct
type t = B.t
+
let id = B.id
+
module Key = Current.String
module Value = B.Key
module Outcome = B.Value
+
let run op job _ key = B.build op job key
let pp f (_, key) = B.pp f key
let auto_cancel = B.auto_cancel
let latched = true
end
+
include Current_cache.Generic (Adaptor)
+
let get ~opkey ?schedule ctx key = run ?schedule ctx opkey key
end
@@ -143,8 +148,8 @@ module Map = OpamStd.Map.Make (struct
let to_string t = OpamPackage.to_string t.package
end)
-let v ~repo_label ~limit ~(filter : string list)
- (repo : Git.Commit.t Current.t) =
+let v ~repo_label ~limit ~(filter : string list) (repo : Git.Commit.t Current.t)
+ =
let open Current.Syntax in
(* [repo_label] distinguishes same-(filter, limit) calls that feed
from different repos — e.g. the ocaml mainline + oxcaml overlay
@@ -152,33 +157,33 @@ let v ~repo_label ~limit ~(filter : string list)
mainline. Without it, OCurrent treats the shared component as
one "instance" and errors "set to different values in the same
step" when the input commits don't match. *)
- let limit_s = match limit with
- | None -> "all"
- | Some n -> string_of_int n
- in
+ let limit_s = match limit with None -> "all" | Some n -> string_of_int n in
let reduced_filter =
- if List.length filter <= 3 then filter else
- List.take 3 filter @ ["..."]
+ if List.length filter <= 3 then filter else List.take 3 filter @ [ "..." ]
in
Current.component "Track %s (limit=%s) - %a" repo_label limit_s
- Fmt.(list string) reduced_filter
+ Fmt.(list string)
+ reduced_filter
|> let> repo in
(* opkey disambiguates at the LatchedBuilder layer too. *)
- let opkey = Printf.sprintf "track-%s-%s-%s"
- repo_label limit_s (String.concat "," filter) in
+ let opkey =
+ Printf.sprintf "track-%s-%s-%s" repo_label limit_s
+ (String.concat "," filter)
+ in
TrackCache.get ~opkey No_context { filter; repo; limit }
-(** Union multiple per-repo tracking results, with later repos'
- entries overriding earlier by [(name, version)] — mirroring
- opam's overlay resolution. *)
+(** Union multiple per-repo tracking results, with later repos' entries
+ overriding earlier by [(name, version)] — mirroring opam's overlay
+ resolution. *)
let merge (tracks : t list Current.t list) : t list Current.t =
let open Current.Syntax in
let+ lists = Current.list_seq tracks in
let table = Hashtbl.create 1024 in
- List.iter (fun per_repo ->
- List.iter (fun (pkg : t) ->
- Hashtbl.replace table pkg.package pkg
-) per_repo
- ) lists;
+ List.iter
+ (fun per_repo ->
+ List.iter
+ (fun (pkg : t) -> Hashtbl.replace table pkg.package pkg)
+ per_repo)
+ lists;
Hashtbl.fold (fun _ v acc -> v :: acc) table []
- |> List.sort (fun a b -> -(OpamPackage.compare a.package b.package))
+ |> List.sort (fun a b -> -OpamPackage.compare a.package b.package)
File "src/pipelines/docs.ml", line 1, characters 0-0:
diff --git a/_build/default/src/pipelines/docs.ml b/_build/default/src/pipelines/.formatted/docs.ml
index 614588e..a59d474 100644
--- a/_build/default/src/pipelines/docs.ml
+++ b/_build/default/src/pipelines/.formatted/docs.ml
@@ -37,18 +37,20 @@ let get_build_pool capacity =
match !build_pool with
| Some p -> p
| None ->
- let p = Current.Pool.create ~label:"day11-builds" capacity in
- build_pool := Some p;
- p
+ let p = Current.Pool.create ~label:"day11-builds" capacity in
+ build_pool := Some p;
+ p
let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
~(tracking_commits : Current_git.Commit.t Current.t list)
(ctx_current : profile_ctx Current.t) =
let open Current.Syntax in
let* (ctx : profile_ctx) = ctx_current in
- let ctx = match cpu_slots with
+ let ctx =
+ match cpu_slots with
| Some pool -> Profile_ctx.with_cpu_slots ctx pool
- | None -> ctx in
+ | None -> ctx
+ in
let profile = ctx.profile in
let env = eio_env in
ignore (Bos.OS.Dir.create ~path:true ctx.os_dir);
@@ -57,8 +59,7 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
— via [Profile_ctx.with_base_digest] — into the base layer hash,
so every dependent build rehashes when the upstream image moves. *)
let digest =
- Day11_base_digest.current
- ~schedule:base_digest_schedule
+ Day11_base_digest.current ~schedule:base_digest_schedule
~image:(Profile.base_image_tag profile)
~arch:profile.arch
in
@@ -72,11 +73,12 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
let ctx = Profile_ctx.with_base_digest ctx d in
(* After [Day11_base.ensure] succeeds the base layer is on disk;
require_base is a cheap marker-file check. *)
- let ctx = match Profile_ctx.require_base ctx with
+ let ctx =
+ match Profile_ctx.require_base ctx with
| Ok c -> c
| Error (`Msg msg) ->
- Logs.err (fun f -> f "[%s] %s" profile.name msg);
- failwith msg
+ Logs.err (fun f -> f "[%s] %s" profile.name msg);
+ failwith msg
in
let benv = ctx.benv in
@@ -86,13 +88,13 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
packages). *)
let profile_limit = Profile.track_limit profile in
let profile_filter = Profile.track_filter profile in
- let limit = match profile_limit with
+ let limit =
+ match profile_limit with
| Some _ as l -> l
| None -> Config.take_n_last_versions config
in
- let filter = match profile_filter with
- | [] -> Config.track_packages config
- | f -> f
+ let filter =
+ match profile_filter with [] -> Config.track_packages config | f -> f
in
(* Fan out [Track.v] across all of [profile.opam_repositories] and
merge. [repo_label] (the static path string, stable across
@@ -101,8 +103,7 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
profiles share the same filter+limit. *)
let tracked =
List.map2
- (fun repo_label commit ->
- Track.v ~repo_label ~limit ~filter commit)
+ (fun repo_label commit -> Track.v ~repo_label ~limit ~filter commit)
profile.opam_repositories tracking_commits
|> Track.merge
in
@@ -113,22 +114,22 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
this the solver falls back to mainline ocaml-base-compiler and
picks mainline dune/ppxlib/etc, ignoring oxcaml overlays. *)
let pinned_versions =
- List.filter_map (fun s ->
- try Some (OpamPackage.of_string s)
- with _ ->
- Logs.warn (fun m -> m "[%s] ignoring malformed pinned_versions entry %S"
- profile.name s);
- None
- ) profile.pinned_versions
+ List.filter_map
+ (fun s ->
+ try Some (OpamPackage.of_string s)
+ with _ ->
+ Logs.warn (fun m ->
+ m "[%s] ignoring malformed pinned_versions entry %S" profile.name
+ s);
+ None)
+ profile.pinned_versions
in
let solutions =
- Day11_solver.solve ~env ~np:(Config.jobs config)
- ~profile_name:profile.name
- ~repos_with_shas:ctx.repos_with_shas
- ?ocaml_version:ctx.ocaml_version
+ Day11_solver.solve ~env ~np:(Config.jobs config) ~profile_name:profile.name
+ ~repos_with_shas:ctx.repos_with_shas ?ocaml_version:ctx.ocaml_version
~pinned_versions
~cache_dir:ctx.cache_dir
- (* [opam_commit] drives the solver's re-run trigger and goes
+ (* [opam_commit] drives the solver's re-run trigger and goes
into the cache key. Pick mainline (first entry) — overlay
commits already flow through [repos_with_shas] which is
part of the same cache key, so this doesn't lose anything. *)
@@ -144,23 +145,33 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
[Day11_solution.Deps.transitive_deps] is cycle-safe (uses a
[visiting] guard) so all the doc-deps walks tolerate them. *)
let solutions, dropped =
- List.partition (fun (s : Day11_solver.solution) ->
- not (Day11_solution.Deps.has_cycle s.solve_result.build_deps))
- solutions in
- List.iter (fun (s : Day11_solver.solution) ->
- Log.warn (fun f -> f "[%s] dropping %s: solver output has dep cycle"
- profile.name (OpamPackage.to_string s.target))) dropped;
- Log.info (fun f -> f "[%s] solved %d packages (%d dropped for cycles)"
- profile.name (List.length solutions) (List.length dropped));
+ List.partition
+ (fun (s : Day11_solver.solution) ->
+ not (Day11_solution.Deps.has_cycle s.solve_result.build_deps))
+ solutions
+ in
+ List.iter
+ (fun (s : Day11_solver.solution) ->
+ Log.warn (fun f ->
+ f "[%s] dropping %s: solver output has dep cycle" profile.name
+ (OpamPackage.to_string s.target)))
+ dropped;
+ Log.info (fun f ->
+ f "[%s] solved %d packages (%d dropped for cycles)" profile.name
+ (List.length solutions) (List.length dropped));
(* 3) Build DAG — reuse the shared hash cache from the ctx. *)
- let build_solutions = List.map (fun (s : Day11_solver.solution) ->
- (s.target, s.solve_result.build_deps, s.solve_result.doc_deps)
- ) solutions in
- let nodes = Day11_opam_build.Dag.build_dag ctx.hash_cache
- ~base_hash:ctx.base.hash build_solutions in
- Log.info (fun f -> f "[%s] %d build nodes"
- profile.name (List.length nodes));
+ let build_solutions =
+ List.map
+ (fun (s : Day11_solver.solution) ->
+ (s.target, s.solve_result.build_deps, s.solve_result.doc_deps))
+ solutions
+ in
+ let nodes =
+ Day11_opam_build.Dag.build_dag ctx.hash_cache ~base_hash:ctx.base.hash
+ build_solutions
+ in
+ Log.info (fun f -> f "[%s] %d build nodes" profile.name (List.length nodes));
(* 4) Doc plan (only if this profile has an html_dir).
@@ -179,10 +190,9 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
[%\{ocaml-config:share\}%] (inside [ocaml.X.Y]'s build) yields an
empty string. *)
let snapshot_dir =
- Day11_profile_ctx_loader.snapshot_dir_of
- ~cache_dir:ctx.cache_dir
- ~profile_name:profile.name
- ctx.repos_with_shas in
+ Day11_profile_ctx_loader.snapshot_dir_of ~cache_dir:ctx.cache_dir
+ ~profile_name:profile.name ctx.repos_with_shas
+ in
(* NB: we deliberately do NOT mount a full merged opam-repository at
[/home/opam/.opam/repo/default]. Each build mounts a per-package
slice there (Container_backend.build, from [~opam_repositories]),
@@ -191,18 +201,22 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
shadowed that slice and made opam canonicalise/scan all ~18k
packages on every switch-state load — several seconds per node. *)
let opam_build_mnt =
- match Day11_opam_build.Base.opam_build_mount
- ~cache_dir:ctx.cache_dir
- ?opam_build_repo:(Option.map Fpath.v profile.opam_build_repo)
- () with
- | Some m -> [ m ] | None -> []
+ match
+ Day11_opam_build.Base.opam_build_mount ~cache_dir:ctx.cache_dir
+ ?opam_build_repo:(Option.map Fpath.v profile.opam_build_repo)
+ ()
+ with
+ | Some m -> [ m ]
+ | None -> []
in
let doc_mounts = opam_build_mnt in
let build_mounts = opam_build_mnt in
let opam_repos_fpath = List.map Fpath.v profile.opam_repositories in
- let target_solutions = List.map (fun (s : Day11_solver.solution) ->
- (s.target, s.solve_result)
- ) solutions in
+ let target_solutions =
+ List.map
+ (fun (s : Day11_solver.solution) -> (s.target, s.solve_result))
+ solutions
+ in
(* Real blessing: run the same [compute_blessings] the day11 CLI
uses, so the per-build [blessed] flag written to history reflects
the canonical universe choice (maximise deps_count, then
@@ -210,9 +224,11 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
lands as [blessed:false], and the GUI shows "0 blessed builds"
even for latest-only profiles where one universe per package is
expected to be blessed. *)
- let blessing_input = List.map
- (fun (t, (r : Day11_solution.Solve_result.t)) -> (t, r.build_deps))
- target_solutions in
+ let blessing_input =
+ List.map
+ (fun (t, (r : Day11_solution.Solve_result.t)) -> (t, r.build_deps))
+ target_solutions
+ in
let blessing_maps = Day11_batch.Blessing.compute_blessings blessing_input in
(* Set up [run_log] and [recorder] before [plan_doc_dag], so the
dispatch wrapped inside [doc_plan.build_one] can record outcomes
@@ -224,67 +240,79 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
ignore (Bos.OS.Dir.create ~path:true packages_dir);
Day11_lib.Run_log.set_log_base_dir (Fpath.to_string snapshot_dir);
let run_log = Day11_lib.Run_log.start_run () in
- let recorder = Day11_batch.Recorder.create
- ~env ~os_dir:ctx.os_dir ~packages_dir
- ~blessing_maps ~run_log in
+ let recorder =
+ Day11_batch.Recorder.create ~env ~os_dir:ctx.os_dir ~packages_dir
+ ~blessing_maps ~run_log
+ in
let on_pkg_complete node ~success =
- Day11_batch.Recorder.record_build recorder node ~success in
+ Day11_batch.Recorder.record_build recorder node ~success
+ in
let on_doc_complete node ~success =
- Day11_batch.Recorder.record_doc recorder node ~success in
+ Day11_batch.Recorder.record_doc recorder node ~success
+ in
(* [plan_doc_dag] forks 9+ fibers (driver + per-compiler odoc),
each running a [day11-solver-worker] subprocess. Subprocess
awaits go through [Sys.Run.run] which yields on socket I/O,
so under [Lwt_eio.with_event_loop] the cohttp web server gets
scheduler cycles between yields and stays responsive. *)
- let doc_plan = match profile.html_dir with
+ let doc_plan =
+ match profile.html_dir with
| None -> None
| Some _ ->
- Eio.Switch.run @@ fun plan_sw ->
- Day11_doc.Generate.plan_doc_dag ~sw:plan_sw env ctx
- ~mounts:doc_mounts
- ~build_one:(fun node ->
- Eio.Switch.run @@ fun sw ->
- match Day11_opam_build.Build_layer.build ~sw env benv
- ~opam_repositories:opam_repos_fpath
- ~mounts:build_mounts node () with
- | Day11_opam_build.Types.Success _ -> true
- | _ -> false)
- ~on_pkg_complete ~on_doc_complete
- ~snapshot_dir
- ~nodes
- ~solutions:target_solutions ~blessing_maps ()
+ Eio.Switch.run @@ fun plan_sw ->
+ Day11_doc.Generate.plan_doc_dag ~sw:plan_sw env ctx ~mounts:doc_mounts
+ ~build_one:(fun node ->
+ Eio.Switch.run @@ fun sw ->
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv
+ ~opam_repositories:opam_repos_fpath ~mounts:build_mounts node ()
+ with
+ | Day11_opam_build.Types.Success _ -> true
+ | _ -> false)
+ ~on_pkg_complete ~on_doc_complete ~snapshot_dir ~nodes
+ ~solutions:target_solutions ~blessing_maps ()
in
- let all_dag_nodes = match doc_plan with
+ let all_dag_nodes =
+ match doc_plan with
| Some plan ->
- let nb, nt, nc, nd, nl = List.fold_left (fun (b, t, c, d, l) n ->
- match plan.node_kind n with
- | Day11_doc.Generate.Build -> (b+1, t, c, d, l)
- | Tool -> (b, t+1, c, d, l)
- | Compile -> (b, t, c+1, d, l)
- | Doc_all -> (b, t, c, d+1, l)
- | Link -> (b, t, c, d, l+1)
- ) (0, 0, 0, 0, 0) plan.all_nodes in
- Log.info (fun f -> f "[%s] doc DAG: %d total nodes \
- (build=%d tool=%d compile=%d doc=%d link=%d)"
- profile.name (List.length plan.all_nodes) nb nt nc nd nl);
- plan.all_nodes
+ let nb, nt, nc, nd, nl =
+ List.fold_left
+ (fun (b, t, c, d, l) n ->
+ match plan.node_kind n with
+ | Day11_doc.Generate.Build -> (b + 1, t, c, d, l)
+ | Tool -> (b, t + 1, c, d, l)
+ | Compile -> (b, t, c + 1, d, l)
+ | Doc_all -> (b, t, c, d + 1, l)
+ | Link -> (b, t, c, d, l + 1))
+ (0, 0, 0, 0, 0) plan.all_nodes
+ in
+ Log.info (fun f ->
+ f
+ "[%s] doc DAG: %d total nodes (build=%d tool=%d compile=%d \
+ doc=%d link=%d)"
+ profile.name
+ (List.length plan.all_nodes)
+ nb nt nc nd nl);
+ plan.all_nodes
| None -> nodes
in
let dispatch : Eio_unix.Stdenv.base -> Day11_opam_layer.Build.t -> bool =
match doc_plan with
| Some plan ->
- fun _env node ->
- Eio.Switch.run @@ fun sw -> plan.build_one ~sw _env node
- | None ->
- fun _env node ->
- Eio.Switch.run @@ fun sw ->
- match Day11_opam_build.Build_layer.build ~sw _env benv
- ~opam_repositories:opam_repos_fpath
- ~mounts:build_mounts node () with
- | Day11_opam_build.Types.Success _ -> true
- | _ -> false
+ fun _env node ->
+ Eio.Switch.run @@ fun sw -> plan.build_one ~sw _env node
+ | None -> (
+ fun _env node ->
+ Eio.Switch.run @@ fun sw ->
+ match
+ Day11_opam_build.Build_layer.build ~sw _env benv
+ ~opam_repositories:opam_repos_fpath ~mounts:build_mounts node ()
+ with
+ | Day11_opam_build.Types.Success _ -> true
+ | _ -> false)
in
- let node_kind = match doc_plan with
+ let node_kind =
+ match doc_plan with
| Some plan -> plan.node_kind
| None -> fun _ -> Day11_doc.Generate.Build
in
@@ -292,12 +320,14 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
(* Persist the planned-node counters so mid-run CLIs
([day11 status / results / failures]) can report a denominator
via [Day11_batch.Live_view]. *)
- let count_kind kind = match doc_plan with
- | None -> if kind = Day11_doc.Generate.Build
- then List.length nodes else 0
- | Some plan -> List.fold_left (fun acc n ->
- if plan.node_kind n = kind then acc + 1 else acc)
- 0 plan.all_nodes in
+ let count_kind kind =
+ match doc_plan with
+ | None -> if kind = Day11_doc.Generate.Build then List.length nodes else 0
+ | Some plan ->
+ List.fold_left
+ (fun acc n -> if plan.node_kind n = kind then acc + 1 else acc)
+ 0 plan.all_nodes
+ in
Day11_lib.Run_log.write_doc_dag run_log
~n_build:(count_kind Day11_doc.Generate.Build)
~n_tool:(count_kind Day11_doc.Generate.Tool)
@@ -305,34 +335,36 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
~n_doc_all:(count_kind Day11_doc.Generate.Doc_all)
~n_link:(count_kind Day11_doc.Generate.Link);
let node_cache : (string, Day11_prep.t Current.t) Hashtbl.t =
- Hashtbl.create (List.length all_dag_nodes) in
+ Hashtbl.create (List.length all_dag_nodes)
+ in
let rec make_node (dag_node : Day11_opam_layer.Build.t) =
match Hashtbl.find_opt node_cache dag_node.hash with
| Some existing -> existing
| None ->
- let dep_currents = List.map make_node dag_node.deps in
- let deps = Current.list_seq dep_currents in
- let kind = node_kind dag_node in
- let label = match kind with
- | Day11_doc.Generate.Build -> "build"
- | Tool -> "tool"
- | Compile -> "compile"
- | Doc_all -> "doc"
- | Link -> "link"
- in
- (* Plain wiring — no [Current.catch], no synthesised fallback.
+ let dep_currents = List.map make_node dag_node.deps in
+ let deps = Current.list_seq dep_currents in
+ let kind = node_kind dag_node in
+ let label =
+ match kind with
+ | Day11_doc.Generate.Build -> "build"
+ | Tool -> "tool"
+ | Compile -> "compile"
+ | Doc_all -> "doc"
+ | Link -> "link"
+ in
+ (* Plain wiring — no [Current.catch], no synthesised fallback.
Recording is handled at dispatch time (inside [doc_plan]'s
[build_one] via [on_pkg_complete]/[on_doc_complete]), so when
a dep is Error the entire subtree cascades to Error in the
OCurrent graph and dispatch is never invoked. Cascade
attribution is recoverable from [<snapshot_dir>/dag.json] +
the per-package history. *)
- let node =
- Day11_prep.run_node ~env ~os_dir:ctx.os_dir ~pool ~dispatch
- ~label ~profile_name:profile.name ~dag_node ~deps ()
- in
- Hashtbl.replace node_cache dag_node.hash node;
- node
+ let node =
+ Day11_prep.run_node ~env ~os_dir:ctx.os_dir ~pool ~dispatch ~label
+ ~profile_name:profile.name ~dag_node ~deps ()
+ in
+ Hashtbl.replace node_cache dag_node.hash node;
+ node
in
let all_nodes = List.map make_node all_dag_nodes in
(* Collapse the build+doc subtree into a single node in the
@@ -349,8 +381,7 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
[make_node] call wires its parent's deps to the un-caught
[node] — caught only in this final aggregation. *)
let collapsed_builds =
- Current.collapse
- ~key:"profile-builds" ~value:profile.name
+ Current.collapse ~key:"profile-builds" ~value:profile.name
~input:ctx_current
(Current.list_seq (List.map Current.catch all_nodes))
in
@@ -359,8 +390,7 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
(* Status regen: history.jsonl is already up to date (incremental),
this just re-derives [status.json] from it. Triggered each time
[list_seq] re-evaluates. *)
- Day11_batch.Summary.generate_status
- ~snapshot_dir ~packages_dir
+ Day11_batch.Summary.generate_status ~snapshot_dir ~packages_dir
~run_id:(Day11_lib.Run_log.get_id run_log);
()
in
@@ -372,10 +402,12 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
match doc_plan with
| None -> builds
| Some plan ->
- Current.all
- [ builds;
- Epoch_promote.promote ~base_dir:plan.epoch_base
- ~epoch_hash:plan.epoch_hash ]
+ Current.all
+ [
+ builds;
+ Epoch_promote.promote ~base_dir:plan.epoch_base
+ ~epoch_hash:plan.epoch_hash;
+ ]
(* Fan out across profiles: each profile gets its own sub-pipeline
composed under [Current.all]. Profiles with the same os_dir share
@@ -386,16 +418,15 @@ let v_for_profile ~config ~eio_env ~cache_dir:_ ?cpu_slots
live [Current_git] polling of its [opam_repositories] — so changes
to any repo (remote or local) invalidate the solver cache. See
[Day11_profile_ctx_loader]. *)
-let v ~config ~eio_env ~cache_dir ~profiles ~remote_commits
- ?cpu_slots () =
+let v ~config ~eio_env ~cache_dir ~profiles ~remote_commits ?cpu_slots () =
let sub_pipelines =
- List.map (fun profile ->
- let resolved =
- Day11_profile_ctx_loader.resolve ~remote_commits
- ~cache_dir profile in
- v_for_profile ~config ~eio_env ~cache_dir ?cpu_slots
- ~tracking_commits:resolved.tracking_commits
- resolved.ctx
- ) profiles
+ List.map
+ (fun profile ->
+ let resolved =
+ Day11_profile_ctx_loader.resolve ~remote_commits ~cache_dir profile
+ in
+ v_for_profile ~config ~eio_env ~cache_dir ?cpu_slots
+ ~tracking_commits:resolved.tracking_commits resolved.ctx)
+ profiles
in
Current.all sub_pipelines
File "day11/layer/cli/layer_cli.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/layer/cli/layer_cli.ml b/_build/default/day11/layer/cli/.formatted/layer_cli.ml
index ac4af28..7738018 100644
--- a/_build/default/day11/layer/cli/layer_cli.ml
+++ b/_build/default/day11/layer/cli/.formatted/layer_cli.ml
@@ -1,13 +1,11 @@
(** Low-level layer cache inspection tool.
- Uses only the day11_layer library — no opam, no solver, no build
- pipeline. Reads layer.json files and lists directory contents
- directly, without interpreting any domain-specific sidecar
- (build.json, doc.json, etc.).
+ Uses only the day11_layer library — no opam, no solver, no build pipeline.
+ Reads layer.json files and lists directory contents directly, without
+ interpreting any domain-specific sidecar (build.json, doc.json, etc.).
- For domain-aware inspection (package names, phase classification)
- use a higher-level tool that depends on the appropriate domain
- library. *)
+ For domain-aware inspection (package names, phase classification) use a
+ higher-level tool that depends on the appropriate domain library. *)
open Cmdliner
module L = Day11_layer
@@ -25,13 +23,12 @@ let status_of (m : L.Meta.t) =
(** Short hash for display. *)
let short h = if String.length h >= 12 then String.sub h 0 12 else h
-let load_meta env layer_dir =
- L.Meta.load env Fpath.(layer_dir / "layer.json")
- (* layer_dir comes from fold_layers which walks the filesystem
+let load_meta env layer_dir = L.Meta.load env Fpath.(layer_dir / "layer.json")
+(* layer_dir comes from fold_layers which walks the filesystem
directly — it doesn't have a hash, so we can't use Layer.t here *)
-(** List every non-layer-core file in the layer directory. Used to
- show what sidecars etc. are present. *)
+(** List every non-layer-core file in the layer directory. Used to show what
+ sidecars etc. are present. *)
let list_extras env layer_dir =
let core = [ "layer.json"; "layer.log"; "last_used"; "fs" ] in
try
@@ -43,10 +40,12 @@ let list_extras env layer_dir =
(** Walk all layer directories under [os_dir] and apply [f]. *)
let fold_layers env os_dir init f =
L.Scan.list_layers env os_dir
- |> List.fold_left (fun acc (name, layer_dir) ->
- match load_meta env layer_dir with
- | Ok meta -> f acc name layer_dir meta
- | Error _ -> acc) init
+ |> List.fold_left
+ (fun acc (name, layer_dir) ->
+ match load_meta env layer_dir with
+ | Ok meta -> f acc name layer_dir meta
+ | Error _ -> acc)
+ init
(** Check whether a named file exists in a layer dir. *)
let has_file env layer_dir name =
@@ -57,77 +56,84 @@ let has_file env layer_dir name =
let cmd_list env os_dir status has limit sort_lru =
let os_dir = fpath os_dir in
let matches _name layer_dir (m : L.Meta.t) =
- (match status with None -> true | Some s -> status_of m = s) &&
- (match has with
- | [] -> true
- | files -> List.for_all (has_file env layer_dir) files)
+ (match status with None -> true | Some s -> status_of m = s)
+ &&
+ match has with
+ | [] -> true
+ | files -> List.for_all (has_file env layer_dir) files
in
- let entries = fold_layers env os_dir [] (fun acc name layer_dir m ->
- if matches name layer_dir m
- then (name, layer_dir, m, L.Last_used.get env layer_dir) :: acc
- else acc)
+ let entries =
+ fold_layers env os_dir [] (fun acc name layer_dir m ->
+ if matches name layer_dir m then
+ (name, layer_dir, m, L.Last_used.get env layer_dir) :: acc
+ else acc)
in
let entries =
if sort_lru then
- List.sort (fun (_, _, _, a) (_, _, _, b) ->
- let av = match a with Some t -> t | None -> 0.0 in
- let bv = match b with Some t -> t | None -> 0.0 in
- compare av bv) entries
+ List.sort
+ (fun (_, _, _, a) (_, _, _, b) ->
+ let av = match a with Some t -> t | None -> 0.0 in
+ let bv = match b with Some t -> t | None -> 0.0 in
+ compare av bv)
+ entries
else
- List.sort (fun (_, _, a, _) (_, _, b, _) ->
- String.compare a.L.Meta.created_at b.L.Meta.created_at)
+ List.sort
+ (fun (_, _, a, _) (_, _, b, _) ->
+ String.compare a.L.Meta.created_at b.L.Meta.created_at)
entries
in
let n_total = List.length entries in
- let entries = match limit with
+ let entries =
+ match limit with
| Some n when n > 0 ->
- let rec take k = function
- | [] -> []
- | _ when k = 0 -> []
- | x :: xs -> x :: take (k - 1) xs
- in
- take n entries
+ let rec take k = function
+ | [] -> []
+ | _ when k = 0 -> []
+ | x :: xs -> x :: take (k - 1) xs
+ in
+ take n entries
| _ -> entries
in
let fmt_lru = function
| None -> "(never)"
| Some t ->
- let tm = Unix.gmtime t in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02d"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min tm.tm_sec
+ let tm = Unix.gmtime t in
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02d" (tm.tm_year + 1900)
+ (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
in
let date_col_label = if sort_lru then "LAST USED" else "CREATED" in
- Printf.printf "%-14s %-8s %-19s %-8s %s\n"
- "HASH" "STATUS" date_col_label "DISK" "EXTRA FILES";
- Printf.printf "%-14s %-8s %-19s %-8s %s\n"
- (String.make 12 '-') (String.make 8 '-')
- (String.make 19 '-') (String.make 8 '-') (String.make 30 '-');
- List.iter (fun (name, layer_dir, (m : L.Meta.t), lru) ->
- let hash = match String.index_opt name '-' with
- | Some i -> String.sub name (i + 1) (String.length name - i - 1)
- | None -> name
- in
- let date_col =
- if sort_lru then fmt_lru lru
- else if String.length m.created_at >= 19
- then String.sub m.created_at 0 19 else m.created_at
- in
- let extras = list_extras env layer_dir in
- let extras_s =
- if extras = [] then "(none)"
- else String.concat " " extras
- in
- let disk_s =
- if m.disk_usage >= 1_000_000 then
- Printf.sprintf "%dM" (m.disk_usage / 1_000_000)
- else if m.disk_usage >= 1_000 then
- Printf.sprintf "%dK" (m.disk_usage / 1_000)
- else Printf.sprintf "%dB" m.disk_usage
- in
- Printf.printf "%-14s %-8s %-19s %-8s %s\n"
- (short hash) (status_of m) date_col disk_s extras_s
- ) entries;
+ Printf.printf "%-14s %-8s %-19s %-8s %s\n" "HASH" "STATUS" date_col_label
+ "DISK" "EXTRA FILES";
+ Printf.printf "%-14s %-8s %-19s %-8s %s\n" (String.make 12 '-')
+ (String.make 8 '-') (String.make 19 '-') (String.make 8 '-')
+ (String.make 30 '-');
+ List.iter
+ (fun (name, layer_dir, (m : L.Meta.t), lru) ->
+ let hash =
+ match String.index_opt name '-' with
+ | Some i -> String.sub name (i + 1) (String.length name - i - 1)
+ | None -> name
+ in
+ let date_col =
+ if sort_lru then fmt_lru lru
+ else if String.length m.created_at >= 19 then
+ String.sub m.created_at 0 19
+ else m.created_at
+ in
+ let extras = list_extras env layer_dir in
+ let extras_s =
+ if extras = [] then "(none)" else String.concat " " extras
+ in
+ let disk_s =
+ if m.disk_usage >= 1_000_000 then
+ Printf.sprintf "%dM" (m.disk_usage / 1_000_000)
+ else if m.disk_usage >= 1_000 then
+ Printf.sprintf "%dK" (m.disk_usage / 1_000)
+ else Printf.sprintf "%dB" m.disk_usage
+ in
+ Printf.printf "%-14s %-8s %-19s %-8s %s\n" (short hash) (status_of m)
+ date_col disk_s extras_s)
+ entries;
Printf.printf "\n(showing %d of %d layers)\n" (List.length entries) n_total;
0
@@ -136,87 +142,92 @@ let cmd_list env os_dir status has limit sort_lru =
let find_layer_by_prefix env os_dir prefix =
L.Scan.list_layers env os_dir
|> List.filter_map (fun (name, layer_dir) ->
- let h = match String.index_opt name '-' with
- | Some i -> String.sub name (i + 1) (String.length name - i - 1)
- | None -> name
- in
- if String.length h >= String.length prefix
- && String.sub h 0 (String.length prefix) = prefix
- then Some (name, layer_dir)
- else None)
+ let h =
+ match String.index_opt name '-' with
+ | Some i -> String.sub name (i + 1) (String.length name - i - 1)
+ | None -> name
+ in
+ if
+ String.length h >= String.length prefix
+ && String.sub h 0 (String.length prefix) = prefix
+ then Some (name, layer_dir)
+ else None)
let with_resolved_layer env os_dir hash_prefix f =
let os_dir = fpath os_dir in
match find_layer_by_prefix env os_dir hash_prefix with
| [] ->
- Printf.eprintf "No layer with hash prefix %s\n" hash_prefix; 1
+ Printf.eprintf "No layer with hash prefix %s\n" hash_prefix;
+ 1
| _ :: _ :: _ as matches ->
- Printf.eprintf "Ambiguous prefix %s, matches:\n" hash_prefix;
- List.iter (fun (n, _) -> Printf.eprintf " %s\n" n) matches;
- 2
+ Printf.eprintf "Ambiguous prefix %s, matches:\n" hash_prefix;
+ List.iter (fun (n, _) -> Printf.eprintf " %s\n" n) matches;
+ 2
| [ (name, layer_dir) ] -> f os_dir name layer_dir
let cmd_show env os_dir hash_prefix =
with_resolved_layer env os_dir hash_prefix @@ fun _os_dir name layer_dir ->
match load_meta env layer_dir with
| Error (`Msg e) ->
- Printf.eprintf "%s: %s\n" name e; 1
+ Printf.eprintf "%s: %s\n" name e;
+ 1
| Ok m ->
- Printf.printf "Layer: %s\n" name;
- Printf.printf "Path: %s\n" (Fpath.to_string layer_dir);
- Printf.printf "Status: %s (exit %d)\n" (status_of m) m.exit_status;
- Printf.printf "Created: %s\n" m.created_at;
- (match L.Last_used.get env layer_dir with
- | Some t ->
- let tm = Unix.gmtime t in
- Printf.printf "Last used: %04d-%02d-%02dT%02d:%02d:%02dZ\n"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min tm.tm_sec
- | None -> Printf.printf "Last used: (never recorded)\n");
- Printf.printf "Base: %s\n" m.base_hash;
- Printf.printf "UID/GID: %d:%d\n" m.uid m.gid;
- Printf.printf "Disk: %d bytes\n" m.disk_usage;
- (match m.failed_dep with
- | Some d -> Printf.printf "Failed dep: %s\n" d
- | None -> ());
- Printf.printf "\nParent layers (%d):\n" (List.length m.parent_hashes);
- List.iter (fun h -> Printf.printf " %s\n" (short h)) m.parent_hashes;
- let extras = list_extras env layer_dir in
- List.iter (fun f ->
- let p = Fpath.(layer_dir / f) in
- let p_ep = Eio.Path.(env#fs / Fpath.to_string p) in
- Printf.printf "\nSidecar: %s\n" f;
- match
- try Ok (Yojson.Safe.from_string (Eio.Path.load p_ep))
- with exn -> Error exn
- with
- | Ok json ->
- let pretty = Yojson.Safe.pretty_to_string json in
- (* Indent each line by two spaces for visual nesting. *)
- let lines = String.split_on_char '\n' pretty in
- List.iter (fun line -> Printf.printf " %s\n" line) lines
- | Error exn ->
- let size =
- try Optint.Int63.to_int
- (Eio.Path.stat ~follow:true p_ep).size
- with _ -> -1
- in
- Printf.printf " (not valid JSON: %s, %d bytes)\n"
- (Printexc.to_string exn) size
- ) extras;
- if m.timing <> [] then begin
- Printf.printf "\nTiming (s):\n";
- List.iter (fun (tname, secs) ->
- Printf.printf " %-16s %.3f\n" (tname ^ ":") secs
- ) m.timing
- end;
- 0
+ Printf.printf "Layer: %s\n" name;
+ Printf.printf "Path: %s\n" (Fpath.to_string layer_dir);
+ Printf.printf "Status: %s (exit %d)\n" (status_of m) m.exit_status;
+ Printf.printf "Created: %s\n" m.created_at;
+ (match L.Last_used.get env layer_dir with
+ | Some t ->
+ let tm = Unix.gmtime t in
+ Printf.printf "Last used: %04d-%02d-%02dT%02d:%02d:%02dZ\n"
+ (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min
+ tm.tm_sec
+ | None -> Printf.printf "Last used: (never recorded)\n");
+ Printf.printf "Base: %s\n" m.base_hash;
+ Printf.printf "UID/GID: %d:%d\n" m.uid m.gid;
+ Printf.printf "Disk: %d bytes\n" m.disk_usage;
+ (match m.failed_dep with
+ | Some d -> Printf.printf "Failed dep: %s\n" d
+ | None -> ());
+ Printf.printf "\nParent layers (%d):\n" (List.length m.parent_hashes);
+ List.iter (fun h -> Printf.printf " %s\n" (short h)) m.parent_hashes;
+ let extras = list_extras env layer_dir in
+ List.iter
+ (fun f ->
+ let p = Fpath.(layer_dir / f) in
+ let p_ep = Eio.Path.(env#fs / Fpath.to_string p) in
+ Printf.printf "\nSidecar: %s\n" f;
+ match
+ try Ok (Yojson.Safe.from_string (Eio.Path.load p_ep))
+ with exn -> Error exn
+ with
+ | Ok json ->
+ let pretty = Yojson.Safe.pretty_to_string json in
+ (* Indent each line by two spaces for visual nesting. *)
+ let lines = String.split_on_char '\n' pretty in
+ List.iter (fun line -> Printf.printf " %s\n" line) lines
+ | Error exn ->
+ let size =
+ try Optint.Int63.to_int (Eio.Path.stat ~follow:true p_ep).size
+ with _ -> -1
+ in
+ Printf.printf " (not valid JSON: %s, %d bytes)\n"
+ (Printexc.to_string exn) size)
+ extras;
+ if m.timing <> [] then (
+ Printf.printf "\nTiming (s):\n";
+ List.iter
+ (fun (tname, secs) ->
+ Printf.printf " %-16s %.3f\n" (tname ^ ":") secs)
+ m.timing);
+ 0
(* ── tree ────────────────────────────────────────────────────────── *)
let cmd_tree env os_dir hash_prefix =
with_resolved_layer env os_dir hash_prefix @@ fun os_dir name _layer_dir ->
- let full_hash = match String.index_opt name '-' with
+ let full_hash =
+ match String.index_opt name '-' with
| Some i -> String.sub name (i + 1) (String.length name - i - 1)
| None -> name
in
@@ -226,24 +237,21 @@ let cmd_tree env os_dir hash_prefix =
let layer_dir = Fpath.(os_dir / dname) in
if Hashtbl.mem visited dname then
Printf.printf "%s%s (already shown)\n" prefix dname
- else begin
+ else (
Hashtbl.add visited dname ();
match load_meta env layer_dir with
- | Error _ ->
- Printf.printf "%s%s (no layer.json)\n" prefix dname
+ | Error _ -> Printf.printf "%s%s (no layer.json)\n" prefix dname
| Ok m ->
- let extras = list_extras env layer_dir in
- let tag =
- if extras = [] then ""
- else " [" ^ String.concat " " extras ^ "]"
- in
- Printf.printf "%s%s %s%s\n"
- prefix dname (status_of m) tag;
- List.iter (fun h ->
- let dep_name = "build-" ^ short h in
- walk (depth + 1) dep_name
- ) m.parent_hashes
- end
+ let extras = list_extras env layer_dir in
+ let tag =
+ if extras = [] then "" else " [" ^ String.concat " " extras ^ "]"
+ in
+ Printf.printf "%s%s %s%s\n" prefix dname (status_of m) tag;
+ List.iter
+ (fun h ->
+ let dep_name = "build-" ^ short h in
+ walk (depth + 1) dep_name)
+ m.parent_hashes)
in
walk 0 ("build-" ^ short full_hash);
0
@@ -255,28 +263,29 @@ let cmd_stats env os_dir =
let by_status = Hashtbl.create 4 in
let by_extra_set = Hashtbl.create 8 in
let total_disk = ref 0 in
- let n = fold_layers env os_dir 0 (fun acc _ layer_dir m ->
- let st = status_of m in
- let cur = try Hashtbl.find by_status st with Not_found -> 0 in
- Hashtbl.replace by_status st (cur + 1);
- let key = String.concat " " (list_extras env layer_dir) in
- let key = if key = "" then "(none)" else key in
- let cur2 = try Hashtbl.find by_extra_set key with Not_found -> 0 in
- Hashtbl.replace by_extra_set key (cur2 + 1);
- total_disk := !total_disk + m.disk_usage;
- acc + 1)
+ let n =
+ fold_layers env os_dir 0 (fun acc _ layer_dir m ->
+ let st = status_of m in
+ let cur = try Hashtbl.find by_status st with Not_found -> 0 in
+ Hashtbl.replace by_status st (cur + 1);
+ let key = String.concat " " (list_extras env layer_dir) in
+ let key = if key = "" then "(none)" else key in
+ let cur2 = try Hashtbl.find by_extra_set key with Not_found -> 0 in
+ Hashtbl.replace by_extra_set key (cur2 + 1);
+ total_disk := !total_disk + m.disk_usage;
+ acc + 1)
in
Printf.printf "Total layers: %d\n" n;
- Printf.printf "Total disk: %d bytes (%.1f GB)\n"
- !total_disk (float_of_int !total_disk /. 1e9);
+ Printf.printf "Total disk: %d bytes (%.1f GB)\n" !total_disk
+ (float_of_int !total_disk /. 1e9);
Printf.printf "\nBy status:\n";
- Hashtbl.iter (fun k v ->
- Printf.printf " %-10s %d\n" k v) by_status;
+ Hashtbl.iter (fun k v -> Printf.printf " %-10s %d\n" k v) by_status;
Printf.printf "\nBy extra-file set (i.e. which sidecars are present):\n";
let entries = Hashtbl.fold (fun k v acc -> (k, v) :: acc) by_extra_set [] in
let entries = List.sort (fun (_, a) (_, b) -> compare b a) entries in
- List.iter (fun (key, count) ->
- Printf.printf " %-40s %d\n" key count) entries;
+ List.iter
+ (fun (key, count) -> Printf.printf " %-40s %d\n" key count)
+ entries;
0
(* ── log ─────────────────────────────────────────────────────────── *)
@@ -289,27 +298,32 @@ let cmd_log env os_dir hash_prefix =
try Ok (Eio.Path.load Eio.Path.(env#fs / Fpath.to_string lp))
with exn -> Error (Printexc.to_string exn)
with
- | Ok content -> print_string content; 0
- | Error e -> Printf.eprintf "%s\n" e; 1
+ | Ok content ->
+ print_string content;
+ 0
+ | Error e ->
+ Printf.eprintf "%s\n" e;
+ 1
(* ── CLI wiring ──────────────────────────────────────────────────── *)
let os_dir_term =
- let doc = "Path to the OS-specific cache directory containing build-* \
- subdirectories" in
- Arg.(required & opt (some string) None
- & info [ "os-dir" ] ~docv:"DIR" ~doc)
+ let doc =
+ "Path to the OS-specific cache directory containing build-* subdirectories"
+ in
+ Arg.(required & opt (some string) None & info [ "os-dir" ] ~docv:"DIR" ~doc)
let status_term =
let doc = "Filter by status (ok, fail, cascade)" in
- Arg.(value & opt (some string) None
- & info [ "status"; "s" ] ~docv:"STATUS" ~doc)
+ Arg.(
+ value & opt (some string) None & info [ "status"; "s" ] ~docv:"STATUS" ~doc)
let has_term =
- let doc = "Filter to layers that have a file of this name in their \
- directory. Repeatable — all specified files must be \
- present. Use e.g. [--has build.json] to find opam build \
- layers, [--has doc.json] for doc layers." in
+ let doc =
+ "Filter to layers that have a file of this name in their directory. \
+ Repeatable — all specified files must be present. Use e.g. [--has \
+ build.json] to find opam build layers, [--has doc.json] for doc layers."
+ in
Arg.(value & opt_all string [] & info [ "has" ] ~docv:"FILE" ~doc)
let limit_term =
@@ -321,42 +335,57 @@ let sort_lru_term =
Arg.(value & flag & info [ "sort-by-lru"; "lru" ] ~doc)
let hash_term =
- Arg.(required & pos 0 (some string) None
- & info [] ~docv:"HASH" ~doc:"Layer hash (or prefix)")
+ Arg.(
+ required
+ & pos 0 (some string) None
+ & info [] ~docv:"HASH" ~doc:"Layer hash (or prefix)")
let build_main env =
let list_cmd =
let info = Cmd.info "list" ~doc:"List layers in the cache" in
- Cmd.v info Term.(const (cmd_list env) $ os_dir_term $ status_term
- $ has_term $ limit_term $ sort_lru_term)
+ Cmd.v info
+ Term.(
+ const (cmd_list env)
+ $ os_dir_term
+ $ status_term
+ $ has_term
+ $ limit_term
+ $ sort_lru_term)
in
let show_cmd =
- let info = Cmd.info "show"
- ~doc:"Show layer.json contents and list of extra files" in
+ let info =
+ Cmd.info "show" ~doc:"Show layer.json contents and list of extra files"
+ in
Cmd.v info Term.(const (cmd_show env) $ os_dir_term $ hash_term)
in
let tree_cmd =
- let info = Cmd.info "tree"
- ~doc:"Show parent tree of a layer (follows parent_hashes)" in
+ let info =
+ Cmd.info "tree" ~doc:"Show parent tree of a layer (follows parent_hashes)"
+ in
Cmd.v info Term.(const (cmd_tree env) $ os_dir_term $ hash_term)
in
let stats_cmd =
- let info = Cmd.info "stats"
- ~doc:"Summary: total count, disk usage, breakdown by status and \
- extra-file set" in
+ let info =
+ Cmd.info "stats"
+ ~doc:
+ "Summary: total count, disk usage, breakdown by status and \
+ extra-file set"
+ in
Cmd.v info Term.(const (cmd_stats env) $ os_dir_term)
in
let log_cmd =
- let info = Cmd.info "log"
- ~doc:"Print the layer's build log (layer.log)" in
+ let info = Cmd.info "log" ~doc:"Print the layer's build log (layer.log)" in
Cmd.v info Term.(const (cmd_log env) $ os_dir_term $ hash_term)
in
- let info = Cmd.info "day11-layer-cli"
- ~doc:"Low-level inspection of the day11 layer cache. Strictly \
- generic: knows about layer.json and the filesystem layout, \
- but treats domain-specific sidecar files as opaque JSON \
- blobs (which it pretty-prints in 'show')."
- ~version:"0.3" in
+ let info =
+ Cmd.info "day11-layer-cli"
+ ~doc:
+ "Low-level inspection of the day11 layer cache. Strictly generic: \
+ knows about layer.json and the filesystem layout, but treats \
+ domain-specific sidecar files as opaque JSON blobs (which it \
+ pretty-prints in 'show')."
+ ~version:"0.3"
+ in
Cmd.group info [ list_cmd; show_cmd; tree_cmd; stats_cmd; log_cmd ]
let () =
File "day11/bin/cmd_batch.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_batch.ml b/_build/default/day11/bin/.formatted/cmd_batch.ml
index 483f31b..d9ed7ad 100644
--- a/_build/default/day11/bin/cmd_batch.ml
+++ b/_build/default/day11/bin/.formatted/cmd_batch.ml
@@ -4,92 +4,104 @@ open Cmdliner
module Build = Day11_opam_layer.Build
module Tool = Day11_opam_layer.Tool
module Layer = Day11_layer.Layer
+
type build = Build.t
type tool = Tool.t
-
-
let cleanup_stale_mounts () =
(* Unmount and remove any leaked day11_run_* overlay mounts from
previous runs that were killed without cleanup *)
let tmp = Filename.get_temp_dir_name () in
let entries = try Sys.readdir tmp |> Array.to_list with _ -> [] in
- let stale = List.filter (fun name ->
- String.length name > 10 &&
- String.sub name 0 10 = "day11_run_"
- ) entries in
- if stale <> [] then begin
+ let stale =
+ List.filter
+ (fun name ->
+ String.length name > 10 && String.sub name 0 10 = "day11_run_")
+ entries
+ in
+ if stale <> [] then (
Printf.printf "Cleaning up %d stale temp dirs...\n%!" (List.length stale);
- List.iter (fun name ->
- let merged = Filename.concat (Filename.concat tmp name) "merged" in
- ignore (Sys.command (Printf.sprintf "sudo umount %s 2>/dev/null" merged));
- ) stale;
- ignore (Sys.command (Printf.sprintf "sudo rm -rf %s"
- (String.concat " " (List.map (fun name ->
- Filename.concat tmp name) stale))))
- end
+ List.iter
+ (fun name ->
+ let merged = Filename.concat (Filename.concat tmp name) "merged" in
+ ignore
+ (Sys.command (Printf.sprintf "sudo umount %s 2>/dev/null" merged)))
+ stale;
+ ignore
+ (Sys.command
+ (Printf.sprintf "sudo rm -rf %s"
+ (String.concat " "
+ (List.map (fun name -> Filename.concat tmp name) stale)))))
-let run profile_name profile_dir np cores_per_build overcommit
- solve_only dry_run rebuild_failed rebuild_base fake_build target_override =
+let run profile_name profile_dir np cores_per_build overcommit solve_only
+ dry_run rebuild_failed rebuild_base fake_build target_override =
Common.with_eio @@ fun ~sw env ->
cleanup_stale_mounts ();
(* Build the NUMA-aware cpu slot pool if requested. [np] is adjusted
down to match so the outer concurrency never exceeds what the pool
can serve. *)
- let cpu_slots = match cores_per_build with
+ let cpu_slots =
+ match cores_per_build with
| None | Some 0 -> None
| Some n ->
- let pool =
- Day11_runner.Cpu_slots.auto ~cores_per_build:n ~overcommit () in
- Printf.printf "CPU pool: %s\n%!"
- (Day11_runner.Cpu_slots.describe pool);
- Some pool
+ let pool =
+ Day11_runner.Cpu_slots.auto ~cores_per_build:n ~overcommit ()
+ in
+ Printf.printf "CPU pool: %s\n%!" (Day11_runner.Cpu_slots.describe pool);
+ Some pool
in
- let np = match cpu_slots with
+ let np =
+ match cpu_slots with
| Some pool ->
- let n = Day11_runner.Cpu_slots.n_slots pool in
- if n < np then begin
- Printf.printf "Reducing -j from %d to %d to match cpu pool\n%!"
- np n; n
- end else np
+ let n = Day11_runner.Cpu_slots.n_slots pool in
+ if n < np then (
+ Printf.printf "Reducing -j from %d to %d to match cpu pool\n%!" np n;
+ n)
+ else np
| None -> np
in
- let profile, paths = match Common.load_profile ~profile_dir ~name:profile_name with
- | Ok x -> x | Error (`Msg e) -> Printf.eprintf "Error: %s\n" e; exit 1
+ let profile, paths =
+ match Common.load_profile ~profile_dir ~name:profile_name with
+ | Ok x -> x
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n" e;
+ exit 1
in
Common.ensure_paths paths;
(* Warn if base image digest is stale or not pinned *)
if Day11_batch.Profile.base_image_stale profile then
- Printf.printf "WARNING: Base image digest is %s. Run 'day11 profile refresh-base --name %s' to update.\n%!"
+ Printf.printf
+ "WARNING: Base image digest is %s. Run 'day11 profile refresh-base \
+ --name %s' to update.\n\
+ %!"
(match profile.base_image_digest with
- | None -> "not pinned"
- | Some _ -> "more than 30 days old")
+ | None -> "not pinned"
+ | Some _ -> "more than 30 days old")
profile_name;
- let ctx = Day11_batch.Profile_ctx.load profile
- ~cache_dir:paths.cache_dir in
- let ctx = match cpu_slots with
+ let ctx = Day11_batch.Profile_ctx.load profile ~cache_dir:paths.cache_dir in
+ let ctx =
+ match cpu_slots with
| Some pool -> Day11_batch.Profile_ctx.with_cpu_slots ctx pool
- | None -> ctx in
+ | None -> ctx
+ in
let with_doc = profile.with_doc in
let extra_pins = profile.extra_pins in
let jtw_repo = if profile.with_jtw then profile.jtw_repo else None in
let small_universe, all_versions, target, profile_packages =
match target_override with
| Some t ->
- (* CLI target overrides the profile's target mode *)
- (false, false, Some t, None)
+ (* CLI target overrides the profile's target mode *)
+ (false, false, Some t, None)
| None ->
- let open Day11_batch.Profile in
- let tm = profile.target_mode in
- let av = match tm.versions with
- | All_versions -> true
- | Latest_n _ -> false
- in
- let pkgs = match tm.names with
- | Names names -> Some names
- | All_names -> None
- in
- (false, av, None, pkgs)
+ let open Day11_batch.Profile in
+ let tm = profile.target_mode in
+ let av =
+ match tm.versions with All_versions -> true | Latest_n _ -> false
+ in
+ let pkgs =
+ match tm.names with Names names -> Some names | All_names -> None
+ in
+ (false, av, None, pkgs)
in
(* Convenience aliases from ctx — avoids churn in the (still large)
body below. All profile-derived state that used to be bound
@@ -100,23 +112,25 @@ let run profile_name profile_dir np cores_per_build overcommit
let ocaml_version = ctx.ocaml_version in
let os_dir = ctx.os_dir in
let cache_dir = ctx.cache_dir in
- let targets = match profile_packages with
+ let targets =
+ match profile_packages with
| Some names ->
- (* Profile declares an explicit list of package names. Resolve
+ (* Profile declares an explicit list of package names. Resolve
each to its latest non-avoided version in the solver repos
— mirrors how ocaml-docs-ci uses [Track.v] with the names
as a filter. *)
- Printf.printf "Using profile packages: %d names\n%!"
- (List.length names);
- List.filter_map (fun name ->
- match Day11_batch.Targets.pick_latest_version git_packages name with
- | v :: _ -> Some v
- | [] ->
- Printf.eprintf "warning: no versions found for %s\n%!" name;
- None) names
+ Printf.printf "Using profile packages: %d names\n%!" (List.length names);
+ List.filter_map
+ (fun name ->
+ match Day11_batch.Targets.pick_latest_version git_packages name with
+ | v :: _ -> Some v
+ | [] ->
+ Printf.eprintf "warning: no versions found for %s\n%!" name;
+ None)
+ names
| None ->
- Day11_batch.Targets.resolve ~small:small_universe ~all_versions
- git_packages target
+ Day11_batch.Targets.resolve ~small:small_universe ~all_versions
+ git_packages target
in
Printf.printf "Targets: %d packages\n%!" (List.length targets);
(* Snapshot — deterministic dir keyed by repo HEADs *)
@@ -133,19 +147,24 @@ let run profile_name profile_dir np cores_per_build overcommit
~ocaml_version:(Option.map OpamPackage.to_string ocaml_version)
~with_doc ~all_versions ~small_universe;
(match ocaml_version with
- | Some v -> Printf.printf "Compiler: %s\n%!" (OpamPackage.to_string v)
- | None -> ());
+ | Some v -> Printf.printf "Compiler: %s\n%!" (OpamPackage.to_string v)
+ | None -> ());
(* Solve — load cached solutions where possible *)
let solutions_dir = Day11_batch.Snapshot.solutions_dir snapshot_dir in
Bos.OS.Dir.create ~path:true solutions_dir |> ignore;
let cached = ref 0 in
- let need_solve = List.filter (fun target ->
- let cache_file = Fpath.(solutions_dir /
- (OpamPackage.to_string target ^ ".json")) in
- if Sys.file_exists (Fpath.to_string cache_file) then begin
- incr cached; false
- end else true
- ) targets in
+ let need_solve =
+ List.filter
+ (fun target ->
+ let cache_file =
+ Fpath.(solutions_dir / (OpamPackage.to_string target ^ ".json"))
+ in
+ if Sys.file_exists (Fpath.to_string cache_file) then (
+ incr cached;
+ false)
+ else true)
+ targets
+ in
Printf.printf "Solving: %d cached, %d need solving (%d workers)...\n%!"
!cached (List.length need_solve) np;
(* Latest-version mode: profile lists package names, day11 picked
@@ -161,303 +180,352 @@ let run profile_name profile_dir np cores_per_build overcommit
preference through the transitive deps — same shape as
[oi]'s [x-oi-toolchain-roots] mechanism. *)
let pinned_constraints =
- List.filter_map (fun s ->
- try Some (OpamPackage.of_string s)
- with _ ->
- Printf.eprintf "warning: ignoring malformed pinned_versions entry %S\n%!" s;
- None
- ) profile.pinned_versions
+ List.filter_map
+ (fun s ->
+ try Some (OpamPackage.of_string s)
+ with _ ->
+ Printf.eprintf
+ "warning: ignoring malformed pinned_versions entry %S\n%!" s;
+ None)
+ profile.pinned_versions
+ in
+ let results =
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ?ocaml_version ~np
+ ~repos:repos_with_shas ~constraints:pinned_constraints ~pin_target
+ need_solve
in
- let results = Day11_solver_pool.Solver_pool.solve_many ~sw env
- ?ocaml_version ~np ~repos:repos_with_shas
- ~constraints:pinned_constraints
- ~pin_target need_solve in
(* Retry failed solves with older versions (useful for overlays that
pin transitive deps to specific versions) *)
let results, targets =
if not small_universe then (results, targets)
else
- let new_results = ref [] in
- let new_targets = ref [] in
- let solved_names = Hashtbl.create 16 in
- (* First pass: collect successes *)
- List.iter (fun (target, result) ->
- match result with
- | Ok _ ->
- new_results := (target, result) :: !new_results;
- Hashtbl.replace solved_names
- (OpamPackage.name target) target
- | Error _ -> ()
- ) results;
- (* Second pass: retry failures *)
- List.iter (fun (target, result) ->
- match result with
- | Ok _ -> ()
- | Error _ ->
- let name = OpamPackage.Name.to_string (OpamPackage.name target) in
- let candidates = Day11_batch.Targets.pick_latest_version git_packages name in
- let older = List.filter (fun pkg ->
- OpamPackage.Version.compare (OpamPackage.version pkg)
- (OpamPackage.version target) < 0
- ) candidates in
- if older = [] then
- new_results := (target, result) :: !new_results
- else begin
- Printf.printf " Retrying %s with older versions...\n%!" name;
- let retries = Day11_solver_pool.Solver_pool.solve_many ~sw env
- ?ocaml_version ~np:1 ~repos:repos_with_shas
- ~constraints:pinned_constraints older in
- match List.find_opt (fun (_, r) -> Result.is_ok r) retries with
- | Some hit ->
- Printf.printf " %s -> %s\n%!"
- name (OpamPackage.to_string (fst hit));
- new_results := hit :: !new_results;
- Hashtbl.replace solved_names
- (OpamPackage.name target) (fst hit)
- | None ->
- new_results := (target, result) :: !new_results
- end
- ) results;
- (* Update targets to use the versions that actually solved *)
- List.iter (fun target ->
- match Hashtbl.find_opt solved_names (OpamPackage.name target) with
- | Some pkg -> new_targets := pkg :: !new_targets
- | None -> new_targets := target :: !new_targets
- ) targets;
- (List.rev !new_results, List.rev !new_targets)
+ let new_results = ref [] in
+ let new_targets = ref [] in
+ let solved_names = Hashtbl.create 16 in
+ (* First pass: collect successes *)
+ List.iter
+ (fun (target, result) ->
+ match result with
+ | Ok _ ->
+ new_results := (target, result) :: !new_results;
+ Hashtbl.replace solved_names (OpamPackage.name target) target
+ | Error _ -> ())
+ results;
+ (* Second pass: retry failures *)
+ List.iter
+ (fun (target, result) ->
+ match result with
+ | Ok _ -> ()
+ | Error _ ->
+ let name = OpamPackage.Name.to_string (OpamPackage.name target) in
+ let candidates =
+ Day11_batch.Targets.pick_latest_version git_packages name
+ in
+ let older =
+ List.filter
+ (fun pkg ->
+ OpamPackage.Version.compare (OpamPackage.version pkg)
+ (OpamPackage.version target)
+ < 0)
+ candidates
+ in
+ if older = [] then new_results := (target, result) :: !new_results
+ else (
+ Printf.printf " Retrying %s with older versions...\n%!" name;
+ let retries =
+ Day11_solver_pool.Solver_pool.solve_many ~sw env
+ ?ocaml_version ~np:1 ~repos:repos_with_shas
+ ~constraints:pinned_constraints older
+ in
+ match List.find_opt (fun (_, r) -> Result.is_ok r) retries with
+ | Some hit ->
+ Printf.printf " %s -> %s\n%!" name
+ (OpamPackage.to_string (fst hit));
+ new_results := hit :: !new_results;
+ Hashtbl.replace solved_names (OpamPackage.name target)
+ (fst hit)
+ | None -> new_results := (target, result) :: !new_results))
+ results;
+ (* Update targets to use the versions that actually solved *)
+ List.iter
+ (fun target ->
+ match Hashtbl.find_opt solved_names (OpamPackage.name target) with
+ | Some pkg -> new_targets := pkg :: !new_targets
+ | None -> new_targets := target :: !new_targets)
+ targets;
+ (List.rev !new_results, List.rev !new_targets)
in
(* Save new solutions *)
- List.iter (fun (target, result) ->
- let entry = match result with
- | Ok result ->
- Day11_batch.Incremental_solver.Cached_solution {
- package = target; result; cache_key = None }
- | Error (msg, examined) ->
- Day11_batch.Incremental_solver.Cached_failure {
- package = target; error = msg; examined; cache_key = None }
- in
- ignore (Day11_batch.Incremental_solver.save
- Fpath.(solutions_dir / (OpamPackage.to_string target ^ ".json"))
- entry)
- ) results;
+ List.iter
+ (fun (target, result) ->
+ let entry =
+ match result with
+ | Ok result ->
+ Day11_batch.Incremental_solver.Cached_solution
+ { package = target; result; cache_key = None }
+ | Error (msg, examined) ->
+ Day11_batch.Incremental_solver.Cached_failure
+ { package = target; error = msg; examined; cache_key = None }
+ in
+ ignore
+ (Day11_batch.Incremental_solver.save
+ Fpath.(solutions_dir / (OpamPackage.to_string target ^ ".json"))
+ entry))
+ results;
(* Load all solutions (cached + new) *)
- let solutions = List.filter_map (fun target ->
- let cache_file = Fpath.(solutions_dir /
- (OpamPackage.to_string target ^ ".json")) in
- match Day11_batch.Incremental_solver.load cache_file with
- | Ok (Day11_batch.Incremental_solver.Cached_solution { result; _ }) ->
- Some (target, result)
- | _ -> None
- ) targets in
+ let solutions =
+ List.filter_map
+ (fun target ->
+ let cache_file =
+ Fpath.(solutions_dir / (OpamPackage.to_string target ^ ".json"))
+ in
+ match Day11_batch.Incremental_solver.load cache_file with
+ | Ok (Day11_batch.Incremental_solver.Cached_solution { result; _ }) ->
+ Some (target, result)
+ | _ -> None)
+ targets
+ in
(* Extract build_deps for consumers that don't need doc_deps *)
- let build_solutions = List.map (fun (t, r) ->
- (t, (r : Day11_solution.Solve_result.t).build_deps)) solutions in
+ let build_solutions =
+ List.map
+ (fun (t, r) -> (t, (r : Day11_solution.Solve_result.t).build_deps))
+ solutions
+ in
let n_solved = List.length solutions in
let n_failed = List.length targets - n_solved in
- Printf.printf "Solved: %d/%d (%d failed)\n%!" n_solved (List.length targets) n_failed;
+ Printf.printf "Solved: %d/%d (%d failed)\n%!" n_solved (List.length targets)
+ n_failed;
Day11_lib.Run_log.write_solve run_log ~n_solved ~n_failed;
- if solve_only then begin
+ if solve_only then (
Printf.printf "Solutions cached in %s\n%!" (Fpath.to_string solutions_dir);
- 0
- end else
- let patches = ctx.patches in
- (* Delete base image early if --rebuild-base, before loading *)
- if rebuild_base then begin
- let base_dir = Fpath.(cache_dir / "base") in
- Printf.printf "Deleting base image and all build layers for rebuild...\n%!";
- (* Both dirs have root-owned files — go straight to sudo rm -rf *)
- ignore (Sys.command
- (Printf.sprintf "sudo rm -rf %s %s"
- (Fpath.to_string base_dir) (Fpath.to_string os_dir)))
- end;
- (* Build DAG — no Eio needed. Uses the ctx's hash cache so that later
+ 0)
+ else
+ let patches = ctx.patches in
+ (* Delete base image early if --rebuild-base, before loading *)
+ if rebuild_base then (
+ let base_dir = Fpath.(cache_dir / "base") in
+ Printf.printf
+ "Deleting base image and all build layers for rebuild...\n%!";
+ (* Both dirs have root-owned files — go straight to sudo rm -rf *)
+ ignore
+ (Sys.command
+ (Printf.sprintf "sudo rm -rf %s %s" (Fpath.to_string base_dir)
+ (Fpath.to_string os_dir))));
+ (* Build DAG — no Eio needed. Uses the ctx's hash cache so that later
doc-tool planning sees the same hashes. *)
- let cache = ctx.hash_cache in
- (* Triples carry doc_deps so Dag uses doc-deps-keyed universe;
+ let cache = ctx.hash_cache in
+ (* Triples carry doc_deps so Dag uses doc-deps-keyed universe;
[build_solutions] (just build_deps) keeps working for Blessing
and JTW. *)
- let dag_solutions = List.map (fun (t, r) ->
- (t, (r : Day11_solution.Solve_result.t).build_deps,
- r.Day11_solution.Solve_result.doc_deps)) solutions in
- let nodes = Day11_opam_build.Dag.build_dag cache
- ~base_hash:ctx.base.hash dag_solutions in
- Printf.printf "DAG: %d unique build nodes\n%!" (List.length nodes);
- (* Delete failed layers if --rebuild-failed *)
- if rebuild_failed then begin
- let root_deleted = ref 0 in
- let cascade_deleted = ref 0 in
- List.iter (fun (node : Day11_opam_layer.Build.t) ->
- let layer = Build.layer ~os_dir node in
- if Layer.exists env layer then
- match Day11_layer.Meta.load env (Layer.meta_path layer) with
- | Ok { exit_status; failed_dep; _ } when exit_status <> 0 ->
- ignore (Bos.OS.Path.delete ~recurse:true (Layer.dir layer));
- if failed_dep = None then incr root_deleted
- else incr cascade_deleted
- | _ -> ()
- ) nodes;
- if !root_deleted + !cascade_deleted > 0 then
- Printf.printf "Deleted %d root failures + %d cascade failures for rebuild\n%!"
- !root_deleted !cascade_deleted
- end;
- (* Check which layers already exist *)
- let n_cached = List.length (List.filter (fun (node : Day11_opam_layer.Build.t) ->
- Layer.exists env (Build.layer ~os_dir node)
- ) nodes) in
- let n_need_build = List.length nodes - n_cached in
- Printf.printf "Layers: %d cached, %d need building\n%!" n_cached n_need_build;
- Day11_lib.Run_log.write_dag run_log ~n_build:(List.length nodes)
- ~n_cached ~n_need_build;
- if dry_run then begin
- if n_need_build > 0 then begin
- Printf.printf "\nLayers to build:\n";
- List.iter (fun (node : Day11_opam_layer.Build.t) ->
- if not (Layer.exists env (Build.layer ~os_dir node)) then
- Printf.printf " %s (%d deps)\n"
- (OpamPackage.to_string node.pkg) (List.length node.deps)
- ) nodes
- end;
- 0
- end else begin
- (* === Build phase (needs base image, containers) === *)
- (* [rebuild_base] deletes the cached opam-build binary too — it
+ let dag_solutions =
+ List.map
+ (fun (t, r) ->
+ ( t,
+ (r : Day11_solution.Solve_result.t).build_deps,
+ r.Day11_solution.Solve_result.doc_deps ))
+ solutions
+ in
+ let nodes =
+ Day11_opam_build.Dag.build_dag cache ~base_hash:ctx.base.hash
+ dag_solutions
+ in
+ Printf.printf "DAG: %d unique build nodes\n%!" (List.length nodes);
+ (* Delete failed layers if --rebuild-failed *)
+ if rebuild_failed then (
+ let root_deleted = ref 0 in
+ let cascade_deleted = ref 0 in
+ List.iter
+ (fun (node : Day11_opam_layer.Build.t) ->
+ let layer = Build.layer ~os_dir node in
+ if Layer.exists env layer then
+ match Day11_layer.Meta.load env (Layer.meta_path layer) with
+ | Ok { exit_status; failed_dep; _ } when exit_status <> 0 ->
+ ignore (Bos.OS.Path.delete ~recurse:true (Layer.dir layer));
+ if failed_dep = None then incr root_deleted
+ else incr cascade_deleted
+ | _ -> ())
+ nodes;
+ if !root_deleted + !cascade_deleted > 0 then
+ Printf.printf
+ "Deleted %d root failures + %d cascade failures for rebuild\n%!"
+ !root_deleted !cascade_deleted);
+ (* Check which layers already exist *)
+ let n_cached =
+ List.length
+ (List.filter
+ (fun (node : Day11_opam_layer.Build.t) ->
+ Layer.exists env (Build.layer ~os_dir node))
+ nodes)
+ in
+ let n_need_build = List.length nodes - n_cached in
+ Printf.printf "Layers: %d cached, %d need building\n%!" n_cached
+ n_need_build;
+ Day11_lib.Run_log.write_dag run_log ~n_build:(List.length nodes) ~n_cached
+ ~n_need_build;
+ if dry_run then (
+ if n_need_build > 0 then (
+ Printf.printf "\nLayers to build:\n";
+ List.iter
+ (fun (node : Day11_opam_layer.Build.t) ->
+ if not (Layer.exists env (Build.layer ~os_dir node)) then
+ Printf.printf " %s (%d deps)\n"
+ (OpamPackage.to_string node.pkg)
+ (List.length node.deps))
+ nodes);
+ 0)
+ else (
+ (* === Build phase (needs base image, containers) === *)
+ (* [rebuild_base] deletes the cached opam-build binary too — it
gets rebuilt from source as part of [ensure_base]. *)
- if rebuild_base then begin
- let bin = Fpath.(cache_dir / "opam-build-bin") in
- ignore (Bos.OS.File.delete bin)
- end;
- (* Build opam-build and the base image in one step. *)
- let ctx = match Day11_batch.Profile_ctx.ensure_base ~sw env ctx with
- | Ok c -> c
- | Error (`Msg e) ->
- Printf.eprintf "Base image build failed: %s\n%!" e; exit 1
- in
- let benv = ctx.benv in
- Day11_opam_build.Types.ensure_dirs benv;
- (* No full merged-repo mount at [/home/opam/.opam/repo/default]: each
+ (if rebuild_base then
+ let bin = Fpath.(cache_dir / "opam-build-bin") in
+ ignore (Bos.OS.File.delete bin));
+ (* Build opam-build and the base image in one step. *)
+ let ctx =
+ match Day11_batch.Profile_ctx.ensure_base ~sw env ctx with
+ | Ok c -> c
+ | Error (`Msg e) ->
+ Printf.eprintf "Base image build failed: %s\n%!" e;
+ exit 1
+ in
+ let benv = ctx.benv in
+ Day11_opam_build.Types.ensure_dirs benv;
+ (* No full merged-repo mount at [/home/opam/.opam/repo/default]: each
build mounts a per-package slice there (Container_backend.build,
from [~opam_repositories]) and only needs its own package — deps
are pre-installed in the overlay. Mounting the whole ~18k-package
repo on top shadowed that slice and made opam scan all of it on
every switch-state load (multi-second stall per build). *)
- let opam_build_repo = Option.map Fpath.v profile.opam_build_repo in
- let base_mounts =
- (match Day11_opam_build.Base.opam_build_mount ~cache_dir
- ?opam_build_repo () with
- | Some m -> [ m ] | None -> [])
- in
- (* Bless *)
- let blessing_maps = Day11_batch.Blessing.compute_blessings build_solutions in
- (* Build function for the unified DAG *)
- let packages_dir = Day11_batch.Snapshot.packages_dir snapshot_dir in
- ignore (Bos.OS.Dir.create ~path:true packages_dir);
- let fake_strategy pkg =
- let pkg_str = OpamPackage.to_string pkg in
- { Day11_opam_build.Types.cmd =
- Printf.sprintf "echo 'fake-build %s'" pkg_str;
- cleanup = Day11_opam_build.Build_layer.opam_build_cleanup }
- in
- (* Shared writer for build outcomes, symlinks, and run-log lines. *)
- let recorder = Day11_batch.Recorder.create
- ~env ~os_dir ~packages_dir ~blessing_maps ~run_log in
- let snapshot_repos = List.map Fpath.v profile.opam_repositories in
- let build_one (node : Day11_opam_layer.Build.t) =
- let strategy =
- if fake_build then Some (fake_strategy node.pkg)
- else None
- in
- match Day11_opam_build.Build_layer.build ~sw env benv ?patches
- ~opam_repositories:snapshot_repos
- ~mounts:base_mounts ~snapshot_repos node ?strategy () with
- | Day11_opam_build.Types.Success _ -> true
- | _ -> false
- in
- (* Build + Docs (unified pipeline when --with-doc) *)
- let doc_outcomes = ref [] in
- let doc_outcomes_lock = Mutex.create () in
- if with_doc then begin
- let on_pkg_complete node ~cached:_ ~success =
- Day11_batch.Recorder.record_build recorder node ~success
- in
- let on_doc_complete (node : Day11_opam_layer.Build.t) ~cached:_ ~success =
- let layer_dir = Day11_opam_layer.Build.dir ~os_dir node in
- let log_file =
- let p = Fpath.(layer_dir / "build.log") in
- if Sys.file_exists (Fpath.to_string p) then Some p else None
+ let opam_build_repo = Option.map Fpath.v profile.opam_build_repo in
+ let base_mounts =
+ match
+ Day11_opam_build.Base.opam_build_mount ~cache_dir ?opam_build_repo ()
+ with
+ | Some m -> [ m ]
+ | None -> []
in
- let outcome : Day11_batch.Summary.doc_outcome = {
- pkg = node.pkg;
- success;
- layer_hash = node.hash;
- log_file;
- blessed = Day11_batch.Recorder.is_blessed recorder node;
- } in
- Mutex.lock doc_outcomes_lock;
- doc_outcomes := outcome :: !doc_outcomes;
- Mutex.unlock doc_outcomes_lock
- in
- Day11_doc.Generate.build_tools_and_run ~sw env ctx ~np
- ~mounts:base_mounts ~build_one
- ~on_pkg_complete ~on_doc_complete ~snapshot_dir ~run_log
- ~nodes ~solutions ~blessing_maps ()
- end
- else begin
- (* Build only — no docs *)
- let is_cached node =
- let layer = Build.layer ~os_dir node in
- if not (Layer.exists env layer) then
- Day11_opam_build.Dag_executor.Not_cached
- else begin
- Day11_layer.Last_used.touch env (Layer.dir layer);
- match Day11_layer.Meta.load env (Layer.meta_path layer) with
- | Ok meta ->
- if meta.exit_status = 0 then Day11_opam_build.Dag_executor.Cached_ok
- else Day11_opam_build.Dag_executor.Cached_fail
- | Error _ -> Day11_opam_build.Dag_executor.Cached_fail
- end
- in
- let cascaded_set : (string, unit) Hashtbl.t = Hashtbl.create 256 in
- Day11_opam_build.Dag_executor.execute env ~np ~is_cached
- ~on_complete:(fun ~stats ~cached:_ node success ->
- let open Day11_opam_build.Dag_executor in
- if Hashtbl.mem cascaded_set node.hash then
- ()
- else begin
- Day11_batch.Recorder.record_build recorder node ~success;
- if not success then
- Printf.printf "[%d/%d, %d ok, %d failed, %d cascade] FAIL: %s\n%!"
- stats.completed stats.total stats.ok stats.failed
- stats.cascaded (OpamPackage.to_string node.pkg)
- else if stats.completed mod 100 = 0 then
- Printf.printf "[%d/%d, %d ok, %d failed, %d cascade] %s\n%!"
- stats.completed stats.total stats.ok stats.failed
- stats.cascaded (OpamPackage.to_string node.pkg)
- end)
- ~on_cascade:(fun ~failed ~failed_dep ->
- Hashtbl.replace cascaded_set failed.hash ();
- Day11_batch.Recorder.record_cascade recorder ~failed ~failed_dep)
- nodes build_one
- end;
- (* JTW *)
- (match jtw_repo with
- | Some dir ->
- let output = Fpath.to_string Fpath.(cache_dir / "jtw-output") in
- Day11_jtw.Build_tools.build_and_run ~sw env benv ~np ~os_dir
- ~packages:git_packages ~repos:repos_with_shas ~mounts:base_mounts
- ~extra_repo_dirs:extra_pins ~repo_dir:dir ~output
- ~nodes ~solutions:build_solutions
- | None -> ());
- (* Write final summary via Summary module *)
- Day11_lib.Run_log.close_build_log ();
- let results : Day11_batch.Summary.results = {
- builds = Day11_batch.Recorder.outcomes recorder;
- docs = !doc_outcomes;
- targets;
- } in
- ignore (Day11_batch.Summary.finish ~snapshot_dir ~packages_dir
- ~run_info:run_log results);
- 0
- end
+ (* Bless *)
+ let blessing_maps =
+ Day11_batch.Blessing.compute_blessings build_solutions
+ in
+ (* Build function for the unified DAG *)
+ let packages_dir = Day11_batch.Snapshot.packages_dir snapshot_dir in
+ ignore (Bos.OS.Dir.create ~path:true packages_dir);
+ let fake_strategy pkg =
+ let pkg_str = OpamPackage.to_string pkg in
+ {
+ Day11_opam_build.Types.cmd =
+ Printf.sprintf "echo 'fake-build %s'" pkg_str;
+ cleanup = Day11_opam_build.Build_layer.opam_build_cleanup;
+ }
+ in
+ (* Shared writer for build outcomes, symlinks, and run-log lines. *)
+ let recorder =
+ Day11_batch.Recorder.create ~env ~os_dir ~packages_dir ~blessing_maps
+ ~run_log
+ in
+ let snapshot_repos = List.map Fpath.v profile.opam_repositories in
+ let build_one (node : Day11_opam_layer.Build.t) =
+ let strategy =
+ if fake_build then Some (fake_strategy node.pkg) else None
+ in
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv ?patches
+ ~opam_repositories:snapshot_repos ~mounts:base_mounts
+ ~snapshot_repos node ?strategy ()
+ with
+ | Day11_opam_build.Types.Success _ -> true
+ | _ -> false
+ in
+ (* Build + Docs (unified pipeline when --with-doc) *)
+ let doc_outcomes = ref [] in
+ let doc_outcomes_lock = Mutex.create () in
+ (if with_doc then
+ let on_pkg_complete node ~cached:_ ~success =
+ Day11_batch.Recorder.record_build recorder node ~success
+ in
+ let on_doc_complete (node : Day11_opam_layer.Build.t) ~cached:_
+ ~success =
+ let layer_dir = Day11_opam_layer.Build.dir ~os_dir node in
+ let log_file =
+ let p = Fpath.(layer_dir / "build.log") in
+ if Sys.file_exists (Fpath.to_string p) then Some p else None
+ in
+ let outcome : Day11_batch.Summary.doc_outcome =
+ {
+ pkg = node.pkg;
+ success;
+ layer_hash = node.hash;
+ log_file;
+ blessed = Day11_batch.Recorder.is_blessed recorder node;
+ }
+ in
+ Mutex.lock doc_outcomes_lock;
+ doc_outcomes := outcome :: !doc_outcomes;
+ Mutex.unlock doc_outcomes_lock
+ in
+ Day11_doc.Generate.build_tools_and_run ~sw env ctx ~np
+ ~mounts:base_mounts ~build_one ~on_pkg_complete ~on_doc_complete
+ ~snapshot_dir ~run_log ~nodes ~solutions ~blessing_maps ()
+ else
+ (* Build only — no docs *)
+ let is_cached node =
+ let layer = Build.layer ~os_dir node in
+ if not (Layer.exists env layer) then
+ Day11_opam_build.Dag_executor.Not_cached
+ else (
+ Day11_layer.Last_used.touch env (Layer.dir layer);
+ match Day11_layer.Meta.load env (Layer.meta_path layer) with
+ | Ok meta ->
+ if meta.exit_status = 0 then
+ Day11_opam_build.Dag_executor.Cached_ok
+ else Day11_opam_build.Dag_executor.Cached_fail
+ | Error _ -> Day11_opam_build.Dag_executor.Cached_fail)
+ in
+ let cascaded_set : (string, unit) Hashtbl.t = Hashtbl.create 256 in
+ Day11_opam_build.Dag_executor.execute env ~np ~is_cached
+ ~on_complete:(fun ~stats ~cached:_ node success ->
+ let open Day11_opam_build.Dag_executor in
+ if Hashtbl.mem cascaded_set node.hash then ()
+ else (
+ Day11_batch.Recorder.record_build recorder node ~success;
+ if not success then
+ Printf.printf
+ "[%d/%d, %d ok, %d failed, %d cascade] FAIL: %s\n%!"
+ stats.completed stats.total stats.ok stats.failed
+ stats.cascaded
+ (OpamPackage.to_string node.pkg)
+ else if stats.completed mod 100 = 0 then
+ Printf.printf "[%d/%d, %d ok, %d failed, %d cascade] %s\n%!"
+ stats.completed stats.total stats.ok stats.failed
+ stats.cascaded
+ (OpamPackage.to_string node.pkg)))
+ ~on_cascade:(fun ~failed ~failed_dep ->
+ Hashtbl.replace cascaded_set failed.hash ();
+ Day11_batch.Recorder.record_cascade recorder ~failed ~failed_dep)
+ nodes build_one);
+ (* JTW *)
+ (match jtw_repo with
+ | Some dir ->
+ let output = Fpath.to_string Fpath.(cache_dir / "jtw-output") in
+ Day11_jtw.Build_tools.build_and_run ~sw env benv ~np ~os_dir
+ ~packages:git_packages ~repos:repos_with_shas ~mounts:base_mounts
+ ~extra_repo_dirs:extra_pins ~repo_dir:dir ~output ~nodes
+ ~solutions:build_solutions
+ | None -> ());
+ (* Write final summary via Summary module *)
+ Day11_lib.Run_log.close_build_log ();
+ let results : Day11_batch.Summary.results =
+ {
+ builds = Day11_batch.Recorder.outcomes recorder;
+ docs = !doc_outcomes;
+ targets;
+ }
+ in
+ ignore
+ (Day11_batch.Summary.finish ~snapshot_dir ~packages_dir
+ ~run_info:run_log results);
+ 0)
let solve_only_term =
let doc = "Solve only — cache solutions and exit without building" in
@@ -472,7 +540,9 @@ let rebuild_failed_term =
Arg.(value & flag & info [ "rebuild-failed" ] ~doc)
let rebuild_base_term =
- let doc = "Delete and rebuild the base image (use when repos or opam-build change)" in
+ let doc =
+ "Delete and rebuild the base image (use when repos or opam-build change)"
+ in
Arg.(value & flag & info [ "rebuild-base" ] ~doc)
let fake_build_term =
@@ -484,28 +554,38 @@ let target_term =
Arg.(value & pos 0 (some string) None & info [] ~docv:"TARGET" ~doc)
let cores_per_build_term =
- let doc = "Cores per container. Enables cgroup cpuset pinning and \
- NUMA-local memory allocation when the host has multiple \
- NUMA nodes. Host CPUs are divided into slots of this \
- size, and [-j] is capped to the slot count. 0 (default) \
- disables pinning — containers see all host CPUs." in
- Arg.(value & opt (some int) None
- & info [ "cores-per-build" ] ~docv:"N" ~doc)
+ let doc =
+ "Cores per container. Enables cgroup cpuset pinning and NUMA-local memory \
+ allocation when the host has multiple NUMA nodes. Host CPUs are divided \
+ into slots of this size, and [-j] is capped to the slot count. 0 \
+ (default) disables pinning — containers see all host CPUs."
+ in
+ Arg.(value & opt (some int) None & info [ "cores-per-build" ] ~docv:"N" ~doc)
let overcommit_term =
- let doc = "Multiplier on the strict CPU-bounded slot count. 1.0 \
- (default) means each build has exclusive use of its \
- cpuset; 1.5 lets two builds share one cpuset 50% of the \
- time; 2.0 means every cpuset is doubled. Only takes \
- effect when [--cores-per-build] is set." in
- Arg.(value & opt float 1.0
- & info [ "overcommit" ] ~docv:"FACTOR" ~doc)
+ let doc =
+ "Multiplier on the strict CPU-bounded slot count. 1.0 (default) means each \
+ build has exclusive use of its cpuset; 1.5 lets two builds share one \
+ cpuset 50% of the time; 2.0 means every cpuset is doubled. Only takes \
+ effect when [--cores-per-build] is set."
+ in
+ Arg.(value & opt float 1.0 & info [ "overcommit" ] ~docv:"FACTOR" ~doc)
let cmd =
let info = Cmd.info "batch" ~doc:"Solve, build, and document packages" in
- let term = Term.(const run $ Common.profile_term $ Common.profile_dir_term
- $ Common.np_term $ cores_per_build_term $ overcommit_term
- $ solve_only_term $ dry_run_term
- $ rebuild_failed_term $ rebuild_base_term $ fake_build_term
- $ target_term) in
+ let term =
+ Term.(
+ const run
+ $ Common.profile_term
+ $ Common.profile_dir_term
+ $ Common.np_term
+ $ cores_per_build_term
+ $ overcommit_term
+ $ solve_only_term
+ $ dry_run_term
+ $ rebuild_failed_term
+ $ rebuild_base_term
+ $ fake_build_term
+ $ target_term)
+ in
Cmd.v info term
File "day11/bin/cmd_build.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_build.ml b/_build/default/day11/bin/.formatted/cmd_build.ml
index cf2abd0..6295e76 100644
--- a/_build/default/day11/bin/cmd_build.ml
+++ b/_build/default/day11/bin/.formatted/cmd_build.ml
@@ -4,23 +4,24 @@ open Cmdliner
module Build = Day11_opam_layer.Build
module Layer = Day11_layer.Layer
-let run profile_name profile_dir np target_str doc_output rebuild_failed
- native =
+let run profile_name profile_dir np target_str doc_output rebuild_failed native
+ =
Common.with_eio @@ fun ~sw env ->
let backend =
if native then
- (module Day11_opam_build.Native_backend
- : Day11_opam_build.Backend.S)
+ (module Day11_opam_build.Native_backend : Day11_opam_build.Backend.S)
else
- (module Day11_opam_build.Container_backend
- : Day11_opam_build.Backend.S)
+ (module Day11_opam_build.Container_backend : Day11_opam_build.Backend.S)
in
- let profile, paths = match Common.load_profile ~profile_dir ~name:profile_name with
- | Ok x -> x | Error (`Msg e) -> Printf.eprintf "Error: %s\n" e; exit 1
+ let profile, paths =
+ match Common.load_profile ~profile_dir ~name:profile_name with
+ | Ok x -> x
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n" e;
+ exit 1
in
Common.ensure_paths paths;
- let ctx = Day11_batch.Profile_ctx.load profile
- ~cache_dir:paths.cache_dir in
+ let ctx = Day11_batch.Profile_ctx.load profile ~cache_dir:paths.cache_dir in
(* Aliases to keep the existing body readable. *)
let os_dir = ctx.os_dir in
let ocaml_version = ctx.ocaml_version in
@@ -37,173 +38,206 @@ let run profile_name profile_dir np target_str doc_output rebuild_failed
ignore (Bos.OS.Dir.create ~path:true solutions_dir);
Printf.printf "Solving...\n%!";
let pinned_constraints =
- List.filter_map (fun s ->
- try Some (OpamPackage.of_string s) with _ -> None
- ) profile.pinned_versions
+ List.filter_map
+ (fun s -> try Some (OpamPackage.of_string s) with _ -> None)
+ profile.pinned_versions
+ in
+ let result =
+ Day11_solver_pool.Solver_pool.solve_many ~sw env ?ocaml_version ~np:1
+ ~repos:repos_with_shas ~constraints:pinned_constraints [ target ]
in
- let result = Day11_solver_pool.Solver_pool.solve_many ~sw env
- ?ocaml_version ~np:1 ~repos:repos_with_shas
- ~constraints:pinned_constraints [ target ] in
match List.find_opt (fun (_, r) -> Result.is_ok r) result with
| None ->
- let err = match result with
- | [ (_, Error (msg, _)) ] -> msg
- | _ -> "unknown error"
- in
- Printf.eprintf "Solve failed: %s\n%!" err; 1
+ let err =
+ match result with
+ | [ (_, Error (msg, _)) ] -> msg
+ | _ -> "unknown error"
+ in
+ Printf.eprintf "Solve failed: %s\n%!" err;
+ 1
| Some (target, Ok solve_result) ->
- let solution = solve_result.Day11_solution.Solve_result.build_deps in
- let doc_solution = solve_result.Day11_solution.Solve_result.doc_deps in
- Printf.printf "Solved: %d packages\n%!"
- (OpamPackage.Map.cardinal solution);
- (* Build DAG — uses the ctx's shared hash cache + base hash. *)
- let patches = ctx.patches in
- let cache = ctx.hash_cache in
- let dag_solutions = [ (target, solution, doc_solution) ] in
- let nodes = Day11_opam_build.Dag.build_dag cache
- ~base_hash:ctx.base.hash dag_solutions in
- Printf.printf "DAG: %d nodes\n%!" (List.length nodes);
- (* Delete failed layers if requested *)
- if rebuild_failed then begin
- let deleted = ref 0 in
- List.iter (fun (node : Day11_opam_layer.Build.t) ->
- let layer = Build.layer ~os_dir node in
- if Layer.exists env layer then
- match Day11_layer.Meta.load env (Layer.meta_path layer) with
- | Ok { exit_status; _ } when exit_status <> 0 ->
- ignore (Bos.OS.Path.delete ~recurse:true (Layer.dir layer));
- incr deleted
- | _ -> ()
- ) nodes;
- if !deleted > 0 then
- Printf.printf "Deleted %d failed layers for rebuild\n%!" !deleted
- end;
- let n_cached = List.length (List.filter (fun (node : Day11_opam_layer.Build.t) ->
- Layer.exists env (Build.layer ~os_dir node)
- ) nodes) in
- Printf.printf "Layers: %d cached, %d to build\n%!" n_cached
- (List.length nodes - n_cached);
- if n_cached = List.length nodes && doc_output = None then begin
- Printf.printf "Everything cached, nothing to do.\n%!"; 0
- end else begin
- (* Build — [ensure_base] handles both the opam-build binary and
+ let solution = solve_result.Day11_solution.Solve_result.build_deps in
+ let doc_solution = solve_result.Day11_solution.Solve_result.doc_deps in
+ Printf.printf "Solved: %d packages\n%!"
+ (OpamPackage.Map.cardinal solution);
+ (* Build DAG — uses the ctx's shared hash cache + base hash. *)
+ let patches = ctx.patches in
+ let cache = ctx.hash_cache in
+ let dag_solutions = [ (target, solution, doc_solution) ] in
+ let nodes =
+ Day11_opam_build.Dag.build_dag cache ~base_hash:ctx.base.hash
+ dag_solutions
+ in
+ Printf.printf "DAG: %d nodes\n%!" (List.length nodes);
+ (* Delete failed layers if requested *)
+ if rebuild_failed then (
+ let deleted = ref 0 in
+ List.iter
+ (fun (node : Day11_opam_layer.Build.t) ->
+ let layer = Build.layer ~os_dir node in
+ if Layer.exists env layer then
+ match Day11_layer.Meta.load env (Layer.meta_path layer) with
+ | Ok { exit_status; _ } when exit_status <> 0 ->
+ ignore (Bos.OS.Path.delete ~recurse:true (Layer.dir layer));
+ incr deleted
+ | _ -> ())
+ nodes;
+ if !deleted > 0 then
+ Printf.printf "Deleted %d failed layers for rebuild\n%!" !deleted);
+ let n_cached =
+ List.length
+ (List.filter
+ (fun (node : Day11_opam_layer.Build.t) ->
+ Layer.exists env (Build.layer ~os_dir node))
+ nodes)
+ in
+ Printf.printf "Layers: %d cached, %d to build\n%!" n_cached
+ (List.length nodes - n_cached);
+ if n_cached = List.length nodes && doc_output = None then (
+ Printf.printf "Everything cached, nothing to do.\n%!";
+ 0)
+ else
+ (* Build — [ensure_base] handles both the opam-build binary and
the base image. *)
- let ctx = match Day11_batch.Profile_ctx.ensure_base ~sw env ctx with
- | Ok c -> c
- | Error (`Msg e) ->
- Printf.eprintf "Base image build failed: %s\n%!" e; exit 1
- in
- let benv = ctx.benv in
- Day11_opam_build.Types.ensure_dirs benv;
- (* Repo mount — reuse from snapshot if available, else build fresh *)
- let merged_repo_dir = Fpath.(snapshot_dir / "merged-repo") in
- (match Day11_opam_layer.Opam_repo.build_merged
- ~dest:merged_repo_dir profile.opam_repositories with
- | Ok () -> ()
- | Error (`Msg e) ->
- Printf.eprintf "Failed to build merged repo: %s\n%!" e; exit 1);
- let repo_mount = Day11_container.Mount.bind_rw
- ~src:(Fpath.to_string merged_repo_dir)
- "/home/opam/.opam/repo/default" in
- let opam_build_repo = Option.map Fpath.v profile.opam_build_repo in
- let base_mounts =
- [ repo_mount ] @
- (match Day11_opam_build.Base.opam_build_mount ~cache_dir:paths.cache_dir
- ?opam_build_repo () with
- | Some m -> [ m ] | None -> [])
- in
- let packages_dir = Day11_batch.Snapshot.packages_dir snapshot_dir in
- ignore (Bos.OS.Dir.create ~path:true packages_dir);
- (* Build phase *)
- let open Day11_opam_build.Dag_executor in
- execute env ~np
- ~is_cached:(fun node ->
- let layer = Build.layer ~os_dir node in
- if not (Layer.exists env layer) then
- Not_cached
- else
- match Day11_layer.Meta.load env (Layer.meta_path layer) with
- | Ok meta when meta.exit_status = 0 ->
- Day11_layer.Last_used.touch env (Layer.dir layer);
- Cached_ok
- | _ -> Cached_fail)
- ~on_complete:(fun ~stats ~cached:_ node success ->
- if success then begin
- let pkg_str = OpamPackage.to_string node.pkg in
- let layer_name = Day11_opam_layer.Build.dir_name node in
- ignore (Day11_layer.Symlinks.ensure env ~packages_dir ~id:pkg_str ~layer_name)
- end;
- if stats.completed mod 10 = 0 || not success then
- Printf.printf "[%d/%d, %d ok, %d failed] %s: %s\n%!"
- stats.completed stats.total stats.ok stats.failed
- (OpamPackage.to_string node.pkg)
- (if success then "OK" else "FAIL"))
- ~on_cascade:(fun ~failed ~failed_dep ->
- let layer = Build.layer ~os_dir failed in
- ignore (Bos.OS.Dir.create ~path:true (Layer.dir layer));
- if not (Layer.exists env layer) then begin
- let meta : Day11_layer.Meta.t = {
- exit_status = 1; parent_hashes = [];
- uid = benv.uid; gid = benv.gid;
- base_hash = benv.base.hash;
- disk_usage = 0;
- timing = Day11_layer.Meta.empty_timing;
- created_at = "";
- failed_dep = Some (Day11_opam_layer.Build.dir_name failed_dep);
- } in
- ignore (Day11_layer.Meta.save env (Layer.meta_path layer) meta)
- end)
- nodes
- (fun node ->
- let opam_repos_fpath =
- List.map Fpath.v profile.opam_repositories in
- match Day11_opam_build.Build_layer.build ~backend ~sw env benv ?patches
- ~opam_repositories:opam_repos_fpath
- ~mounts:base_mounts node () with
- | Day11_opam_build.Types.Success _ -> true
- | _ -> false);
- (* Doc phase — only if --with-doc <dir> *)
- (match doc_output with
- | None -> ()
- | Some output_dir ->
- Printf.printf "\nGenerating docs to %s...\n%!" output_dir;
- let output = Fpath.v output_dir in
- ignore (Bos.OS.Dir.create ~path:true output);
- let solutions = [ (target, solve_result) ] in
- let blessing_maps =
- [ (target, OpamPackage.Map.map (fun _ -> true) solution) ] in
- Day11_lib.Run_log.set_log_base_dir (Fpath.to_string snapshot_dir);
- let run_log = Day11_lib.Run_log.start_run () in
- Day11_doc.Generate.build_tools_and_run ~sw env ctx ~np
- ~mounts:base_mounts
- ~build_one:(fun node ->
- match Day11_opam_build.Build_layer.build ~sw env benv ?patches
- ~opam_repositories:(List.map Fpath.v profile.opam_repositories)
- ~mounts:base_mounts node () with
- | Day11_opam_build.Types.Success _ -> true
- | _ -> false)
- ~run_log
- ~nodes ~solutions ~blessing_maps ();
- (* Copy HTML for packages in this solution to the output dir *)
- let html_root = Fpath.(os_dir / "html" / "p") in
- let n_copied = ref 0 in
- OpamPackage.Map.iter (fun pkg _ ->
- let name = OpamPackage.Name.to_string (OpamPackage.name pkg) in
- let ver = OpamPackage.Version.to_string (OpamPackage.version pkg) in
- let src = Fpath.(html_root / name / ver) in
- if Bos.OS.Dir.exists src |> Result.get_ok then begin
- let dst = Fpath.(output / name / ver) in
- ignore (Bos.OS.Dir.create ~path:true (Fpath.parent dst));
- ignore (Sys.command (Printf.sprintf "cp -a %s %s"
- (Fpath.to_string src) (Fpath.to_string dst)));
- incr n_copied
- end
- ) solution;
- Printf.printf "Copied docs for %d packages to %s\n%!" !n_copied output_dir);
- Printf.printf "Done.\n%!";
- 0
- end
- | _ -> Printf.eprintf "Unexpected result\n%!"; 1
+ let ctx =
+ match Day11_batch.Profile_ctx.ensure_base ~sw env ctx with
+ | Ok c -> c
+ | Error (`Msg e) ->
+ Printf.eprintf "Base image build failed: %s\n%!" e;
+ exit 1
+ in
+ let benv = ctx.benv in
+ Day11_opam_build.Types.ensure_dirs benv;
+ (* Repo mount — reuse from snapshot if available, else build fresh *)
+ let merged_repo_dir = Fpath.(snapshot_dir / "merged-repo") in
+ (match
+ Day11_opam_layer.Opam_repo.build_merged ~dest:merged_repo_dir
+ profile.opam_repositories
+ with
+ | Ok () -> ()
+ | Error (`Msg e) ->
+ Printf.eprintf "Failed to build merged repo: %s\n%!" e;
+ exit 1);
+ let repo_mount =
+ Day11_container.Mount.bind_rw
+ ~src:(Fpath.to_string merged_repo_dir)
+ "/home/opam/.opam/repo/default"
+ in
+ let opam_build_repo = Option.map Fpath.v profile.opam_build_repo in
+ let base_mounts =
+ [ repo_mount ]
+ @
+ match
+ Day11_opam_build.Base.opam_build_mount ~cache_dir:paths.cache_dir
+ ?opam_build_repo ()
+ with
+ | Some m -> [ m ]
+ | None -> []
+ in
+ let packages_dir = Day11_batch.Snapshot.packages_dir snapshot_dir in
+ ignore (Bos.OS.Dir.create ~path:true packages_dir);
+ (* Build phase *)
+ let open Day11_opam_build.Dag_executor in
+ execute env ~np
+ ~is_cached:(fun node ->
+ let layer = Build.layer ~os_dir node in
+ if not (Layer.exists env layer) then Not_cached
+ else
+ match Day11_layer.Meta.load env (Layer.meta_path layer) with
+ | Ok meta when meta.exit_status = 0 ->
+ Day11_layer.Last_used.touch env (Layer.dir layer);
+ Cached_ok
+ | _ -> Cached_fail)
+ ~on_complete:(fun ~stats ~cached:_ node success ->
+ (if success then
+ let pkg_str = OpamPackage.to_string node.pkg in
+ let layer_name = Day11_opam_layer.Build.dir_name node in
+ ignore
+ (Day11_layer.Symlinks.ensure env ~packages_dir ~id:pkg_str
+ ~layer_name));
+ if stats.completed mod 10 = 0 || not success then
+ Printf.printf "[%d/%d, %d ok, %d failed] %s: %s\n%!"
+ stats.completed stats.total stats.ok stats.failed
+ (OpamPackage.to_string node.pkg)
+ (if success then "OK" else "FAIL"))
+ ~on_cascade:(fun ~failed ~failed_dep ->
+ let layer = Build.layer ~os_dir failed in
+ ignore (Bos.OS.Dir.create ~path:true (Layer.dir layer));
+ if not (Layer.exists env layer) then
+ let meta : Day11_layer.Meta.t =
+ {
+ exit_status = 1;
+ parent_hashes = [];
+ uid = benv.uid;
+ gid = benv.gid;
+ base_hash = benv.base.hash;
+ disk_usage = 0;
+ timing = Day11_layer.Meta.empty_timing;
+ created_at = "";
+ failed_dep = Some (Day11_opam_layer.Build.dir_name failed_dep);
+ }
+ in
+ ignore (Day11_layer.Meta.save env (Layer.meta_path layer) meta))
+ nodes
+ (fun node ->
+ let opam_repos_fpath = List.map Fpath.v profile.opam_repositories in
+ match
+ Day11_opam_build.Build_layer.build ~backend ~sw env benv ?patches
+ ~opam_repositories:opam_repos_fpath ~mounts:base_mounts node ()
+ with
+ | Day11_opam_build.Types.Success _ -> true
+ | _ -> false);
+ (* Doc phase — only if --with-doc <dir> *)
+ (match doc_output with
+ | None -> ()
+ | Some output_dir ->
+ Printf.printf "\nGenerating docs to %s...\n%!" output_dir;
+ let output = Fpath.v output_dir in
+ ignore (Bos.OS.Dir.create ~path:true output);
+ let solutions = [ (target, solve_result) ] in
+ let blessing_maps =
+ [ (target, OpamPackage.Map.map (fun _ -> true) solution) ]
+ in
+ Day11_lib.Run_log.set_log_base_dir (Fpath.to_string snapshot_dir);
+ let run_log = Day11_lib.Run_log.start_run () in
+ Day11_doc.Generate.build_tools_and_run ~sw env ctx ~np
+ ~mounts:base_mounts
+ ~build_one:(fun node ->
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv ?patches
+ ~opam_repositories:
+ (List.map Fpath.v profile.opam_repositories)
+ ~mounts:base_mounts node ()
+ with
+ | Day11_opam_build.Types.Success _ -> true
+ | _ -> false)
+ ~run_log ~nodes ~solutions ~blessing_maps ();
+ (* Copy HTML for packages in this solution to the output dir *)
+ let html_root = Fpath.(os_dir / "html" / "p") in
+ let n_copied = ref 0 in
+ OpamPackage.Map.iter
+ (fun pkg _ ->
+ let name = OpamPackage.Name.to_string (OpamPackage.name pkg) in
+ let ver =
+ OpamPackage.Version.to_string (OpamPackage.version pkg)
+ in
+ let src = Fpath.(html_root / name / ver) in
+ if Bos.OS.Dir.exists src |> Result.get_ok then (
+ let dst = Fpath.(output / name / ver) in
+ ignore (Bos.OS.Dir.create ~path:true (Fpath.parent dst));
+ ignore
+ (Sys.command
+ (Printf.sprintf "cp -a %s %s" (Fpath.to_string src)
+ (Fpath.to_string dst)));
+ incr n_copied))
+ solution;
+ Printf.printf "Copied docs for %d packages to %s\n%!" !n_copied
+ output_dir);
+ Printf.printf "Done.\n%!";
+ 0
+ | _ ->
+ Printf.eprintf "Unexpected result\n%!";
+ 1
let doc_output_term =
let doc = "Generate documentation and write HTML to DIR" in
@@ -214,8 +248,10 @@ let rebuild_failed_term =
Arg.(value & flag & info [ "rebuild-failed" ] ~doc)
let native_term =
- let doc = "Use the native (host-side) backend instead of the \
- runc + overlayfs container backend." in
+ let doc =
+ "Use the native (host-side) backend instead of the runc + overlayfs \
+ container backend."
+ in
Arg.(value & flag & info [ "native" ] ~doc)
let target_term =
@@ -226,6 +262,12 @@ let cmd =
let doc = "Solve and build a single package" in
let info = Cmd.info "build" ~doc in
Cmd.v info
- Term.(const run $ Common.profile_term $ Common.profile_dir_term
- $ Common.np_term $ target_term $ doc_output_term
- $ rebuild_failed_term $ native_term)
+ Term.(
+ const run
+ $ Common.profile_term
+ $ Common.profile_dir_term
+ $ Common.np_term
+ $ target_term
+ $ doc_output_term
+ $ rebuild_failed_term
+ $ native_term)
File "day11/bin/cmd_cascade.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_cascade.ml b/_build/default/day11/bin/.formatted/cmd_cascade.ml
index 9bbe52e..d3d225e 100644
--- a/_build/default/day11/bin/cmd_cascade.ml
+++ b/_build/default/day11/bin/.formatted/cmd_cascade.ml
@@ -1,13 +1,16 @@
-(** cascade command: derive cascade attribution from the planned DAG
- plus per-package history. *)
+(** cascade command: derive cascade attriution from the planned DAG plus
+ per-package history. *)
open Cmdliner
module Cascade = Day11_lib.Cascade
module Dag_marshal = Day11_lib.Dag_marshal
let kind_label : Dag_marshal.kind -> string = function
- | Build -> "build" | Tool -> "tool" | Compile -> "compile"
- | Doc_all -> "doc-all" | Link -> "link"
+ | Build -> "build"
+ | Tool -> "tool"
+ | Compile -> "compile"
+ | Doc_all -> "doc-all"
+ | Link -> "link"
let short h = String.sub h 0 (min 12 (String.length h))
@@ -18,88 +21,101 @@ let load_dag ~snapshot_dir =
match Dag_marshal.read ~snapshot_dir with
| Ok entries -> Some entries
| Error (`Msg m) ->
- Printf.eprintf " warning: could not read dag.json: %s\n%!" m;
- None
+ Printf.eprintf " warning: could not read dag.json: %s\n%!" m;
+ None
(** Show the cascade story for a single package. *)
let show_for_package ~entries ~table pkg_str =
let matches =
- List.filter (fun (e : Dag_marshal.entry) ->
- OpamPackage.to_string e.pkg = pkg_str
- || OpamPackage.Name.to_string (OpamPackage.name e.pkg) = pkg_str
- ) entries
+ List.filter
+ (fun (e : Dag_marshal.entry) ->
+ OpamPackage.to_string e.pkg = pkg_str
+ || OpamPackage.Name.to_string (OpamPackage.name e.pkg) = pkg_str)
+ entries
in
- if matches = [] then begin
+ if matches = [] then (
Printf.printf "No DAG entries found for %s\n" pkg_str;
- 1
- end else begin
- Printf.printf "DAG entries for %s (%d):\n\n" pkg_str
- (List.length matches);
- List.iter (fun (e : Dag_marshal.entry) ->
- let r = Hashtbl.find table e.hash in
- let status_s = match r.Cascade.status with
- | Ok -> "ok"
- | Failed -> "FAILED (root cause)"
- | Cascade src ->
- let src_e = List.find (fun (x : Dag_marshal.entry) ->
- x.hash = src) entries in
- Printf.sprintf "cascade ← %s [%s] (%s)"
- (OpamPackage.to_string src_e.pkg)
- (kind_label src_e.kind) (short src)
- | Pending -> "pending (no upstream failure)"
- in
- Printf.printf " %s %s %s\n"
- (short e.hash) (kind_label e.kind) status_s
- ) matches;
- 0
- end
+ 1)
+ else (
+ Printf.printf "DAG entries for %s (%d):\n\n" pkg_str (List.length matches);
+ List.iter
+ (fun (e : Dag_marshal.entry) ->
+ let r = Hashtbl.find table e.hash in
+ let status_s =
+ match r.Cascade.status with
+ | Ok -> "ok"
+ | Failed -> "FAILED (root cause)"
+ | Cascade src ->
+ let src_e =
+ List.find (fun (x : Dag_marshal.entry) -> x.hash = src) entries
+ in
+ Printf.sprintf "cascade ← %s [%s] (%s)"
+ (OpamPackage.to_string src_e.pkg)
+ (kind_label src_e.kind) (short src)
+ | Pending -> "pending (no upstream failure)"
+ in
+ Printf.printf " %s %s %s\n" (short e.hash) (kind_label e.kind)
+ status_s)
+ matches;
+ 0)
(** Group cascaded nodes under their root cause, sort by fanout. *)
let summarise ~entries ~table ~verbose =
let by_root : (string, Dag_marshal.entry list) Hashtbl.t =
- Hashtbl.create 32 in
+ Hashtbl.create 32
+ in
let pending = ref [] in
- List.iter (fun (e : Dag_marshal.entry) ->
- let r = Hashtbl.find table e.hash in
- match r.Cascade.status with
- | Ok -> ()
- | Failed ->
- let prev = try Hashtbl.find by_root e.hash with Not_found -> [] in
- Hashtbl.replace by_root e.hash (e :: prev)
- | Cascade src ->
- let prev = try Hashtbl.find by_root src with Not_found -> [] in
- Hashtbl.replace by_root src (e :: prev)
- | Pending -> pending := e :: !pending
- ) entries;
- let groups = Hashtbl.fold (fun root members acc ->
- let root_e = List.find (fun (x : Dag_marshal.entry) ->
- x.hash = root) entries in
- (* Members include the root itself; cascaded count excludes it. *)
- let cascaded = List.filter (fun (x : Dag_marshal.entry) ->
- x.hash <> root) members in
- (root_e, cascaded) :: acc
- ) by_root [] in
- let groups = List.sort (fun (_, a) (_, b) ->
- compare (List.length b) (List.length a)) groups in
- if groups = [] then
- Printf.printf "No failures.\n"
- else begin
- Printf.printf "%d root cause%s, %d cascaded:\n\n"
- (List.length groups)
+ List.iter
+ (fun (e : Dag_marshal.entry) ->
+ let r = Hashtbl.find table e.hash in
+ match r.Cascade.status with
+ | Ok -> ()
+ | Failed ->
+ let prev = try Hashtbl.find by_root e.hash with Not_found -> [] in
+ Hashtbl.replace by_root e.hash (e :: prev)
+ | Cascade src ->
+ let prev = try Hashtbl.find by_root src with Not_found -> [] in
+ Hashtbl.replace by_root src (e :: prev)
+ | Pending -> pending := e :: !pending)
+ entries;
+ let groups =
+ Hashtbl.fold
+ (fun root members acc ->
+ let root_e =
+ List.find (fun (x : Dag_marshal.entry) -> x.hash = root) entries
+ in
+ (* Members include the root itself; cascaded count excludes it. *)
+ let cascaded =
+ List.filter (fun (x : Dag_marshal.entry) -> x.hash <> root) members
+ in
+ (root_e, cascaded) :: acc)
+ by_root []
+ in
+ let groups =
+ List.sort
+ (fun (_, a) (_, b) -> compare (List.length b) (List.length a))
+ groups
+ in
+ if groups = [] then Printf.printf "No failures.\n"
+ else (
+ Printf.printf "%d root cause%s, %d cascaded:\n\n" (List.length groups)
(if List.length groups = 1 then "" else "s")
(List.fold_left (fun acc (_, cs) -> acc + List.length cs) 0 groups);
- List.iter (fun (root, cascaded) ->
- Printf.printf " %s (hash %s) → %d cascaded\n"
- (pkg_kind_label root) (short root.hash) (List.length cascaded);
- if verbose && cascaded <> [] then
- List.iter (fun (e : Dag_marshal.entry) ->
- Printf.printf " %s (%s)\n"
- (pkg_kind_label e) (short e.hash))
- (List.sort (fun (a : Dag_marshal.entry) b ->
- compare (OpamPackage.to_string a.pkg)
- (OpamPackage.to_string b.pkg)) cascaded)
- ) groups
- end;
+ List.iter
+ (fun (root, cascaded) ->
+ Printf.printf " %s (hash %s) → %d cascaded\n" (pkg_kind_label root)
+ (short root.hash) (List.length cascaded);
+ if verbose && cascaded <> [] then
+ List.iter
+ (fun (e : Dag_marshal.entry) ->
+ Printf.printf " %s (%s)\n" (pkg_kind_label e) (short e.hash))
+ (List.sort
+ (fun (a : Dag_marshal.entry) b ->
+ compare
+ (OpamPackage.to_string a.pkg)
+ (OpamPackage.to_string b.pkg))
+ cascaded))
+ groups);
if !pending <> [] then
Printf.printf "\n%d pending (in-flight or not yet attempted)\n"
(List.length !pending);
@@ -107,32 +123,51 @@ let summarise ~entries ~table ~verbose =
let run profile_name profile_dir package verbose =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (_profile, paths) ->
- match Common.latest_snapshot_dir paths with
- | None -> Printf.printf "No snapshots found\n"; 1
- | Some snapshot_dir ->
- match load_dag ~snapshot_dir with
- | None -> Printf.printf "No dag.json in latest snapshot\n"; 1
- | Some entries ->
- let packages_dir = Fpath.(snapshot_dir / "packages") in
- let table = Cascade.classify ~packages_dir entries in
- match package with
- | Some pkg -> show_for_package ~entries ~table pkg
- | None -> summarise ~entries ~table ~verbose
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (_profile, paths) -> (
+ match Common.latest_snapshot_dir paths with
+ | None ->
+ Printf.printf "No snapshots found\n";
+ 1
+ | Some snapshot_dir -> (
+ match load_dag ~snapshot_dir with
+ | None ->
+ Printf.printf "No dag.json in latest snapshot\n";
+ 1
+ | Some entries -> (
+ let packages_dir = Fpath.(snapshot_dir / "packages") in
+ let table = Cascade.classify ~packages_dir entries in
+ match package with
+ | Some pkg -> show_for_package ~entries ~table pkg
+ | None -> summarise ~entries ~table ~verbose)))
let package_term =
- Arg.(value & opt (some string) None
- & info ["package"; "p"] ~docv:"PACKAGE"
- ~doc:"Show cascade detail for one package (full version or name).")
+ Arg.(
+ value
+ & opt (some string) None
+ & info [ "package"; "p" ] ~docv:"PACKAGE"
+ ~doc:"Show cascade detail for one package (full version or name).")
let verbose_term =
- Arg.(value & flag & info ["v"; "verbose"]
- ~doc:"List cascaded packages under each root cause.")
+ Arg.(
+ value
+ & flag
+ & info [ "v"; "verbose" ]
+ ~doc:"List cascaded packages under each root cause.")
let cmd =
- let info = Cmd.info "cascade"
- ~doc:"Derive cascade attribution from the planned DAG and history" in
- let term = Term.(const run $ Common.profile_term $ Common.profile_dir_term
- $ package_term $ verbose_term) in
+ let info =
+ Cmd.info "cascade"
+ ~doc:"Derive cascade attribution from the planned DAG and history"
+ in
+ let term =
+ Term.(
+ const run
+ $ Common.profile_term
+ $ Common.profile_dir_term
+ $ package_term
+ $ verbose_term)
+ in
Cmd.v info term
File "day11/bin/cmd_diff.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_diff.ml b/_build/default/day11/bin/.formatted/cmd_diff.ml
index b01fc01..7f2b21c 100644
--- a/_build/default/day11/bin/cmd_diff.ml
+++ b/_build/default/day11/bin/.formatted/cmd_diff.ml
@@ -8,144 +8,161 @@ let load_solutions snap_dir =
match Bos.OS.Dir.contents sol_dir with
| Error _ -> []
| Ok files ->
- List.filter_map (fun path ->
- if not (Fpath.has_ext ".json" path) then None
- else if Fpath.basename path = "repos.json" then None
- else
- match Day11_batch.Incremental_solver.load path with
- | Ok (Day11_batch.Incremental_solver.Cached_solution { package; result; _ }) ->
- Some (package, Some result)
- | Ok (Day11_batch.Incremental_solver.Cached_failure { package; _ }) ->
- Some (package, None)
- | Error _ -> None
- ) files
+ List.filter_map
+ (fun path ->
+ if not (Fpath.has_ext ".json" path) then None
+ else if Fpath.basename path = "repos.json" then None
+ else
+ match Day11_batch.Incremental_solver.load path with
+ | Ok
+ (Day11_batch.Incremental_solver.Cached_solution
+ { package; result; _ }) ->
+ Some (package, Some result)
+ | Ok (Day11_batch.Incremental_solver.Cached_failure { package; _ })
+ ->
+ Some (package, None)
+ | Error _ -> None)
+ files
(* Extract package -> version map from solutions *)
let version_map solutions =
- List.fold_left (fun acc (pkg, result) ->
- let name = OpamPackage.Name.to_string (OpamPackage.name pkg) in
- let ver = OpamPackage.Version.to_string (OpamPackage.version pkg) in
- let solved = result <> None in
- let deps = match result with
- | Some r -> OpamPackage.Map.cardinal r.Day11_solution.Solve_result.build_deps
- | None -> 0
- in
- (name, (ver, solved, deps)) :: acc
- ) [] solutions
+ List.fold_left
+ (fun acc (pkg, result) ->
+ let name = OpamPackage.Name.to_string (OpamPackage.name pkg) in
+ let ver = OpamPackage.Version.to_string (OpamPackage.version pkg) in
+ let solved = result <> None in
+ let deps =
+ match result with
+ | Some r ->
+ OpamPackage.Map.cardinal r.Day11_solution.Solve_result.build_deps
+ | None -> 0
+ in
+ (name, (ver, solved, deps)) :: acc)
+ [] solutions
let run profile_name profile_dir snap1_key snap2_key =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
| Ok (_profile, paths) ->
- let all_snaps = Common.snapshot_dirs_by_recency paths in
- if List.length all_snaps < 2 && snap1_key = None then begin
- Printf.printf "Need at least 2 snapshots to diff (have %d)\n%!"
- (List.length all_snaps);
- 1
- end else
- (* Resolve snapshot dirs *)
- let find_snap key =
- List.find_opt (fun p ->
- String.equal (Fpath.basename p) key
- ) all_snaps
- in
- let snap1_dir, snap2_dir = match snap1_key, snap2_key with
- | Some k1, Some k2 ->
- (match find_snap k1, find_snap k2 with
- | Some d1, Some d2 -> (d1, d2)
- | None, _ -> Printf.eprintf "Snapshot %s not found\n" k1; exit 1
- | _, None -> Printf.eprintf "Snapshot %s not found\n" k2; exit 1)
- | _ ->
- (* Default: compare two most recent *)
- (match all_snaps with
- | d1 :: d2 :: _ -> (d2, d1) (* older first *)
- | _ -> Printf.eprintf "Not enough snapshots\n"; exit 1)
- in
- let key1 = Fpath.basename snap1_dir in
- let key2 = Fpath.basename snap2_dir in
- (* Load snapshot metadata *)
- let snap1 = Day11_batch.Snapshot.load snap1_dir in
- let snap2 = Day11_batch.Snapshot.load snap2_dir in
- Printf.printf "Comparing snapshots:\n";
- Printf.printf " Old: %s" key1;
- (match snap1 with
- | Ok s -> Printf.printf " (%s)" s.created | _ -> ());
- Printf.printf "\n";
- Printf.printf " New: %s" key2;
- (match snap2 with
- | Ok s -> Printf.printf " (%s)" s.created | _ -> ());
- Printf.printf "\n\n";
- (* Load solutions *)
- let sols1 = version_map (load_solutions snap1_dir) in
- let sols2 = version_map (load_solutions snap2_dir) in
- let tbl1 = Hashtbl.create (List.length sols1) in
- List.iter (fun (name, v) -> Hashtbl.replace tbl1 name v) sols1;
- let tbl2 = Hashtbl.create (List.length sols2) in
- List.iter (fun (name, v) -> Hashtbl.replace tbl2 name v) sols2;
- (* Collect all package names *)
- let all_names = Hashtbl.create 64 in
- Hashtbl.iter (fun k _ -> Hashtbl.replace all_names k ()) tbl1;
- Hashtbl.iter (fun k _ -> Hashtbl.replace all_names k ()) tbl2;
- let names = Hashtbl.fold (fun k () acc -> k :: acc) all_names []
- |> List.sort String.compare in
- (* Categorize changes *)
- let added = ref [] in
- let removed = ref [] in
- let version_changed = ref [] in
- let solve_changed = ref [] in
- let unchanged = ref 0 in
- List.iter (fun name ->
- match Hashtbl.find_opt tbl1 name, Hashtbl.find_opt tbl2 name with
- | None, Some (ver, solved, _) ->
- added := (name, ver, solved) :: !added
- | Some (ver, solved, _), None ->
- removed := (name, ver, solved) :: !removed
- | Some (v1, s1, _), Some (v2, s2, _) ->
- if v1 <> v2 then
- version_changed := (name, v1, v2) :: !version_changed
- else if s1 <> s2 then
- solve_changed := (name, s1, s2) :: !solve_changed
+ let all_snaps = Common.snapshot_dirs_by_recency paths in
+ if List.length all_snaps < 2 && snap1_key = None then (
+ Printf.printf "Need at least 2 snapshots to diff (have %d)\n%!"
+ (List.length all_snaps);
+ 1)
else
- incr unchanged
- | None, None -> ()
- ) names;
- (* Print results *)
- if !version_changed <> [] then begin
- Printf.printf "Version changes:\n";
- List.iter (fun (name, v1, v2) ->
- Printf.printf " %s: %s -> %s\n" name v1 v2
- ) (List.rev !version_changed);
- Printf.printf "\n"
- end;
- if !added <> [] then begin
- Printf.printf "Added:\n";
- List.iter (fun (name, ver, solved) ->
- Printf.printf " %s.%s%s\n" name ver
- (if solved then "" else " (solve failed)")
- ) (List.rev !added);
- Printf.printf "\n"
- end;
- if !removed <> [] then begin
- Printf.printf "Removed:\n";
- List.iter (fun (name, ver, solved) ->
- Printf.printf " %s.%s%s\n" name ver
- (if solved then "" else " (was failing)")
- ) (List.rev !removed);
- Printf.printf "\n"
- end;
- if !solve_changed <> [] then begin
- Printf.printf "Solve status changed:\n";
- List.iter (fun (name, was_ok, now_ok) ->
- let status = if now_ok then "now solves" else "now fails" in
- ignore was_ok;
- Printf.printf " %s: %s\n" name status
- ) (List.rev !solve_changed);
- Printf.printf "\n"
- end;
- Printf.printf "Summary: %d unchanged, %d version changes, %d added, %d removed, %d solve changes\n"
- !unchanged (List.length !version_changed)
- (List.length !added) (List.length !removed) (List.length !solve_changed);
- 0
+ (* Resolve snapshot dirs *)
+ let find_snap key =
+ List.find_opt (fun p -> String.equal (Fpath.basename p) key) all_snaps
+ in
+ let snap1_dir, snap2_dir =
+ match (snap1_key, snap2_key) with
+ | Some k1, Some k2 -> (
+ match (find_snap k1, find_snap k2) with
+ | Some d1, Some d2 -> (d1, d2)
+ | None, _ ->
+ Printf.eprintf "Snapshot %s not found\n" k1;
+ exit 1
+ | _, None ->
+ Printf.eprintf "Snapshot %s not found\n" k2;
+ exit 1)
+ | _ -> (
+ (* Default: compare two most recent *)
+ match all_snaps with
+ | d1 :: d2 :: _ -> (d2, d1) (* older first *)
+ | _ ->
+ Printf.eprintf "Not enough snapshots\n";
+ exit 1)
+ in
+ let key1 = Fpath.basename snap1_dir in
+ let key2 = Fpath.basename snap2_dir in
+ (* Load snapshot metadata *)
+ let snap1 = Day11_batch.Snapshot.load snap1_dir in
+ let snap2 = Day11_batch.Snapshot.load snap2_dir in
+ Printf.printf "Comparing snapshots:\n";
+ Printf.printf " Old: %s" key1;
+ (match snap1 with Ok s -> Printf.printf " (%s)" s.created | _ -> ());
+ Printf.printf "\n";
+ Printf.printf " New: %s" key2;
+ (match snap2 with Ok s -> Printf.printf " (%s)" s.created | _ -> ());
+ Printf.printf "\n\n";
+ (* Load solutions *)
+ let sols1 = version_map (load_solutions snap1_dir) in
+ let sols2 = version_map (load_solutions snap2_dir) in
+ let tbl1 = Hashtbl.create (List.length sols1) in
+ List.iter (fun (name, v) -> Hashtbl.replace tbl1 name v) sols1;
+ let tbl2 = Hashtbl.create (List.length sols2) in
+ List.iter (fun (name, v) -> Hashtbl.replace tbl2 name v) sols2;
+ (* Collect all package names *)
+ let all_names = Hashtbl.create 64 in
+ Hashtbl.iter (fun k _ -> Hashtbl.replace all_names k ()) tbl1;
+ Hashtbl.iter (fun k _ -> Hashtbl.replace all_names k ()) tbl2;
+ let names =
+ Hashtbl.fold (fun k () acc -> k :: acc) all_names []
+ |> List.sort String.compare
+ in
+ (* Categorize changes *)
+ let added = ref [] in
+ let removed = ref [] in
+ let version_changed = ref [] in
+ let solve_changed = ref [] in
+ let unchanged = ref 0 in
+ List.iter
+ (fun name ->
+ match (Hashtbl.find_opt tbl1 name, Hashtbl.find_opt tbl2 name) with
+ | None, Some (ver, solved, _) ->
+ added := (name, ver, solved) :: !added
+ | Some (ver, solved, _), None ->
+ removed := (name, ver, solved) :: !removed
+ | Some (v1, s1, _), Some (v2, s2, _) ->
+ if v1 <> v2 then
+ version_changed := (name, v1, v2) :: !version_changed
+ else if s1 <> s2 then
+ solve_changed := (name, s1, s2) :: !solve_changed
+ else incr unchanged
+ | None, None -> ())
+ names;
+ (* Print results *)
+ if !version_changed <> [] then (
+ Printf.printf "Version changes:\n";
+ List.iter
+ (fun (name, v1, v2) -> Printf.printf " %s: %s -> %s\n" name v1 v2)
+ (List.rev !version_changed);
+ Printf.printf "\n");
+ if !added <> [] then (
+ Printf.printf "Added:\n";
+ List.iter
+ (fun (name, ver, solved) ->
+ Printf.printf " %s.%s%s\n" name ver
+ (if solved then "" else " (solve failed)"))
+ (List.rev !added);
+ Printf.printf "\n");
+ if !removed <> [] then (
+ Printf.printf "Removed:\n";
+ List.iter
+ (fun (name, ver, solved) ->
+ Printf.printf " %s.%s%s\n" name ver
+ (if solved then "" else " (was failing)"))
+ (List.rev !removed);
+ Printf.printf "\n");
+ if !solve_changed <> [] then (
+ Printf.printf "Solve status changed:\n";
+ List.iter
+ (fun (name, was_ok, now_ok) ->
+ let status = if now_ok then "now solves" else "now fails" in
+ ignore was_ok;
+ Printf.printf " %s: %s\n" name status)
+ (List.rev !solve_changed);
+ Printf.printf "\n");
+ Printf.printf
+ "Summary: %d unchanged, %d version changes, %d added, %d removed, %d \
+ solve changes\n"
+ !unchanged
+ (List.length !version_changed)
+ (List.length !added) (List.length !removed)
+ (List.length !solve_changed);
+ 0
let snap1_term =
let doc = "First snapshot key (default: second most recent)" in
@@ -159,5 +176,9 @@ let cmd =
let doc = "Compare two snapshots within a profile" in
let info = Cmd.info "diff" ~doc in
Cmd.v info
- Term.(const run $ Common.profile_term $ Common.profile_dir_term
- $ snap1_term $ snap2_term)
+ Term.(
+ const run
+ $ Common.profile_term
+ $ Common.profile_dir_term
+ $ snap1_term
+ $ snap2_term)
File "day11/bin/cmd_gc.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_gc.ml b/_build/default/day11/bin/.formatted/cmd_gc.ml
index 30ed0fd..e17ce1c 100644
--- a/_build/default/day11/bin/cmd_gc.ml
+++ b/_build/default/day11/bin/.formatted/cmd_gc.ml
@@ -17,8 +17,9 @@ let run profile_dir before_days delete =
Printf.printf "=== Garbage Collection ===\n\n";
Printf.printf "Cache: %s\n" (Fpath.to_string cache_dir);
Printf.printf " Size: %s\n\n"
- (du (Printf.sprintf "du -sh %s 2>/dev/null | cut -f1"
- (Fpath.to_string cache_dir)));
+ (du
+ (Printf.sprintf "du -sh %s 2>/dev/null | cut -f1"
+ (Fpath.to_string cache_dir)));
(* 1. Clean stale temp dirs *)
let n_stale = Day11_lib.Gc.gc_stale_temp_dirs () in
if n_stale > 0 then
@@ -29,57 +30,67 @@ let run profile_dir before_days delete =
match Bos.OS.Dir.contents cache_dir with
| Error _ -> []
| Ok entries ->
- List.filter (fun p ->
- let name = Fpath.basename p in
- name <> "base" && name <> "opam-build-bin" &&
- (Bos.OS.Dir.exists p |> Result.get_ok)
- ) entries
+ List.filter
+ (fun p ->
+ let name = Fpath.basename p in
+ name <> "base"
+ && name <> "opam-build-bin"
+ && Bos.OS.Dir.exists p |> Result.get_ok)
+ entries
in
let total_layers = ref 0 in
let old_layers = ref 0 in
let old_size = ref 0 in
let deleted_count = ref 0 in
- List.iter (fun os_dir ->
- let os_name = Fpath.basename os_dir in
- let entries =
- try Sys.readdir (Fpath.to_string os_dir) |> Array.to_list
- with _ -> [] in
- let layers = List.filter (fun name ->
- (* Layer dirs: 12-char hex or build-<hex> (legacy) *)
- let is_hex c = (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') in
- (String.length name = 12 && String.for_all is_hex name)
- || (String.length name > 6 && String.sub name 0 6 = "build-")
- ) entries in
- total_layers := !total_layers + List.length layers;
- List.iter (fun name ->
- let layer_dir = Fpath.(os_dir / name) in
- let last_used = match Day11_layer.Last_used.get env layer_dir with
- | Some t -> t | None -> 0.0 in
- if last_used < cutoff then begin
- incr old_layers;
- let size =
- try (Unix.stat (Fpath.to_string layer_dir)).Unix.st_size
- with _ -> 0 in
- old_size := !old_size + size;
- if delete then begin
- ignore (Sys.command (Printf.sprintf "sudo rm -rf %s"
- (Fpath.to_string layer_dir)));
- incr deleted_count
- end
- end
- ) layers;
- Printf.printf " %s: %d layers\n" os_name (List.length layers)
- ) os_dirs;
+ List.iter
+ (fun os_dir ->
+ let os_name = Fpath.basename os_dir in
+ let entries =
+ try Sys.readdir (Fpath.to_string os_dir) |> Array.to_list with _ -> []
+ in
+ let layers =
+ List.filter
+ (fun name ->
+ (* Layer dirs: 12-char hex or build-<hex> (legacy) *)
+ let is_hex c = (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') in
+ (String.length name = 12 && String.for_all is_hex name)
+ || (String.length name > 6 && String.sub name 0 6 = "build-"))
+ entries
+ in
+ total_layers := !total_layers + List.length layers;
+ List.iter
+ (fun name ->
+ let layer_dir = Fpath.(os_dir / name) in
+ let last_used =
+ match Day11_layer.Last_used.get env layer_dir with
+ | Some t -> t
+ | None -> 0.0
+ in
+ if last_used < cutoff then (
+ incr old_layers;
+ let size =
+ try (Unix.stat (Fpath.to_string layer_dir)).Unix.st_size
+ with _ -> 0
+ in
+ old_size := !old_size + size;
+ if delete then (
+ ignore
+ (Sys.command
+ (Printf.sprintf "sudo rm -rf %s" (Fpath.to_string layer_dir)));
+ incr deleted_count)))
+ layers;
+ Printf.printf " %s: %d layers\n" os_name (List.length layers))
+ os_dirs;
Printf.printf "\nTotal layers: %d\n" !total_layers;
- Printf.printf "Layers last used before %d days ago: %d\n"
- before_days !old_layers;
- if delete then
- Printf.printf "Deleted: %d layers\n" !deleted_count
+ Printf.printf "Layers last used before %d days ago: %d\n" before_days
+ !old_layers;
+ if delete then Printf.printf "Deleted: %d layers\n" !deleted_count
else if !old_layers > 0 then
Printf.printf "Run with --delete to remove them.\n";
Printf.printf "\nCache after: %s\n"
- (du (Printf.sprintf "du -sh %s 2>/dev/null | cut -f1"
- (Fpath.to_string cache_dir)));
+ (du
+ (Printf.sprintf "du -sh %s 2>/dev/null | cut -f1"
+ (Fpath.to_string cache_dir)));
0
let before_term =
@@ -91,8 +102,11 @@ let delete_term =
Arg.(value & flag & info [ "delete" ] ~doc)
let cmd =
- let info = Cmd.info "gc"
- ~doc:"Reclaim disk space by removing old layers from the shared cache" in
- let term = Term.(const run $ Common.profile_dir_term
- $ before_term $ delete_term) in
+ let info =
+ Cmd.info "gc"
+ ~doc:"Reclaim disk space by removing old layers from the shared cache"
+ in
+ let term =
+ Term.(const run $ Common.profile_dir_term $ before_term $ delete_term)
+ in
Cmd.v info term
File "day11/bin/cmd_log.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_log.ml b/_build/default/day11/bin/.formatted/cmd_log.ml
index afa9c61..7a047c0 100644
--- a/_build/default/day11/bin/cmd_log.ml
+++ b/_build/default/day11/bin/.formatted/cmd_log.ml
@@ -6,72 +6,88 @@ module Layer = Day11_layer.Layer
let resolve_layer env os_dir ~packages_dir arg =
(* If it looks like a layer dir name and exists, use it *)
let layer_dir = Fpath.(os_dir / arg) in
- if Bos.OS.Dir.exists layer_dir |> Result.get_ok then
- Some arg
- else begin
+ if Bos.OS.Dir.exists layer_dir |> Result.get_ok then Some arg
+ else
(* Try to look up as a package name in the packages dir *)
- let symlinks = Day11_layer.Scan.list_package_symlinks
- ~exclude:["blessed-build"; "blessed-docs"; "history.jsonl"]
- env packages_dir arg in
+ let symlinks =
+ Day11_layer.Scan.list_package_symlinks
+ ~exclude:[ "blessed-build"; "blessed-docs"; "history.jsonl" ]
+ env packages_dir arg
+ in
match symlinks with
| [] -> None
- | links ->
- (* Pick the most recent layer (last alphabetically, since build-<hash>
+ | links -> (
+ (* Pick the most recent layer (last alphabetically, since build-<hash>
names are stable but we want the latest symlink by mtime) *)
- let ranked = List.filter_map (fun (name, _target) ->
- let path = Fpath.(packages_dir / arg / name) in
- try
- let stat = Unix.stat (Fpath.to_string path) in
- Some (name, stat.Unix.st_mtime)
- with Unix.Unix_error _ -> None
- ) links in
- let sorted = List.sort (fun (_, t1) (_, t2) ->
- compare t2 t1) ranked in
- match sorted with
- | (name, _) :: _ -> Some name
- | [] -> None
- end
+ let ranked =
+ List.filter_map
+ (fun (name, _target) ->
+ let path = Fpath.(packages_dir / arg / name) in
+ try
+ let stat = Unix.stat (Fpath.to_string path) in
+ Some (name, stat.Unix.st_mtime)
+ with Unix.Unix_error _ -> None)
+ links
+ in
+ let sorted = List.sort (fun (_, t1) (_, t2) -> compare t2 t1) ranked in
+ match sorted with (name, _) :: _ -> Some name | [] -> None)
let run profile_name profile_dir arg =
Common.with_eio @@ fun ~sw:_ env ->
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (_profile, paths) ->
- let os_dir = paths.os_dir in
- let packages_dir = match Common.latest_snapshot_dir paths with
- | Some sd -> Fpath.(sd / "packages")
- | None -> Fpath.(os_dir / "packages") in
- let layer = match resolve_layer env os_dir ~packages_dir arg with
- | Some l -> l
- | None ->
- Printf.eprintf "No layer or package found for %s\n" arg;
- exit 1
- in
- let ly = Layer.of_hash ~os_dir layer in
- let layer_dir = Layer.dir ly in
- (* Try layer.log first (build), then odoc-voodoo-all.log (doc) *)
- let log_file =
- let build_log = Layer.log_path ly in
- let doc_log = Fpath.(layer_dir / "odoc-voodoo-all.log") in
- if Bos.OS.File.exists build_log |> Result.get_ok then Some build_log
- else if Bos.OS.File.exists doc_log |> Result.get_ok then Some doc_log
- else None
- in
- match log_file with
- | None ->
- Printf.eprintf "No log found in %s\n" layer;
- 1
- | Some path ->
- (match Bos.OS.File.read path with
- | Ok content -> print_string content; 0
- | Error (`Msg e) -> Printf.eprintf "%s\n" e; 1)
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (_profile, paths) -> (
+ let os_dir = paths.os_dir in
+ let packages_dir =
+ match Common.latest_snapshot_dir paths with
+ | Some sd -> Fpath.(sd / "packages")
+ | None -> Fpath.(os_dir / "packages")
+ in
+ let layer =
+ match resolve_layer env os_dir ~packages_dir arg with
+ | Some l -> l
+ | None ->
+ Printf.eprintf "No layer or package found for %s\n" arg;
+ exit 1
+ in
+ let ly = Layer.of_hash ~os_dir layer in
+ let layer_dir = Layer.dir ly in
+ (* Try layer.log first (build), then odoc-voodoo-all.log (doc) *)
+ let log_file =
+ let build_log = Layer.log_path ly in
+ let doc_log = Fpath.(layer_dir / "odoc-voodoo-all.log") in
+ if Bos.OS.File.exists build_log |> Result.get_ok then Some build_log
+ else if Bos.OS.File.exists doc_log |> Result.get_ok then Some doc_log
+ else None
+ in
+ match log_file with
+ | None ->
+ Printf.eprintf "No log found in %s\n" layer;
+ 1
+ | Some path -> (
+ match Bos.OS.File.read path with
+ | Ok content ->
+ print_string content;
+ 0
+ | Error (`Msg e) ->
+ Printf.eprintf "%s\n" e;
+ 1))
let target_term =
- Arg.(required & pos 0 (some string) None & info [] ~docv:"TARGET"
- ~doc:"Layer directory name (e.g. build-abc123) or package name (e.g. astring.0.8.5)")
+ Arg.(
+ required
+ & pos 0 (some string) None
+ & info [] ~docv:"TARGET"
+ ~doc:
+ "Layer directory name (e.g. build-abc123) or package name (e.g. \
+ astring.0.8.5)")
let cmd =
let info = Cmd.info "log" ~doc:"View build or doc log" in
- let term = Term.(const run $ Common.profile_term $ Common.profile_dir_term
- $ target_term) in
+ let term =
+ Term.(
+ const run $ Common.profile_term $ Common.profile_dir_term $ target_term)
+ in
Cmd.v info term
File "day11/bin/cmd_profile.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_profile.ml b/_build/default/day11/bin/.formatted/cmd_profile.ml
index 2c05af9..a63b2be 100644
--- a/_build/default/day11/bin/cmd_profile.ml
+++ b/_build/default/day11/bin/.formatted/cmd_profile.ml
@@ -7,8 +7,7 @@ let profile_dir_term =
Arg.(value & opt string "" & info [ "profile-dir" ] ~docv:"DIR" ~doc)
let resolve_profile_dir s =
- if s = "" then Day11_batch.Profile.default_dir ()
- else Fpath.v s
+ if s = "" then Day11_batch.Profile.default_dir () else Fpath.v s
let name_term =
let doc = "Profile name" in
@@ -17,13 +16,14 @@ let name_term =
(* ── create ────────────────────────────────────────────────────── *)
let opam_repo_term =
- let doc = "opam-repository path (repeatable, layered in order). \
- Stored verbatim in the profile; a relative path is taken \
- relative to the .day11 root (the profile dir's parent) \
- when the profile is later loaded, so it needn't be \
- absolute." in
- Arg.(non_empty & opt_all string [] &
- info [ "opam-repository" ] ~docv:"DIR" ~doc)
+ let doc =
+ "opam-repository path (repeatable, layered in order). Stored verbatim in \
+ the profile; a relative path is taken relative to the .day11 root (the \
+ profile dir's parent) when the profile is later loaded, so it needn't be \
+ absolute."
+ in
+ Arg.(
+ non_empty & opt_all string [] & info [ "opam-repository" ] ~docv:"DIR" ~doc)
let odoc_repo_term =
let doc = "Local odoc checkout to pin" in
@@ -31,13 +31,12 @@ let odoc_repo_term =
let opam_build_repo_term =
let doc = "Local opam-build checkout" in
- Arg.(value & opt (some string) None &
- info [ "opam-build-repo" ] ~docv:"DIR" ~doc)
+ Arg.(
+ value & opt (some string) None & info [ "opam-build-repo" ] ~docv:"DIR" ~doc)
let compiler_term =
let doc = "Compiler version constraint (e.g. ocaml-base-compiler.5.4.1)" in
- Arg.(value & opt (some string) None &
- info [ "compiler" ] ~docv:"PKG" ~doc)
+ Arg.(value & opt (some string) None & info [ "compiler" ] ~docv:"PKG" ~doc)
let all_versions_term =
let doc = "Build all versions of each package" in
@@ -57,74 +56,91 @@ let arch_term =
let os_distribution_term =
let doc = "OS distribution (default debian)" in
- Arg.(value & opt string "debian" &
- info [ "os-distribution" ] ~docv:"DIST" ~doc)
+ Arg.(
+ value & opt string "debian" & info [ "os-distribution" ] ~docv:"DIST" ~doc)
let os_version_term =
let doc = "OS version (default bookworm)" in
- Arg.(value & opt string "bookworm" &
- info [ "os-version" ] ~docv:"VER" ~doc)
+ Arg.(value & opt string "bookworm" & info [ "os-version" ] ~docv:"VER" ~doc)
let driver_compiler_term =
- let doc = "Compiler for doc driver tools (default: auto-detect from solutions)" in
- Arg.(value & opt string "" &
- info [ "driver-compiler" ] ~docv:"PKG" ~doc)
+ let doc =
+ "Compiler for doc driver tools (default: auto-detect from solutions)"
+ in
+ Arg.(value & opt string "" & info [ "driver-compiler" ] ~docv:"PKG" ~doc)
let run_create profile_dir name opam_repositories odoc_repo opam_build_repo
- compiler all_versions small_universe with_doc
- arch os_distribution os_version driver_compiler =
+ compiler all_versions small_universe with_doc arch os_distribution
+ os_version driver_compiler =
let dir = Fpath.(resolve_profile_dir profile_dir / "profiles") in
let target_mode : Day11_batch.Profile.target_mode =
if small_universe then
- { versions = Day11_batch.Profile.Latest_n 1;
- names = Day11_batch.Profile.Names Day11_batch.Targets.small_universe }
+ {
+ versions = Day11_batch.Profile.Latest_n 1;
+ names = Day11_batch.Profile.Names Day11_batch.Targets.small_universe;
+ }
else if all_versions then
- { versions = Day11_batch.Profile.All_versions;
- names = Day11_batch.Profile.All_names }
+ {
+ versions = Day11_batch.Profile.All_versions;
+ names = Day11_batch.Profile.All_names;
+ }
else
- { versions = Day11_batch.Profile.All_versions;
- names = Day11_batch.Profile.All_names }
+ {
+ versions = Day11_batch.Profile.All_versions;
+ names = Day11_batch.Profile.All_names;
+ }
+ in
+ let profile : Day11_batch.Profile.t =
+ {
+ name;
+ opam_repositories;
+ odoc_repo;
+ opam_build_repo;
+ compiler;
+ target_mode;
+ with_doc;
+ with_jtw = false;
+ jtw_repo = None;
+ arch;
+ os_distribution;
+ os_version;
+ driver_compiler;
+ extra_pins = [];
+ pinned_versions = [];
+ patches_dir = None;
+ base_image_digest = None;
+ base_image_updated = None;
+ html_dir = None;
+ }
in
- let profile : Day11_batch.Profile.t = {
- name;
- opam_repositories;
- odoc_repo;
- opam_build_repo;
- compiler;
- target_mode;
- with_doc;
- with_jtw = false;
- jtw_repo = None;
- arch;
- os_distribution;
- os_version;
- driver_compiler;
- extra_pins = [];
- pinned_versions = [];
- patches_dir = None;
- base_image_digest = None;
- base_image_updated = None;
- html_dir = None;
- } in
match Day11_batch.Profile.save ~dir profile with
| Ok () ->
- Printf.printf "Profile '%s' created.\n%!" name;
- Fmt.pr "%a@." Day11_batch.Profile.pp profile;
- 0
+ Printf.printf "Profile '%s' created.\n%!" name;
+ Fmt.pr "%a@." Day11_batch.Profile.pp profile;
+ 0
| Error (`Msg e) ->
- Printf.eprintf "Error: %s\n%!" e; 1
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
let create_cmd =
let doc = "Create a new profile" in
let info = Cmd.info "create" ~doc in
Cmd.v info
- Term.(const run_create
- $ profile_dir_term $ name_term
- $ opam_repo_term $ odoc_repo_term $ opam_build_repo_term
- $ compiler_term $ all_versions_term $ small_universe_term
- $ with_doc_term
- $ arch_term $ os_distribution_term $ os_version_term
- $ driver_compiler_term)
+ Term.(
+ const run_create
+ $ profile_dir_term
+ $ name_term
+ $ opam_repo_term
+ $ odoc_repo_term
+ $ opam_build_repo_term
+ $ compiler_term
+ $ all_versions_term
+ $ small_universe_term
+ $ with_doc_term
+ $ arch_term
+ $ os_distribution_term
+ $ os_version_term
+ $ driver_compiler_term)
(* ── show ──────────────────────────────────────────────────────── *)
@@ -132,10 +148,11 @@ let run_show profile_dir name =
let dir = Fpath.(resolve_profile_dir profile_dir / "profiles") in
match Day11_batch.Profile.load ~dir ~name with
| Ok profile ->
- Fmt.pr "%a@." Day11_batch.Profile.pp profile;
- 0
+ Fmt.pr "%a@." Day11_batch.Profile.pp profile;
+ 0
| Error (`Msg e) ->
- Printf.eprintf "Error: %s\n%!" e; 1
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
let show_cmd =
let doc = "Show a profile" in
@@ -149,8 +166,7 @@ let run_list profile_dir =
let names = Day11_batch.Profile.list ~dir in
if names = [] then
Printf.printf "No profiles found in %s\n%!" (Fpath.to_string dir)
- else
- List.iter (fun name -> Printf.printf "%s\n" name) names;
+ else List.iter (fun name -> Printf.printf "%s\n" name) names;
0
let list_cmd =
@@ -164,9 +180,11 @@ let run_delete profile_dir name =
let dir = Fpath.(resolve_profile_dir profile_dir / "profiles") in
match Day11_batch.Profile.delete ~dir ~name with
| Ok () ->
- Printf.printf "Profile '%s' deleted.\n%!" name; 0
+ Printf.printf "Profile '%s' deleted.\n%!" name;
+ 0
| Error (`Msg e) ->
- Printf.eprintf "Error: %s\n%!" e; 1
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
let delete_cmd =
let doc = "Delete a profile" in
@@ -178,20 +196,25 @@ let delete_cmd =
let run_refresh_base profile_dir name =
let dir = Fpath.(resolve_profile_dir profile_dir / "profiles") in
match Day11_batch.Profile.load ~dir ~name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok profile ->
- Printf.printf "Resolving digest for %s (this may take ~15s)...\n%!"
- (Day11_batch.Profile.base_image_tag profile);
- match Day11_batch.Profile.refresh_base_digest profile with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok updated ->
- match Day11_batch.Profile.save ~dir updated with
- | Ok () ->
- Printf.printf "Base image digest updated:\n %s\n%!"
- (Option.value ~default:"?" updated.base_image_digest);
- 0
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok profile -> (
+ Printf.printf "Resolving digest for %s (this may take ~15s)...\n%!"
+ (Day11_batch.Profile.base_image_tag profile);
+ match Day11_batch.Profile.refresh_base_digest profile with
| Error (`Msg e) ->
- Printf.eprintf "Error saving: %s\n%!" e; 1
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok updated -> (
+ match Day11_batch.Profile.save ~dir updated with
+ | Ok () ->
+ Printf.printf "Base image digest updated:\n %s\n%!"
+ (Option.value ~default:"?" updated.base_image_digest);
+ 0
+ | Error (`Msg e) ->
+ Printf.eprintf "Error saving: %s\n%!" e;
+ 1))
let refresh_base_cmd =
let doc = "Resolve and pin the base Docker image digest from the registry" in
@@ -203,5 +226,5 @@ let refresh_base_cmd =
let cmd =
let doc = "Manage analysis profiles" in
let info = Cmd.info "profile" ~doc in
- Cmd.group info [ create_cmd; show_cmd; list_cmd; delete_cmd;
- refresh_base_cmd ]
+ Cmd.group info
+ [ create_cmd; show_cmd; list_cmd; delete_cmd; refresh_base_cmd ]
File "day11/bin/cmd_query.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_query.ml b/_build/default/day11/bin/.formatted/cmd_query.ml
index 3558929..2c2bd5e 100644
--- a/_build/default/day11/bin/cmd_query.ml
+++ b/_build/default/day11/bin/.formatted/cmd_query.ml
@@ -4,61 +4,74 @@ open Cmdliner
module Layer = Day11_layer.Layer
let show_layers_from_symlinks env ~os_dir ~packages_dir ~pkg_str =
- let symlinks = Day11_layer.Scan.list_package_symlinks
- ~exclude:["blessed-build"; "blessed-docs"; "history.jsonl"]
- env packages_dir pkg_str in
- if symlinks = [] then begin
+ let symlinks =
+ Day11_layer.Scan.list_package_symlinks
+ ~exclude:[ "blessed-build"; "blessed-docs"; "history.jsonl" ]
+ env packages_dir pkg_str
+ in
+ if symlinks = [] then (
Printf.printf "No layers for %s\n" pkg_str;
- 1
- end else begin
+ 1)
+ else (
Printf.printf "Layers for %s (%d):\n\n" pkg_str (List.length symlinks);
- List.iter (fun (name, _target) ->
- let layer = Layer.of_hash ~os_dir name in
- match Day11_layer.Meta.load env (Layer.meta_path layer) with
- | Ok meta ->
- let status = if meta.exit_status = 0 then "ok"
- else if meta.failed_dep <> None then "cascade"
- else "fail" in
- Printf.printf " %s status=%s created=%s\n"
- name status meta.created_at
- | Error _ ->
- Printf.printf " %s (no metadata)\n" name
- ) symlinks;
- 0
- end
+ List.iter
+ (fun (name, _target) ->
+ let layer = Layer.of_hash ~os_dir name in
+ match Day11_layer.Meta.load env (Layer.meta_path layer) with
+ | Ok meta ->
+ let status =
+ if meta.exit_status = 0 then "ok"
+ else if meta.failed_dep <> None then "cascade"
+ else "fail"
+ in
+ Printf.printf " %s status=%s created=%s\n" name status
+ meta.created_at
+ | Error _ -> Printf.printf " %s (no metadata)\n" name)
+ symlinks;
+ 0)
let run profile_name profile_dir package =
Common.with_eio @@ fun ~sw:_ env ->
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (_profile, paths) ->
- match Common.latest_snapshot_dir paths with
- | None -> Printf.printf "No snapshots found\n"; 1
- | Some snapshot_dir ->
- let os_dir = paths.os_dir in
- let packages_dir = Fpath.(snapshot_dir / "packages") in
- let entries = Day11_lib.History.read ~packages_dir ~pkg_str:package in
- if entries = [] then
- (* Fall back to showing layers discovered via symlinks *)
- show_layers_from_symlinks env ~os_dir ~packages_dir ~pkg_str:package
- else begin
- Printf.printf "History for %s (%d entries):\n\n" package
- (List.length entries);
- List.iter (fun (e : Day11_lib.History.entry) ->
- Printf.printf " %s run=%s hash=%s status=%s category=%s%s\n"
- e.ts e.run (String.sub e.build_hash 0 (min 16 (String.length e.build_hash)))
- e.status e.category
- (if e.blessed then " [blessed]" else "")
- ) entries;
- 0
- end
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (_profile, paths) -> (
+ match Common.latest_snapshot_dir paths with
+ | None ->
+ Printf.printf "No snapshots found\n";
+ 1
+ | Some snapshot_dir ->
+ let os_dir = paths.os_dir in
+ let packages_dir = Fpath.(snapshot_dir / "packages") in
+ let entries = Day11_lib.History.read ~packages_dir ~pkg_str:package in
+ if entries = [] then
+ (* Fall back to showing layers discovered via symlinks *)
+ show_layers_from_symlinks env ~os_dir ~packages_dir ~pkg_str:package
+ else (
+ Printf.printf "History for %s (%d entries):\n\n" package
+ (List.length entries);
+ List.iter
+ (fun (e : Day11_lib.History.entry) ->
+ Printf.printf
+ " %s run=%s hash=%s status=%s category=%s%s\n" e.ts e.run
+ (String.sub e.build_hash 0
+ (min 16 (String.length e.build_hash)))
+ e.status e.category
+ (if e.blessed then " [blessed]" else ""))
+ entries;
+ 0))
let package_term =
- Arg.(required & pos 0 (some string) None & info [] ~docv:"PACKAGE"
- ~doc:"Package name (e.g. astring.0.8.5)")
+ Arg.(
+ required
+ & pos 0 (some string) None
+ & info [] ~docv:"PACKAGE" ~doc:"Package name (e.g. astring.0.8.5)")
let cmd =
let info = Cmd.info "query" ~doc:"Show build history for a package" in
- let term = Term.(const run $ Common.profile_term $ Common.profile_dir_term
- $ package_term) in
+ let term =
+ Term.(
+ const run $ Common.profile_term $ Common.profile_dir_term $ package_term)
+ in
Cmd.v info term
File "day11/bin/cmd_report.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_report.ml b/_build/default/day11/bin/.formatted/cmd_report.ml
index f6d93a0..69225ca 100644
--- a/_build/default/day11/bin/cmd_report.ml
+++ b/_build/default/day11/bin/.formatted/cmd_report.ml
@@ -4,213 +4,276 @@ open Cmdliner
let run profile_name profile_dir =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (_profile, paths) ->
- match Common.latest_snapshot_dir paths with
- | None -> Printf.printf "No snapshots found\n"; 1
- | Some snapshot_dir ->
- let runs_dir = Fpath.(snapshot_dir / "runs") in
- let load_run f =
- try
- let data = In_channel.with_open_text (Fpath.to_string f)
- In_channel.input_all in
- Some (Yojson.Safe.from_string data)
- with _ -> None
- in
- let run_pkg_status json =
- let open Yojson.Safe.Util in
- let layers = json |> member "layers" |> to_assoc in
- let pkg_status : (string, string) Hashtbl.t = Hashtbl.create 256 in
- List.iter (fun (_hash, entry) ->
- let pkg = entry |> member "package" |> to_string in
- let status = entry |> member "status" |> to_string in
- match Hashtbl.find_opt pkg_status pkg with
- | Some "ok" -> ()
- | _ -> Hashtbl.replace pkg_status pkg status
- ) layers;
- pkg_status
- in
- let runs =
- match Bos.OS.Dir.contents runs_dir with
- | Ok files ->
- files
- |> List.filter (fun f -> Fpath.has_ext ".json" f)
- |> List.sort (fun a b ->
- compare (Fpath.to_string b) (Fpath.to_string a))
- | Error _ -> []
- in
- match runs with
- | [] ->
- (* No finished run summaries on disk. If a run is in progress,
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (_profile, paths) -> (
+ match Common.latest_snapshot_dir paths with
+ | None ->
+ Printf.printf "No snapshots found\n";
+ 1
+ | Some snapshot_dir -> (
+ let runs_dir = Fpath.(snapshot_dir / "runs") in
+ let load_run f =
+ try
+ let data =
+ In_channel.with_open_text (Fpath.to_string f)
+ In_channel.input_all
+ in
+ Some (Yojson.Safe.from_string data)
+ with _ -> None
+ in
+ let run_pkg_status json =
+ let open Yojson.Safe.Util in
+ let layers = json |> member "layers" |> to_assoc in
+ let pkg_status : (string, string) Hashtbl.t = Hashtbl.create 256 in
+ List.iter
+ (fun (_hash, entry) ->
+ let pkg = entry |> member "package" |> to_string in
+ let status = entry |> member "status" |> to_string in
+ match Hashtbl.find_opt pkg_status pkg with
+ | Some "ok" -> ()
+ | _ -> Hashtbl.replace pkg_status pkg status)
+ layers;
+ pkg_status
+ in
+ let runs =
+ match Bos.OS.Dir.contents runs_dir with
+ | Ok files ->
+ files
+ |> List.filter (fun f -> Fpath.has_ext ".json" f)
+ |> List.sort (fun a b ->
+ compare (Fpath.to_string b) (Fpath.to_string a))
+ | Error _ -> []
+ in
+ match runs with
+ | [] -> (
+ (* No finished run summaries on disk. If a run is in progress,
emit a minimal live report so the operator can see something
rather than "No runs found". *)
- (match Day11_batch.Live_view.load_latest ~snapshot_dir with
- | None -> Printf.printf "No runs found.\n"; 1
- | Some lv ->
- Printf.printf "# Live Build Report — run %s (in progress)\n\n"
- lv.run_id;
- Printf.printf "Progress: %s\n\n"
- (Day11_batch.Live_view.format_progress lv.progress);
- Printf.printf "## Outcomes so far\n\n";
- Printf.printf "| Status | Count |\n|--------|-------|\n";
- Printf.printf "| ok | %d |\n" lv.counts.ok;
- Printf.printf "| fail | %d |\n" lv.counts.fail;
- Printf.printf "| cascade | %d |\n\n" lv.counts.cascade;
- let failed = Hashtbl.fold (fun pkg s acc ->
- if s = "fail" then pkg :: acc else acc) lv.pkg_status [] in
- let failed = List.sort compare failed in
- if failed <> [] then begin
- Printf.printf "## Failing packages (%d)\n\n"
- (List.length failed);
- List.iter (fun p -> Printf.printf "- `%s`\n" p)
- (List.filteri (fun i _ -> i < 50) failed);
- if List.length failed > 50 then
- Printf.printf "\n_...and %d more_\n" (List.length failed - 50)
- end;
- 0)
- | latest_file :: rest ->
- match load_run latest_file with
- | None ->
- Printf.printf "Cannot load latest run.\n"; 1
- | Some latest_json ->
- let open Yojson.Safe.Util in
- let ts = latest_json |> member "timestamp" |> to_string in
- let repos = latest_json |> member "repos" |> to_list in
- let latest_ps = run_pkg_status latest_json in
- let n_ok = Hashtbl.fold (fun _ s n ->
- if s = "ok" then n + 1 else n) latest_ps 0 in
- let n_fail = Hashtbl.fold (fun _ s n ->
- if s = "fail" then n + 1 else n) latest_ps 0 in
- let n_cascade = Hashtbl.fold (fun _ s n ->
- if s = "cascade" then n + 1 else n) latest_ps 0 in
- (* Generate report *)
- let buf = Buffer.create 4096 in
- let pr fmt = Printf.bprintf buf fmt in
- pr "# Daily Build Report — %s\n\n" (String.sub ts 0 10);
- pr "## Repositories\n\n";
- List.iter (fun r ->
- let path = r |> member "path" |> to_string in
- let commit = r |> member "commit" |> to_string in
- pr "- `%s` @ `%s`\n" (Filename.basename path) (String.sub commit 0 12)
- ) repos;
- pr "\n## Build Summary\n\n";
- pr "| Metric | Count |\n";
- pr "|--------|-------|\n";
- pr "| Succeeded | %d |\n" n_ok;
- pr "| Failed (root) | %d |\n" n_fail;
- pr "| Failed (cascade) | %d |\n" n_cascade;
- pr "| Total | %d |\n" (n_ok + n_fail + n_cascade);
- pr "\n";
- (* Diff with previous *)
- let prev_opt = match rest with
- | prev_file :: _ -> load_run prev_file
- | [] -> None
- in
- (match prev_opt with
- | Some prev_json ->
- let prev_ps = run_pkg_status prev_json in
- let prev_ts = prev_json |> member "timestamp" |> to_string in
- let prev_ok = Hashtbl.fold (fun _ s n ->
- if s = "ok" then n + 1 else n) prev_ps 0 in
- let fixed = ref [] in
- let regressed = ref [] in
- Hashtbl.iter (fun pkg status ->
- match Hashtbl.find_opt prev_ps pkg with
- | Some prev_status ->
- if status = "ok" && prev_status <> "ok" then
- fixed := pkg :: !fixed
- else if status <> "ok" && prev_status = "ok" then
- regressed := pkg :: !regressed
- | None -> ()
- ) latest_ps;
- let fixed = List.sort String.compare !fixed in
- let regressed = List.sort String.compare !regressed in
- pr "## Changes (vs %s)\n\n" (String.sub prev_ts 0 10);
- pr "- **Previous:** %d succeeded\n" prev_ok;
- pr "- **Current:** %d succeeded\n" n_ok;
- pr "- **Net change:** %+d\n\n" (n_ok - prev_ok);
- if fixed <> [] then begin
- pr "### Newly passing (%d)\n\n" (List.length fixed);
- List.iter (fun p -> pr "- `%s`\n" p) fixed;
- pr "\n"
- end;
- if regressed <> [] then begin
- pr "### Newly failing (%d)\n\n" (List.length regressed);
- List.iter (fun p -> pr "- `%s`\n" p) regressed;
- pr "\n"
- end
- | None ->
- pr "## Changes\n\nNo previous run to compare.\n\n");
- (* Top blockers -- compute cascade block counts from failed_dep *)
- pr "## Top Blockers\n\n";
- let layers = latest_json |> member "layers" |> to_assoc in
- (* blocked_by.(dep) = list of packages blocked by dep *)
- let blocked_by : (string, string list) Hashtbl.t = Hashtbl.create 64 in
- List.iter (fun (_hash, entry) ->
- let pkg = entry |> member "package" |> to_string in
- let status = entry |> member "status" |> to_string in
- if status <> "ok" then
- match entry |> member "failed_dep" with
- | `String dep ->
- let prev = try Hashtbl.find blocked_by dep with Not_found -> [] in
- if not (List.mem pkg prev) then
- Hashtbl.replace blocked_by dep (pkg :: prev)
- | _ -> ()
- ) layers;
- (* For "sole" count: packages whose only failed_dep is this one *)
- let pkg_blockers : (string, string list) Hashtbl.t = Hashtbl.create 64 in
- List.iter (fun (_hash, entry) ->
- let pkg = entry |> member "package" |> to_string in
- let status = entry |> member "status" |> to_string in
- if status <> "ok" then
- match entry |> member "failed_dep" with
- | `String dep ->
- let prev = try Hashtbl.find pkg_blockers pkg with Not_found -> [] in
- if not (List.mem dep prev) then
- Hashtbl.replace pkg_blockers pkg (dep :: prev)
- | _ -> ()
- ) layers;
- let sole_count : (string, int) Hashtbl.t = Hashtbl.create 64 in
- Hashtbl.iter (fun pkg deps ->
- match deps with
- | [single_dep] ->
- ignore pkg;
- let n = try Hashtbl.find sole_count single_dep with Not_found -> 0 in
- Hashtbl.replace sole_count single_dep (n + 1)
- | _ -> ()
- ) pkg_blockers;
- let fail_pkgs = Hashtbl.fold (fun pkg status acc ->
- if status = "fail" then pkg :: acc else acc
- ) latest_ps [] in
- (* Sort by block count descending *)
- let fail_pkgs = List.sort (fun a b ->
- let ba = try List.length (Hashtbl.find blocked_by a) with Not_found -> 0 in
- let bb = try List.length (Hashtbl.find blocked_by b) with Not_found -> 0 in
- compare bb ba
- ) fail_pkgs in
- pr "| Package | Blocks | Sole |\n";
- pr "|---------|--------|------|\n";
- List.iteri (fun i pkg ->
- if i < 20 then begin
- let blocks = try List.length (Hashtbl.find blocked_by pkg)
- with Not_found -> 0 in
- let sole = try Hashtbl.find sole_count pkg with Not_found -> 0 in
- pr "| `%s` | %d | %d |\n" pkg blocks sole
- end
- ) fail_pkgs;
- if List.length fail_pkgs > 20 then
- pr "| ... | | |\n";
- pr "\n*Run `day11 results` for full impact analysis.*\n";
- (* Write report *)
- let reports_dir = Fpath.(paths.cache_dir / "reports") in
- Bos.OS.Dir.create ~path:true reports_dir |> ignore;
- let date = String.sub ts 0 10 in
- let report_file = Fpath.(reports_dir / (date ^ ".md")) in
- let content = Buffer.contents buf in
- ignore (Bos.OS.File.write report_file content);
- Printf.printf "%s" content;
- Printf.printf "\nReport saved to %s\n" (Fpath.to_string report_file);
- 0
+ match Day11_batch.Live_view.load_latest ~snapshot_dir with
+ | None ->
+ Printf.printf "No runs found.\n";
+ 1
+ | Some lv ->
+ Printf.printf "# Live Build Report — run %s (in progress)\n\n"
+ lv.run_id;
+ Printf.printf "Progress: %s\n\n"
+ (Day11_batch.Live_view.format_progress lv.progress);
+ Printf.printf "## Outcomes so far\n\n";
+ Printf.printf "| Status | Count |\n|--------|-------|\n";
+ Printf.printf "| ok | %d |\n" lv.counts.ok;
+ Printf.printf "| fail | %d |\n" lv.counts.fail;
+ Printf.printf "| cascade | %d |\n\n" lv.counts.cascade;
+ let failed =
+ Hashtbl.fold
+ (fun pkg s acc -> if s = "fail" then pkg :: acc else acc)
+ lv.pkg_status []
+ in
+ let failed = List.sort compare failed in
+ if failed <> [] then (
+ Printf.printf "## Failing packages (%d)\n\n"
+ (List.length failed);
+ List.iter
+ (fun p -> Printf.printf "- `%s`\n" p)
+ (List.filteri (fun i _ -> i < 50) failed);
+ if List.length failed > 50 then
+ Printf.printf "\n_...and %d more_\n"
+ (List.length failed - 50));
+ 0)
+ | latest_file :: rest -> (
+ match load_run latest_file with
+ | None ->
+ Printf.printf "Cannot load latest run.\n";
+ 1
+ | Some latest_json ->
+ let open Yojson.Safe.Util in
+ let ts = latest_json |> member "timestamp" |> to_string in
+ let repos = latest_json |> member "repos" |> to_list in
+ let latest_ps = run_pkg_status latest_json in
+ let n_ok =
+ Hashtbl.fold
+ (fun _ s n -> if s = "ok" then n + 1 else n)
+ latest_ps 0
+ in
+ let n_fail =
+ Hashtbl.fold
+ (fun _ s n -> if s = "fail" then n + 1 else n)
+ latest_ps 0
+ in
+ let n_cascade =
+ Hashtbl.fold
+ (fun _ s n -> if s = "cascade" then n + 1 else n)
+ latest_ps 0
+ in
+ (* Generate report *)
+ let buf = Buffer.create 4096 in
+ let pr fmt = Printf.bprintf buf fmt in
+ pr "# Daily Build Report — %s\n\n" (String.sub ts 0 10);
+ pr "## Repositories\n\n";
+ List.iter
+ (fun r ->
+ let path = r |> member "path" |> to_string in
+ let commit = r |> member "commit" |> to_string in
+ pr "- `%s` @ `%s`\n" (Filename.basename path)
+ (String.sub commit 0 12))
+ repos;
+ pr "\n## Build Summary\n\n";
+ pr "| Metric | Count |\n";
+ pr "|--------|-------|\n";
+ pr "| Succeeded | %d |\n" n_ok;
+ pr "| Failed (root) | %d |\n" n_fail;
+ pr "| Failed (cascade) | %d |\n" n_cascade;
+ pr "| Total | %d |\n" (n_ok + n_fail + n_cascade);
+ pr "\n";
+ (* Diff with previous *)
+ let prev_opt =
+ match rest with
+ | prev_file :: _ -> load_run prev_file
+ | [] -> None
+ in
+ (match prev_opt with
+ | Some prev_json ->
+ let prev_ps = run_pkg_status prev_json in
+ let prev_ts =
+ prev_json |> member "timestamp" |> to_string
+ in
+ let prev_ok =
+ Hashtbl.fold
+ (fun _ s n -> if s = "ok" then n + 1 else n)
+ prev_ps 0
+ in
+ let fixed = ref [] in
+ let regressed = ref [] in
+ Hashtbl.iter
+ (fun pkg status ->
+ match Hashtbl.find_opt prev_ps pkg with
+ | Some prev_status ->
+ if status = "ok" && prev_status <> "ok" then
+ fixed := pkg :: !fixed
+ else if status <> "ok" && prev_status = "ok" then
+ regressed := pkg :: !regressed
+ | None -> ())
+ latest_ps;
+ let fixed = List.sort String.compare !fixed in
+ let regressed = List.sort String.compare !regressed in
+ pr "## Changes (vs %s)\n\n" (String.sub prev_ts 0 10);
+ pr "- **Previous:** %d succeeded\n" prev_ok;
+ pr "- **Current:** %d succeeded\n" n_ok;
+ pr "- **Net change:** %+d\n\n" (n_ok - prev_ok);
+ if fixed <> [] then (
+ pr "### Newly passing (%d)\n\n" (List.length fixed);
+ List.iter (fun p -> pr "- `%s`\n" p) fixed;
+ pr "\n");
+ if regressed <> [] then (
+ pr "### Newly failing (%d)\n\n" (List.length regressed);
+ List.iter (fun p -> pr "- `%s`\n" p) regressed;
+ pr "\n")
+ | None -> pr "## Changes\n\nNo previous run to compare.\n\n");
+ (* Top blockers -- compute cascade block counts from failed_dep *)
+ pr "## Top Blockers\n\n";
+ let layers = latest_json |> member "layers" |> to_assoc in
+ (* blocked_by.(dep) = list of packages blocked by dep *)
+ let blocked_by : (string, string list) Hashtbl.t =
+ Hashtbl.create 64
+ in
+ List.iter
+ (fun (_hash, entry) ->
+ let pkg = entry |> member "package" |> to_string in
+ let status = entry |> member "status" |> to_string in
+ if status <> "ok" then
+ match entry |> member "failed_dep" with
+ | `String dep ->
+ let prev =
+ try Hashtbl.find blocked_by dep
+ with Not_found -> []
+ in
+ if not (List.mem pkg prev) then
+ Hashtbl.replace blocked_by dep (pkg :: prev)
+ | _ -> ())
+ layers;
+ (* For "sole" count: packages whose only failed_dep is this one *)
+ let pkg_blockers : (string, string list) Hashtbl.t =
+ Hashtbl.create 64
+ in
+ List.iter
+ (fun (_hash, entry) ->
+ let pkg = entry |> member "package" |> to_string in
+ let status = entry |> member "status" |> to_string in
+ if status <> "ok" then
+ match entry |> member "failed_dep" with
+ | `String dep ->
+ let prev =
+ try Hashtbl.find pkg_blockers pkg
+ with Not_found -> []
+ in
+ if not (List.mem dep prev) then
+ Hashtbl.replace pkg_blockers pkg (dep :: prev)
+ | _ -> ())
+ layers;
+ let sole_count : (string, int) Hashtbl.t =
+ Hashtbl.create 64
+ in
+ Hashtbl.iter
+ (fun pkg deps ->
+ match deps with
+ | [ single_dep ] ->
+ ignore pkg;
+ let n =
+ try Hashtbl.find sole_count single_dep
+ with Not_found -> 0
+ in
+ Hashtbl.replace sole_count single_dep (n + 1)
+ | _ -> ())
+ pkg_blockers;
+ let fail_pkgs =
+ Hashtbl.fold
+ (fun pkg status acc ->
+ if status = "fail" then pkg :: acc else acc)
+ latest_ps []
+ in
+ (* Sort by block count descending *)
+ let fail_pkgs =
+ List.sort
+ (fun a b ->
+ let ba =
+ try List.length (Hashtbl.find blocked_by a)
+ with Not_found -> 0
+ in
+ let bb =
+ try List.length (Hashtbl.find blocked_by b)
+ with Not_found -> 0
+ in
+ compare bb ba)
+ fail_pkgs
+ in
+ pr "| Package | Blocks | Sole |\n";
+ pr "|---------|--------|------|\n";
+ List.iteri
+ (fun i pkg ->
+ if i < 20 then
+ let blocks =
+ try List.length (Hashtbl.find blocked_by pkg)
+ with Not_found -> 0
+ in
+ let sole =
+ try Hashtbl.find sole_count pkg with Not_found -> 0
+ in
+ pr "| `%s` | %d | %d |\n" pkg blocks sole)
+ fail_pkgs;
+ if List.length fail_pkgs > 20 then pr "| ... | | |\n";
+ pr "\n*Run `day11 results` for full impact analysis.*\n";
+ (* Write report *)
+ let reports_dir = Fpath.(paths.cache_dir / "reports") in
+ Bos.OS.Dir.create ~path:true reports_dir |> ignore;
+ let date = String.sub ts 0 10 in
+ let report_file = Fpath.(reports_dir / (date ^ ".md")) in
+ let content = Buffer.contents buf in
+ ignore (Bos.OS.File.write report_file content);
+ Printf.printf "%s" content;
+ Printf.printf "\nReport saved to %s\n"
+ (Fpath.to_string report_file);
+ 0)))
let cmd =
let info = Cmd.info "report" ~doc:"Generate daily build summary report" in
File "day11/bin/cmd_results.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_results.ml b/_build/default/day11/bin/.formatted/cmd_results.ml
index d4315df..3928389 100644
--- a/_build/default/day11/bin/cmd_results.ml
+++ b/_build/default/day11/bin/.formatted/cmd_results.ml
@@ -4,273 +4,334 @@ open Cmdliner
let run profile_name profile_dir =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (_profile, paths) ->
- match Common.latest_snapshot_dir paths with
- | None -> Printf.printf "No snapshots found\n"; 1
- | Some snapshot_dir ->
- (* Load solutions *)
- let solutions_dir = Fpath.(snapshot_dir / "solutions") in
- let all_solutions : (string, Day11_solution.Deps.t) Hashtbl.t =
- Hashtbl.create 4096 in
- let n_solve_failures = ref 0 in
- (match Bos.OS.Dir.contents solutions_dir with
- | Ok commit_dirs ->
- List.iter (fun commit_dir ->
- let manifest = Fpath.(commit_dir / "repos.json") in
- (match Bos.OS.File.read manifest with
- | Ok data ->
- (try
- let json = Yojson.Safe.from_string data in
- let open Yojson.Safe.Util in
- let repos = json |> member "repos" |> to_list in
- Printf.printf "Solver cache: %s\n" (Fpath.basename commit_dir);
- List.iter (fun r ->
- let path = r |> member "path" |> to_string in
- let commit = r |> member "commit" |> to_string in
- Printf.printf " %s @ %s\n" path (String.sub commit 0 12)
- ) repos;
- (match json |> member "ocaml_version" with
- | `String v -> Printf.printf " compiler: %s\n" v
- | _ -> ());
- Printf.printf "\n"
- with _ -> ())
- | Error _ -> ());
- match Bos.OS.Dir.contents commit_dir with
- | Ok files ->
- List.iter (fun f ->
- if Fpath.has_ext ".json" f
- && Fpath.basename f <> "repos.json" then
- match Day11_batch.Incremental_solver.load f with
- | Ok (Day11_batch.Incremental_solver.Cached_solution
- { package; result; _ }) ->
- let key = OpamPackage.to_string package in
- if not (Hashtbl.mem all_solutions key) then
- Hashtbl.replace all_solutions key result.build_deps
- | Ok (Day11_batch.Incremental_solver.Cached_failure _) ->
- incr n_solve_failures
- | _ -> ()
- ) files
- | Error _ -> ()
- ) commit_dirs
- | Error _ -> ());
- Printf.printf "=== Solver Cache ===\n";
- Printf.printf " Solutions cached: %d (across all solve passes)\n"
- (Hashtbl.length all_solutions);
- Printf.printf " Solve failed: %d\n\n" !n_solve_failures;
- (* Load runs -- each run is a subdirectory containing summary.json *)
- let runs_dir = Fpath.(snapshot_dir / "runs") in
- let load_run f =
- try
- let data = In_channel.with_open_text (Fpath.to_string f)
- In_channel.input_all in
- Some (Yojson.Safe.from_string data)
- with _ -> None
- in
- let run_pkg_status_from_jsonl run_dir =
- let jsonl_path = Fpath.(run_dir / "build.jsonl") in
- let pkg_status : (string, string) Hashtbl.t = Hashtbl.create 256 in
- if Sys.file_exists (Fpath.to_string jsonl_path) then begin
- let ic = open_in (Fpath.to_string jsonl_path) in
- Fun.protect ~finally:(fun () -> close_in ic) (fun () ->
- try while true do
- let line = input_line ic in
- if String.length line > 0 then begin
- let open Yojson.Safe.Util in
- let json = Yojson.Safe.from_string line in
- let pkg = json |> member "pkg" |> to_string in
- let status = json |> member "status" |> to_string in
- match Hashtbl.find_opt pkg_status pkg with
- | Some "ok" -> ()
- | _ -> Hashtbl.replace pkg_status pkg status
- end
- done with End_of_file -> ())
- end;
- pkg_status
- in
- let runs =
- match Bos.OS.Dir.contents runs_dir with
- | Ok entries ->
- entries
- |> List.filter (fun d ->
- Sys.file_exists
- (Fpath.to_string Fpath.(d / "build.jsonl")))
- |> List.sort (fun a b ->
- compare (Fpath.to_string b) (Fpath.to_string a))
- | Error _ -> []
- in
- (* If the latest run has no [summary.json], surface the live
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (_profile, paths) -> (
+ match Common.latest_snapshot_dir paths with
+ | None ->
+ Printf.printf "No snapshots found\n";
+ 1
+ | Some snapshot_dir ->
+ (* Load solutions *)
+ let solutions_dir = Fpath.(snapshot_dir / "solutions") in
+ let all_solutions : (string, Day11_solution.Deps.t) Hashtbl.t =
+ Hashtbl.create 4096
+ in
+ let n_solve_failures = ref 0 in
+ (match Bos.OS.Dir.contents solutions_dir with
+ | Ok commit_dirs ->
+ List.iter
+ (fun commit_dir ->
+ let manifest = Fpath.(commit_dir / "repos.json") in
+ (match Bos.OS.File.read manifest with
+ | Ok data -> (
+ try
+ let json = Yojson.Safe.from_string data in
+ let open Yojson.Safe.Util in
+ let repos = json |> member "repos" |> to_list in
+ Printf.printf "Solver cache: %s\n"
+ (Fpath.basename commit_dir);
+ List.iter
+ (fun r ->
+ let path = r |> member "path" |> to_string in
+ let commit = r |> member "commit" |> to_string in
+ Printf.printf " %s @ %s\n" path
+ (String.sub commit 0 12))
+ repos;
+ (match json |> member "ocaml_version" with
+ | `String v -> Printf.printf " compiler: %s\n" v
+ | _ -> ());
+ Printf.printf "\n"
+ with _ -> ())
+ | Error _ -> ());
+ match Bos.OS.Dir.contents commit_dir with
+ | Ok files ->
+ List.iter
+ (fun f ->
+ if
+ Fpath.has_ext ".json" f
+ && Fpath.basename f <> "repos.json"
+ then
+ match Day11_batch.Incremental_solver.load f with
+ | Ok
+ (Day11_batch.Incremental_solver.Cached_solution
+ { package; result; _ }) ->
+ let key = OpamPackage.to_string package in
+ if not (Hashtbl.mem all_solutions key) then
+ Hashtbl.replace all_solutions key
+ result.build_deps
+ | Ok
+ (Day11_batch.Incremental_solver.Cached_failure _)
+ ->
+ incr n_solve_failures
+ | _ -> ())
+ files
+ | Error _ -> ())
+ commit_dirs
+ | Error _ -> ());
+ Printf.printf "=== Solver Cache ===\n";
+ Printf.printf " Solutions cached: %d (across all solve passes)\n"
+ (Hashtbl.length all_solutions);
+ Printf.printf " Solve failed: %d\n\n" !n_solve_failures;
+ (* Load runs -- each run is a subdirectory containing summary.json *)
+ let runs_dir = Fpath.(snapshot_dir / "runs") in
+ let load_run f =
+ try
+ let data =
+ In_channel.with_open_text (Fpath.to_string f)
+ In_channel.input_all
+ in
+ Some (Yojson.Safe.from_string data)
+ with _ -> None
+ in
+ let run_pkg_status_from_jsonl run_dir =
+ let jsonl_path = Fpath.(run_dir / "build.jsonl") in
+ let pkg_status : (string, string) Hashtbl.t = Hashtbl.create 256 in
+ (if Sys.file_exists (Fpath.to_string jsonl_path) then
+ let ic = open_in (Fpath.to_string jsonl_path) in
+ Fun.protect
+ ~finally:(fun () -> close_in ic)
+ (fun () ->
+ try
+ while true do
+ let line = input_line ic in
+ if String.length line > 0 then
+ let open Yojson.Safe.Util in
+ let json = Yojson.Safe.from_string line in
+ let pkg = json |> member "pkg" |> to_string in
+ let status = json |> member "status" |> to_string in
+ match Hashtbl.find_opt pkg_status pkg with
+ | Some "ok" -> ()
+ | _ -> Hashtbl.replace pkg_status pkg status
+ done
+ with End_of_file -> ()));
+ pkg_status
+ in
+ let runs =
+ match Bos.OS.Dir.contents runs_dir with
+ | Ok entries ->
+ entries
+ |> List.filter (fun d ->
+ Sys.file_exists
+ (Fpath.to_string Fpath.(d / "build.jsonl")))
+ |> List.sort (fun a b ->
+ compare (Fpath.to_string b) (Fpath.to_string a))
+ | Error _ -> []
+ in
+ (* If the latest run has no [summary.json], surface the live
progress counters before continuing — the rest of the command
reads [build.jsonl] directly, so it still works. *)
- (match runs with
- | latest :: _
- when not (Sys.file_exists
- (Fpath.to_string Fpath.(latest / "summary.json"))) ->
- (match Day11_batch.Live_view.load_latest ~snapshot_dir with
- | Some lv ->
- Printf.printf "=== Run in progress: %s ===\n" lv.run_id;
- Printf.printf " %s\n\n"
- (Day11_batch.Live_view.format_progress lv.progress)
- | None -> ())
- | _ -> ());
- (* Use latest run for build results and failure ranking *)
- (match runs with
- | latest_dir :: _ ->
- let summary_file = Fpath.(latest_dir / "summary.json") in
- let summary_opt = load_run summary_file in
- let ts = match summary_opt with
- | Some j ->
- (try Yojson.Safe.Util.(j |> member "run_id" |> to_string)
- with _ -> Fpath.basename latest_dir)
- | None -> Fpath.basename latest_dir ^ " (in progress)" in
- let n_target_solved = match summary_opt with
- | Some j ->
- (match Yojson.Safe.Util.(j |> member "targets_requested") with
- | `Int n -> Some n | _ -> None)
- | None -> None in
- (let _ = summary_opt in
- let ps = run_pkg_status_from_jsonl latest_dir in
- let n_ok = Hashtbl.fold (fun _ s n ->
- if s = "ok" then n + 1 else n) ps 0 in
- let n_fail = Hashtbl.fold (fun _ s n ->
- if s = "fail" then n + 1 else n) ps 0 in
- let n_cascade = Hashtbl.fold (fun _ s n ->
- if s = "cascade" then n + 1 else n) ps 0 in
- Printf.printf "=== Build Results (run %s) ===\n" ts;
- (match n_target_solved with
- | Some n -> Printf.printf " Solved (targets): %d\n" n
- | None -> ());
- Printf.printf " Succeeded: %d\n" n_ok;
- Printf.printf " Failed: %d\n" n_fail;
- Printf.printf " Cascade: %d\n\n" n_cascade;
- (* Build failed set from this run *)
- let failed_set : (string, unit) Hashtbl.t = Hashtbl.create 64 in
- Hashtbl.iter (fun pkg status ->
- if status <> "ok" then Hashtbl.replace failed_set pkg ()
- ) ps;
- (* Compute blocked counts from solutions *)
- let blocked_count : (string, int) Hashtbl.t = Hashtbl.create 64 in
- let sole_blocker_count : (string, int) Hashtbl.t =
- Hashtbl.create 64 in
- Hashtbl.iter (fun pkg_str solution ->
- let visited : (string, unit) Hashtbl.t = Hashtbl.create 16 in
- let failed_deps = ref [] in
- let rec walk pkg =
- let key = OpamPackage.to_string pkg in
- if Hashtbl.mem visited key then ()
- else begin
- Hashtbl.replace visited key ();
- if Hashtbl.mem failed_set key && key <> pkg_str then
- failed_deps := key :: !failed_deps;
- match OpamPackage.Map.find_opt pkg solution with
- | Some deps -> OpamPackage.Set.iter walk deps
- | None -> ()
- end
- in
- let pkg = OpamPackage.of_string pkg_str in
- walk pkg;
- let unique_failed = List.sort_uniq String.compare !failed_deps in
- List.iter (fun dep ->
- let n = try Hashtbl.find blocked_count dep
- with Not_found -> 0 in
- Hashtbl.replace blocked_count dep (n + 1);
- if List.length unique_failed = 1 then begin
- let n = try Hashtbl.find sole_blocker_count dep
- with Not_found -> 0 in
- Hashtbl.replace sole_blocker_count dep (n + 1)
- end
- ) unique_failed
- ) all_solutions;
- (* Root failures: failed packages with status "fail" (not cascade) *)
- let root_failures = Hashtbl.fold (fun pkg status acc ->
- if status = "fail" then pkg :: acc else acc
- ) ps [] in
- let root_failures = List.sort (fun a b ->
- let ba = try Hashtbl.find blocked_count a with Not_found -> 0 in
- let bb = try Hashtbl.find blocked_count b with Not_found -> 0 in
- compare bb ba
- ) root_failures in
- if root_failures <> [] then begin
- Printf.printf "Root cause failures (%d):\n"
- (List.length root_failures);
- List.iter (fun pkg ->
- let blocks = try Hashtbl.find blocked_count pkg
- with Not_found -> 0 in
- let sole = try Hashtbl.find sole_blocker_count pkg
- with Not_found -> 0 in
- if blocks > 0 then
- Printf.printf " %-45s (blocks %d, %d sole)\n"
- pkg blocks sole
- else
- Printf.printf " %-45s\n" pkg
- ) root_failures
- end;
- if n_cascade > 0 then
- Printf.printf "\nCascade: %d packages blocked by failed deps\n"
- n_cascade)
- | [] ->
- Printf.printf "No build runs yet\n");
- (* Run history *)
- if List.length runs > 1 then begin
- Printf.printf "\n=== Run History ===\n";
- List.iter (fun run_dir ->
- let ts = match load_run Fpath.(run_dir / "summary.json") with
- | Some j ->
- (try Yojson.Safe.Util.(j |> member "run_id" |> to_string)
- with _ -> Fpath.basename run_dir)
- | None -> Fpath.basename run_dir ^ " (in progress)" in
- let ps = run_pkg_status_from_jsonl run_dir in
- let n_ok = Hashtbl.fold (fun _ s n ->
- if s = "ok" then n + 1 else n) ps 0 in
- let n_fail = Hashtbl.fold (fun _ s n ->
- if s = "fail" then n + 1 else n) ps 0 in
- let n_cascade = Hashtbl.fold (fun _ s n ->
- if s = "cascade" then n + 1 else n) ps 0 in
- Printf.printf " %s: %d ok, %d fail, %d cascade\n"
- ts n_ok n_fail n_cascade
- ) runs;
- (* Diff last two runs *)
- let latest_ps = run_pkg_status_from_jsonl (List.nth runs 0) in
- let prev_ps = run_pkg_status_from_jsonl (List.nth runs 1) in
- let fixed = ref [] in
- let regressed = ref [] in
- Hashtbl.iter (fun pkg status ->
- match Hashtbl.find_opt prev_ps pkg with
- | Some prev_status ->
- if status = "ok" && prev_status <> "ok" then
- fixed := pkg :: !fixed
- else if status <> "ok" && prev_status = "ok" then
- regressed := pkg :: !regressed
- | None -> ()
- ) latest_ps;
- let fixed = List.sort String.compare !fixed in
- let regressed = List.sort String.compare !regressed in
- if fixed <> [] || regressed <> [] then begin
- Printf.printf "\n=== Changes (latest vs previous) ===\n";
- if fixed <> [] then begin
- Printf.printf " Fixed (%d):\n" (List.length fixed);
- List.iteri (fun i p ->
- if i < 20 then Printf.printf " + %s\n" p) fixed;
- if List.length fixed > 20 then
- Printf.printf " ... and %d more\n"
- (List.length fixed - 20)
- end;
- if regressed <> [] then begin
- Printf.printf " Regressed (%d):\n" (List.length regressed);
- List.iteri (fun i p ->
- if i < 20 then Printf.printf " - %s\n" p) regressed;
- if List.length regressed > 20 then
- Printf.printf " ... and %d more\n"
- (List.length regressed - 20)
- end;
- let net = List.length fixed - List.length regressed in
- Printf.printf " Net: %+d packages\n" net
- end
- end;
- 0
+ (match runs with
+ | latest :: _
+ when not
+ (Sys.file_exists
+ (Fpath.to_string Fpath.(latest / "summary.json"))) -> (
+ match Day11_batch.Live_view.load_latest ~snapshot_dir with
+ | Some lv ->
+ Printf.printf "=== Run in progress: %s ===\n" lv.run_id;
+ Printf.printf " %s\n\n"
+ (Day11_batch.Live_view.format_progress lv.progress)
+ | None -> ())
+ | _ -> ());
+ (* Use latest run for build results and failure ranking *)
+ (match runs with
+ | latest_dir :: _ ->
+ let summary_file = Fpath.(latest_dir / "summary.json") in
+ let summary_opt = load_run summary_file in
+ let ts =
+ match summary_opt with
+ | Some j -> (
+ try Yojson.Safe.Util.(j |> member "run_id" |> to_string)
+ with _ -> Fpath.basename latest_dir)
+ | None -> Fpath.basename latest_dir ^ " (in progress)"
+ in
+ let n_target_solved =
+ match summary_opt with
+ | Some j -> (
+ match
+ Yojson.Safe.Util.(j |> member "targets_requested")
+ with
+ | `Int n -> Some n
+ | _ -> None)
+ | None -> None
+ in
+ let _ = summary_opt in
+ let ps = run_pkg_status_from_jsonl latest_dir in
+ let n_ok =
+ Hashtbl.fold (fun _ s n -> if s = "ok" then n + 1 else n) ps 0
+ in
+ let n_fail =
+ Hashtbl.fold (fun _ s n -> if s = "fail" then n + 1 else n) ps 0
+ in
+ let n_cascade =
+ Hashtbl.fold
+ (fun _ s n -> if s = "cascade" then n + 1 else n)
+ ps 0
+ in
+ Printf.printf "=== Build Results (run %s) ===\n" ts;
+ (match n_target_solved with
+ | Some n -> Printf.printf " Solved (targets): %d\n" n
+ | None -> ());
+ Printf.printf " Succeeded: %d\n" n_ok;
+ Printf.printf " Failed: %d\n" n_fail;
+ Printf.printf " Cascade: %d\n\n" n_cascade;
+ (* Build failed set from this run *)
+ let failed_set : (string, unit) Hashtbl.t = Hashtbl.create 64 in
+ Hashtbl.iter
+ (fun pkg status ->
+ if status <> "ok" then Hashtbl.replace failed_set pkg ())
+ ps;
+ (* Compute blocked counts from solutions *)
+ let blocked_count : (string, int) Hashtbl.t = Hashtbl.create 64 in
+ let sole_blocker_count : (string, int) Hashtbl.t =
+ Hashtbl.create 64
+ in
+ Hashtbl.iter
+ (fun pkg_str solution ->
+ let visited : (string, unit) Hashtbl.t = Hashtbl.create 16 in
+ let failed_deps = ref [] in
+ let rec walk pkg =
+ let key = OpamPackage.to_string pkg in
+ if Hashtbl.mem visited key then ()
+ else (
+ Hashtbl.replace visited key ();
+ if Hashtbl.mem failed_set key && key <> pkg_str then
+ failed_deps := key :: !failed_deps;
+ match OpamPackage.Map.find_opt pkg solution with
+ | Some deps -> OpamPackage.Set.iter walk deps
+ | None -> ())
+ in
+ let pkg = OpamPackage.of_string pkg_str in
+ walk pkg;
+ let unique_failed =
+ List.sort_uniq String.compare !failed_deps
+ in
+ List.iter
+ (fun dep ->
+ let n =
+ try Hashtbl.find blocked_count dep with Not_found -> 0
+ in
+ Hashtbl.replace blocked_count dep (n + 1);
+ if List.length unique_failed = 1 then
+ let n =
+ try Hashtbl.find sole_blocker_count dep
+ with Not_found -> 0
+ in
+ Hashtbl.replace sole_blocker_count dep (n + 1))
+ unique_failed)
+ all_solutions;
+ (* Root failures: failed packages with status "fail" (not cascade) *)
+ let root_failures =
+ Hashtbl.fold
+ (fun pkg status acc ->
+ if status = "fail" then pkg :: acc else acc)
+ ps []
+ in
+ let root_failures =
+ List.sort
+ (fun a b ->
+ let ba =
+ try Hashtbl.find blocked_count a with Not_found -> 0
+ in
+ let bb =
+ try Hashtbl.find blocked_count b with Not_found -> 0
+ in
+ compare bb ba)
+ root_failures
+ in
+ if root_failures <> [] then (
+ Printf.printf "Root cause failures (%d):\n"
+ (List.length root_failures);
+ List.iter
+ (fun pkg ->
+ let blocks =
+ try Hashtbl.find blocked_count pkg with Not_found -> 0
+ in
+ let sole =
+ try Hashtbl.find sole_blocker_count pkg
+ with Not_found -> 0
+ in
+ if blocks > 0 then
+ Printf.printf " %-45s (blocks %d, %d sole)\n" pkg blocks
+ sole
+ else Printf.printf " %-45s\n" pkg)
+ root_failures);
+ if n_cascade > 0 then
+ Printf.printf "\nCascade: %d packages blocked by failed deps\n"
+ n_cascade
+ | [] -> Printf.printf "No build runs yet\n");
+ (* Run history *)
+ if List.length runs > 1 then (
+ Printf.printf "\n=== Run History ===\n";
+ List.iter
+ (fun run_dir ->
+ let ts =
+ match load_run Fpath.(run_dir / "summary.json") with
+ | Some j -> (
+ try Yojson.Safe.Util.(j |> member "run_id" |> to_string)
+ with _ -> Fpath.basename run_dir)
+ | None -> Fpath.basename run_dir ^ " (in progress)"
+ in
+ let ps = run_pkg_status_from_jsonl run_dir in
+ let n_ok =
+ Hashtbl.fold (fun _ s n -> if s = "ok" then n + 1 else n) ps 0
+ in
+ let n_fail =
+ Hashtbl.fold
+ (fun _ s n -> if s = "fail" then n + 1 else n)
+ ps 0
+ in
+ let n_cascade =
+ Hashtbl.fold
+ (fun _ s n -> if s = "cascade" then n + 1 else n)
+ ps 0
+ in
+ Printf.printf " %s: %d ok, %d fail, %d cascade\n" ts n_ok
+ n_fail n_cascade)
+ runs;
+ (* Diff last two runs *)
+ let latest_ps = run_pkg_status_from_jsonl (List.nth runs 0) in
+ let prev_ps = run_pkg_status_from_jsonl (List.nth runs 1) in
+ let fixed = ref [] in
+ let regressed = ref [] in
+ Hashtbl.iter
+ (fun pkg status ->
+ match Hashtbl.find_opt prev_ps pkg with
+ | Some prev_status ->
+ if status = "ok" && prev_status <> "ok" then
+ fixed := pkg :: !fixed
+ else if status <> "ok" && prev_status = "ok" then
+ regressed := pkg :: !regressed
+ | None -> ())
+ latest_ps;
+ let fixed = List.sort String.compare !fixed in
+ let regressed = List.sort String.compare !regressed in
+ if fixed <> [] || regressed <> [] then (
+ Printf.printf "\n=== Changes (latest vs previous) ===\n";
+ if fixed <> [] then (
+ Printf.printf " Fixed (%d):\n" (List.length fixed);
+ List.iteri
+ (fun i p -> if i < 20 then Printf.printf " + %s\n" p)
+ fixed;
+ if List.length fixed > 20 then
+ Printf.printf " ... and %d more\n" (List.length fixed - 20));
+ if regressed <> [] then (
+ Printf.printf " Regressed (%d):\n" (List.length regressed);
+ List.iteri
+ (fun i p -> if i < 20 then Printf.printf " - %s\n" p)
+ regressed;
+ if List.length regressed > 20 then
+ Printf.printf " ... and %d more\n"
+ (List.length regressed - 20));
+ let net = List.length fixed - List.length regressed in
+ Printf.printf " Net: %+d packages\n" net));
+ 0)
let cmd =
- let info = Cmd.info "results"
- ~doc:"Summarise build results with failure impact ranking" in
+ let info =
+ Cmd.info "results"
+ ~doc:"Summarise build results with failure impact ranking"
+ in
let term = Term.(const run $ Common.profile_term $ Common.profile_dir_term) in
Cmd.v info term
File "day11/bin/cmd_snapshots.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_snapshots.ml b/_build/default/day11/bin/.formatted/cmd_snapshots.ml
index 7b673a5..df8dbfc 100644
--- a/_build/default/day11/bin/cmd_snapshots.ml
+++ b/_build/default/day11/bin/.formatted/cmd_snapshots.ml
@@ -4,51 +4,59 @@ open Cmdliner
let run profile_name profile_dir =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
| Ok (_profile, paths) ->
- let snaps = Common.snapshot_dirs_by_recency paths in
- if snaps = [] then begin
- Printf.printf "No snapshots for profile '%s'\n%!" profile_name;
- 0
- end else begin
- Printf.printf "Snapshots for profile '%s' (%d):\n\n" profile_name
- (List.length snaps);
- List.iter (fun snap_dir ->
- let key = Fpath.basename snap_dir in
- let created = match Day11_batch.Snapshot.load snap_dir with
- | Ok s -> s.created
- | Error _ -> "?"
- in
- let n_solutions =
- let sol_dir = Day11_batch.Snapshot.solutions_dir snap_dir in
- match Bos.OS.Dir.contents sol_dir with
- | Ok files ->
- List.length (List.filter (fun p ->
- Fpath.has_ext ".json" p && Fpath.basename p <> "repos.json"
- ) files)
- | Error _ -> 0
- in
- let n_runs =
- let runs_dir = Day11_batch.Snapshot.runs_dir snap_dir in
- match Bos.OS.Dir.contents runs_dir with
- | Ok dirs -> List.length dirs
- | Error _ -> 0
- in
- let repos = match Day11_batch.Snapshot.load snap_dir with
- | Ok s ->
- String.concat ", " (List.map (fun (_, sha) ->
- String.sub sha 0 (min 12 (String.length sha))
- ) s.repos)
- | Error _ -> "?"
- in
- Printf.printf " %s %s %d solutions, %d runs [%s]\n"
- key created n_solutions n_runs repos
- ) snaps;
- 0
- end
+ let snaps = Common.snapshot_dirs_by_recency paths in
+ if snaps = [] then (
+ Printf.printf "No snapshots for profile '%s'\n%!" profile_name;
+ 0)
+ else (
+ Printf.printf "Snapshots for profile '%s' (%d):\n\n" profile_name
+ (List.length snaps);
+ List.iter
+ (fun snap_dir ->
+ let key = Fpath.basename snap_dir in
+ let created =
+ match Day11_batch.Snapshot.load snap_dir with
+ | Ok s -> s.created
+ | Error _ -> "?"
+ in
+ let n_solutions =
+ let sol_dir = Day11_batch.Snapshot.solutions_dir snap_dir in
+ match Bos.OS.Dir.contents sol_dir with
+ | Ok files ->
+ List.length
+ (List.filter
+ (fun p ->
+ Fpath.has_ext ".json" p
+ && Fpath.basename p <> "repos.json")
+ files)
+ | Error _ -> 0
+ in
+ let n_runs =
+ let runs_dir = Day11_batch.Snapshot.runs_dir snap_dir in
+ match Bos.OS.Dir.contents runs_dir with
+ | Ok dirs -> List.length dirs
+ | Error _ -> 0
+ in
+ let repos =
+ match Day11_batch.Snapshot.load snap_dir with
+ | Ok s ->
+ String.concat ", "
+ (List.map
+ (fun (_, sha) ->
+ String.sub sha 0 (min 12 (String.length sha)))
+ s.repos)
+ | Error _ -> "?"
+ in
+ Printf.printf " %s %s %d solutions, %d runs [%s]\n" key created
+ n_solutions n_runs repos)
+ snaps;
+ 0)
let cmd =
let doc = "List snapshots for a profile" in
let info = Cmd.info "snapshots" ~doc in
- Cmd.v info
- Term.(const run $ Common.profile_term $ Common.profile_dir_term)
+ Cmd.v info Term.(const run $ Common.profile_term $ Common.profile_dir_term)
File "day11/bin/cmd_status.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/cmd_status.ml b/_build/default/day11/bin/.formatted/cmd_status.ml
index 1fa85f7..f6856d0 100644
--- a/_build/default/day11/bin/cmd_status.ml
+++ b/_build/default/day11/bin/.formatted/cmd_status.ml
@@ -4,48 +4,52 @@ open Cmdliner
let run profile_name profile_dir =
match Common.load_profile ~profile_dir ~name:profile_name with
- | Error (`Msg e) -> Printf.eprintf "Error: %s\n%!" e; 1
- | Ok (_profile, paths) ->
- match Common.latest_snapshot_dir paths with
- | None -> Printf.printf "No snapshots found\n"; 1
- | Some snapshot_dir ->
- match Day11_lib.Status_index.read ~dir:snapshot_dir with
- | None ->
- (match Day11_batch.Live_view.load_latest ~snapshot_dir with
- | None ->
- Printf.printf "No status.json found, and no run in progress\n";
- 1
-| Some lv ->
- Printf.printf "Run: %s (in progress — no status.json yet)\n"
- lv.run_id;
- Printf.printf "Progress: %s\n"
- (Day11_batch.Live_view.format_progress lv.progress);
- Printf.printf "Outcomes so far: %d ok, %d fail, %d cascade\n"
- lv.counts.ok lv.counts.fail lv.counts.cascade;
- 0)
- | Some status ->
- Printf.printf "Run: %s (generated %s)\n" status.run_id status.generated;
- Printf.printf "\nBlessed:\n";
- List.iter (fun (cat, n) ->
- Printf.printf " %-20s %d\n" cat n
- ) status.blessed_totals;
- Printf.printf "\nNon-blessed:\n";
- List.iter (fun (cat, n) ->
- Printf.printf " %-20s %d\n" cat n
- ) status.non_blessed_totals;
- if status.changes <> [] then begin
- Printf.printf "\nChanges since last run:\n";
- List.iter (fun (c : Day11_lib.Status_index.change) ->
- Printf.printf " %s: %s → %s%s\n"
- c.package c.from_status c.to_status
- (if c.blessed then " [blessed]" else "")
- ) status.changes
- end;
- if status.new_packages <> [] then begin
- Printf.printf "\nNew packages: %s\n"
- (String.concat ", " status.new_packages)
- end;
- 0
+ | Error (`Msg e) ->
+ Printf.eprintf "Error: %s\n%!" e;
+ 1
+ | Ok (_profile, paths) -> (
+ match Common.latest_snapshot_dir paths with
+ | None ->
+ Printf.printf "No snapshots found\n";
+ 1
+ | Some snapshot_dir -> (
+ match Day11_lib.Status_index.read ~dir:snapshot_dir with
+ | None -> (
+ match Day11_batch.Live_view.load_latest ~snapshot_dir with
+ | None ->
+ Printf.printf "No status.json found, and no run in progress\n";
+ 1
+ | Some lv ->
+ Printf.printf "Run: %s (in progress — no status.json yet)\n"
+ lv.run_id;
+ Printf.printf "Progress: %s\n"
+ (Day11_batch.Live_view.format_progress lv.progress);
+ Printf.printf "Outcomes so far: %d ok, %d fail, %d cascade\n"
+ lv.counts.ok lv.counts.fail lv.counts.cascade;
+ 0)
+ | Some status ->
+ Printf.printf "Run: %s (generated %s)\n" status.run_id
+ status.generated;
+ Printf.printf "\nBlessed:\n";
+ List.iter
+ (fun (cat, n) -> Printf.printf " %-20s %d\n" cat n)
+ status.blessed_totals;
+ Printf.printf "\nNon-blessed:\n";
+ List.iter
+ (fun (cat, n) -> Printf.printf " %-20s %d\n" cat n)
+ status.non_blessed_totals;
+ if status.changes <> [] then (
+ Printf.printf "\nChanges since last run:\n";
+ List.iter
+ (fun (c : Day11_lib.Status_index.change) ->
+ Printf.printf " %s: %s → %s%s\n" c.package c.from_status
+ c.to_status
+ (if c.blessed then " [blessed]" else ""))
+ status.changes);
+ if status.new_packages <> [] then
+ Printf.printf "\nNew packages: %s\n"
+ (String.concat ", " status.new_packages);
+ 0))
let cmd =
let info = Cmd.info "status" ~doc:"Show build status overview" in
File "day11/bin/common.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/common.ml b/_build/default/day11/bin/.formatted/common.ml
index 972047e..4e516a9 100644
--- a/_build/default/day11/bin/common.ml
+++ b/_build/default/day11/bin/.formatted/common.ml
@@ -8,12 +8,16 @@ let os_dir_term =
let cache_dir_term =
let doc = "Top-level cache directory" in
- Arg.(required & opt (some string) None & info [ "cache-dir" ] ~docv:"DIR" ~doc)
+ Arg.(
+ required & opt (some string) None & info [ "cache-dir" ] ~docv:"DIR" ~doc)
let opam_repo_term =
- let doc = "Path to opam-repository (repeatable, layered in order — \
- later repos override earlier ones)" in
- Arg.(non_empty & opt_all string [] & info [ "opam-repository" ] ~docv:"DIR" ~doc)
+ let doc =
+ "Path to opam-repository (repeatable, layered in order — later repos \
+ override earlier ones)"
+ in
+ Arg.(
+ non_empty & opt_all string [] & info [ "opam-repository" ] ~docv:"DIR" ~doc)
let np_term =
let doc = "Number of parallel workers (default 4)" in
@@ -25,46 +29,57 @@ let arch_term =
let os_distribution_term =
let doc = "OS distribution (default debian)" in
- Arg.(value & opt string "debian" & info [ "os-distribution" ] ~docv:"DIST" ~doc)
+ Arg.(
+ value & opt string "debian" & info [ "os-distribution" ] ~docv:"DIST" ~doc)
let os_version_term =
let doc = "OS version (default bookworm)" in
Arg.(value & opt string "bookworm" & info [ "os-version" ] ~docv:"VER" ~doc)
let ocaml_version_term =
- let doc = "OCaml compiler version (e.g. ocaml-base-compiler.5.2.1 \
- or ocaml-variants.5.2.0+ox)" in
- Arg.(value & opt (some string) None & info [ "ocaml-version" ] ~docv:"PKG" ~doc)
+ let doc =
+ "OCaml compiler version (e.g. ocaml-base-compiler.5.2.1 or \
+ ocaml-variants.5.2.0+ox)"
+ in
+ Arg.(
+ value & opt (some string) None & info [ "ocaml-version" ] ~docv:"PKG" ~doc)
let patches_dir_term =
- let doc = "Directory of patches to apply before building. \
- Structure: DIR/PKG.VERSION/*.patch" in
+ let doc =
+ "Directory of patches to apply before building. Structure: \
+ DIR/PKG.VERSION/*.patch"
+ in
Arg.(value & opt (some string) None & info [ "patches-dir" ] ~docv:"DIR" ~doc)
let opam_build_repo_term =
- let doc = "Path to local opam-build source checkout \
- (builds opam-build from source for the base image)" in
- Arg.(value & opt (some string) None & info [ "opam-build-repo" ] ~docv:"DIR" ~doc)
+ let doc =
+ "Path to local opam-build source checkout (builds opam-build from source \
+ for the base image)"
+ in
+ Arg.(
+ value & opt (some string) None & info [ "opam-build-repo" ] ~docv:"DIR" ~doc)
let with_eio f =
Eio_main.run @@ fun env ->
- Eio.Switch.run @@ fun sw ->
- f ~sw (env :> Eio_unix.Stdenv.base)
+ Eio.Switch.run @@ fun sw -> f ~sw (env :> Eio_unix.Stdenv.base)
let fpath s = Fpath.v s
let setup_solver ?(arch = "x86_64") ?(os = "linux")
- ?(os_distribution = "debian") ?(os_family = "debian")
- ?(os_version = "12") opam_repositories =
- let repos_with_heads = List.map (fun repo ->
- (repo, None)
- ) opam_repositories in
+ ?(os_distribution = "debian") ?(os_family = "debian") ?(os_version = "12")
+ opam_repositories =
+ let repos_with_heads =
+ List.map (fun repo -> (repo, None)) opam_repositories
+ in
let git_packages, repos_with_shas =
- Day11_opam.Git_packages.of_repositories repos_with_heads in
+ Day11_opam.Git_packages.of_repositories repos_with_heads
+ in
(* ocaml-git corrupts Bos's temp dir setting — reset it *)
Bos.OS.Dir.set_default_tmp (Fpath.v (Filename.get_temp_dir_name ()));
- let opam_env = Day11_opam.Opam_env.std_env
- ~arch ~os ~os_distribution ~os_family ~os_version () in
+ let opam_env =
+ Day11_opam.Opam_env.std_env ~arch ~os ~os_distribution ~os_family
+ ~os_version ()
+ in
(git_packages, repos_with_shas, opam_env)
let parse_ocaml_version = function
@@ -89,8 +104,7 @@ type paths = {
}
let resolve_profile_dir s =
- if s = "" then Day11_batch.Profile.default_dir ()
- else Fpath.v s
+ if s = "" then Day11_batch.Profile.default_dir () else Fpath.v s
let load_profile ~profile_dir ~name =
let pdir = resolve_profile_dir profile_dir in
@@ -98,10 +112,12 @@ let load_profile ~profile_dir ~name =
match Day11_batch.Profile.load ~dir:profiles_dir ~name with
| Error e -> Error e
| Ok profile ->
- let cache_dir = Fpath.(pdir / "cache") in
- let os_dir = Fpath.(cache_dir / Day11_batch.Profile.os_dir_name profile) in
- let snapshots_base = Fpath.(pdir / "snapshots" / name) in
- Ok (profile, { profile_dir = pdir; cache_dir; os_dir; snapshots_base })
+ let cache_dir = Fpath.(pdir / "cache") in
+ let os_dir =
+ Fpath.(cache_dir / Day11_batch.Profile.os_dir_name profile)
+ in
+ let snapshots_base = Fpath.(pdir / "snapshots" / name) in
+ Ok (profile, { profile_dir = pdir; cache_dir; os_dir; snapshots_base })
let ensure_paths (paths : paths) =
ignore (Bos.OS.Dir.create ~path:true paths.cache_dir);
@@ -111,45 +127,48 @@ let ensure_paths (paths : paths) =
let latest_snapshot_dir (paths : paths) =
match Bos.OS.Dir.contents paths.snapshots_base with
| Error _ -> None
- | Ok entries ->
- let dirs = entries
- |> List.filter (fun p -> Bos.OS.Dir.exists p |> Result.get_ok)
- |> List.filter_map (fun p ->
- try
- let stat = Unix.stat (Fpath.to_string p) in
- Some (p, stat.Unix.st_mtime)
- with Unix.Unix_error _ -> None)
- |> List.sort (fun (_, t1) (_, t2) -> compare t2 t1)
- in
- match dirs with
- | (p, _) :: _ -> Some p
- | [] -> None
+ | Ok entries -> (
+ let dirs =
+ entries
+ |> List.filter (fun p -> Bos.OS.Dir.exists p |> Result.get_ok)
+ |> List.filter_map (fun p ->
+ try
+ let stat = Unix.stat (Fpath.to_string p) in
+ Some (p, stat.Unix.st_mtime)
+ with Unix.Unix_error _ -> None)
+ |> List.sort (fun (_, t1) (_, t2) -> compare t2 t1)
+ in
+ match dirs with (p, _) :: _ -> Some p | [] -> None)
let snapshot_dirs_by_recency (paths : paths) =
match Bos.OS.Dir.contents paths.snapshots_base with
| Error _ -> []
| Ok entries ->
- entries
- |> List.filter (fun p -> Bos.OS.Dir.exists p |> Result.get_ok)
- |> List.filter_map (fun p ->
- try
- let stat = Unix.stat (Fpath.to_string p) in
- Some (p, stat.Unix.st_mtime)
- with Unix.Unix_error _ -> None)
- |> List.sort (fun (_, t1) (_, t2) -> compare t2 t1)
- |> List.map fst
+ entries
+ |> List.filter (fun p -> Bos.OS.Dir.exists p |> Result.get_ok)
+ |> List.filter_map (fun p ->
+ try
+ let stat = Unix.stat (Fpath.to_string p) in
+ Some (p, stat.Unix.st_mtime)
+ with Unix.Unix_error _ -> None)
+ |> List.sort (fun (_, t1) (_, t2) -> compare t2 t1)
+ |> List.map fst
let read_pins_from_dir dir =
- let opam_files = Sys.readdir dir |> Array.to_list
- |> List.filter (fun f -> Filename.check_suffix f ".opam") in
- List.fold_left (fun acc filename ->
- let name = Filename.chop_suffix filename ".opam" in
- let path = Filename.concat dir filename in
- try
- let opam = OpamFile.OPAM.read
- (OpamFile.make (OpamFilename.raw path)) in
- OpamPackage.Name.Map.add
- (OpamPackage.Name.of_string name)
- (OpamPackage.Version.of_string "dev", opam) acc
- with _ -> acc
- ) OpamPackage.Name.Map.empty opam_files
+ let opam_files =
+ Sys.readdir dir
+ |> Array.to_list
+ |> List.filter (fun f -> Filename.check_suffix f ".opam")
+ in
+ List.fold_left
+ (fun acc filename ->
+ let name = Filename.chop_suffix filename ".opam" in
+ let path = Filename.concat dir filename in
+ try
+ let opam = OpamFile.OPAM.read (OpamFile.make (OpamFilename.raw path)) in
+ OpamPackage.Name.Map.add
+ (OpamPackage.Name.of_string name)
+ (OpamPackage.Version.of_string "dev", opam)
+ acc
+ with _ -> acc)
+ OpamPackage.Name.Map.empty opam_files
File "day11/bin/main.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/bin/main.ml b/_build/default/day11/bin/.formatted/main.ml
index b5fe4db..39a7e0e 100644
--- a/_build/default/day11/bin/main.ml
+++ b/_build/default/day11/bin/.formatted/main.ml
@@ -4,43 +4,48 @@ open Cmdliner
let default_term =
let doc = "Build and document OCaml packages" in
- let info = Cmd.info "day11" ~doc ~man:[
- `S Manpage.s_description;
- `P "Build, document, and manage OCaml package health checks.";
- `P "Use 'day11 batch' to build all packages.";
- `P "Use 'day11 status' to check build results.";
- `P "Use 'day11 debug TARGET' to debug a failed build.";
- ] in
+ let info =
+ Cmd.info "day11" ~doc
+ ~man:
+ [
+ `S Manpage.s_description;
+ `P "Build, document, and manage OCaml package health checks.";
+ `P "Use 'day11 batch' to build all packages.";
+ `P "Use 'day11 status' to check build results.";
+ `P "Use 'day11 debug TARGET' to debug a failed build.";
+ ]
+ in
let term = Term.(const 0) in
- Cmd.group ~default:term info [
- Cmd_profile.cmd;
- Cmd_build.cmd;
- Cmd_batch.cmd;
- Cmd_diff.cmd;
- Cmd_snapshots.cmd;
- Cmd_results.cmd;
- Cmd_status.cmd;
- Cmd_query.cmd;
- Cmd_failures.cmd;
- Cmd_cascade.cmd;
- Cmd_disk.cmd;
- Cmd_rerun.cmd;
- Cmd_rdeps.cmd;
- Cmd_gc.cmd;
- Cmd_report.cmd;
- Cmd_log.cmd;
- Cmd_debug.cmd;
- ]
+ Cmd.group ~default:term info
+ [
+ Cmd_profile.cmd;
+ Cmd_build.cmd;
+ Cmd_batch.cmd;
+ Cmd_diff.cmd;
+ Cmd_snapshots.cmd;
+ Cmd_results.cmd;
+ Cmd_status.cmd;
+ Cmd_query.cmd;
+ Cmd_failures.cmd;
+ Cmd_cascade.cmd;
+ Cmd_disk.cmd;
+ Cmd_rerun.cmd;
+ Cmd_rdeps.cmd;
+ Cmd_gc.cmd;
+ Cmd_report.cmd;
+ Cmd_log.cmd;
+ Cmd_debug.cmd;
+ ]
let () =
(* Ensure temp dirs go to /tmp, not cwd or git's tmp *)
Bos.OS.Dir.set_default_tmp (Fpath.v (Filename.get_temp_dir_name ()));
(* Honour DAY11_LOG=debug, info, warning, or error env var. *)
(match Sys.getenv_opt "DAY11_LOG" with
- | Some "debug" -> Logs.set_level (Some Logs.Debug)
- | Some "info" -> Logs.set_level (Some Logs.Info)
- | Some "warning" -> Logs.set_level (Some Logs.Warning)
- | Some "error" -> Logs.set_level (Some Logs.Error)
- | _ -> Logs.set_level (Some Logs.Warning));
+ | Some "debug" -> Logs.set_level (Some Logs.Debug)
+ | Some "info" -> Logs.set_level (Some Logs.Info)
+ | Some "warning" -> Logs.set_level (Some Logs.Warning)
+ | Some "error" -> Logs.set_level (Some Logs.Error)
+ | _ -> Logs.set_level (Some Logs.Warning));
Logs.set_reporter (Logs_fmt.reporter ());
exit (Cmd.eval' default_term)
File "src/ocaml_docs_ci.ml", line 1, characters 0-0:
diff --git a/_build/default/src/ocaml_docs_ci.ml b/_build/default/src/.formatted/ocaml_docs_ci.ml
index f8725a7..2dfd093 100644
--- a/_build/default/src/ocaml_docs_ci.ml
+++ b/_build/default/src/.formatted/ocaml_docs_ci.ml
@@ -10,9 +10,8 @@ let setup_log default_level =
before Eio re-raises. *)
Printexc.record_backtrace true;
Printexc.set_uncaught_exception_handler (fun exn raw_bt ->
- Fmt.epr "FATAL: %s@.%s@."
- (Printexc.to_string exn)
- (Printexc.raw_backtrace_to_string raw_bt))
+ Fmt.epr "FATAL: %s@.%s@." (Printexc.to_string exn)
+ (Printexc.raw_backtrace_to_string raw_bt))
let program_name = "ocaml-docs-ci"
@@ -34,22 +33,22 @@ let has_role user = function
(remote or local) flow through the pipeline and invalidate the
solver cache. *)
let load_profiles ~profile_dir names : Day11_batch.Profile.t list =
- List.map (fun name ->
- match Profile.load ~dir:profile_dir ~name with
- | Error (`Msg e) ->
- Fmt.epr "error loading profile %s: %s@." name e;
- exit 2
- | Ok profile ->
- if profile.opam_repositories = [] then begin
- Fmt.epr "profile %s has empty opam_repositories@." name;
- exit 2
- end;
- profile
- ) names
+ List.map
+ (fun name ->
+ match Profile.load ~dir:profile_dir ~name with
+ | Error (`Msg e) ->
+ Fmt.epr "error loading profile %s: %s@." name e;
+ exit 2
+ | Ok profile ->
+ if profile.opam_repositories = [] then (
+ Fmt.epr "profile %s has empty opam_repositories@." name;
+ exit 2);
+ profile)
+ names
let main () current_config github_auth mode profiles_arg profile_dir_arg
- cache_dir_arg remotes_arg pin_overlays_arg cores_per_build overcommit
- config : unit =
+ cache_dir_arg remotes_arg pin_overlays_arg cores_per_build overcommit config
+ : unit =
(* The epoch-promote node runs at [Current.Level.Dangerous]. By default
OCurrent's [--confirm] is unset (nothing is gated), so it would fire
immediately — defeating the manual-promote design. Default the
@@ -58,20 +57,20 @@ let main () current_config github_auth mode profiles_arg profile_dir_arg
and so still run unattended. An explicit [--confirm] (or the web UI
slider) overrides this. *)
(match Current.Config.get_confirm current_config with
- | Some _ -> ()
- | None ->
- Current.Config.set_confirm current_config (Some Current.Level.Dangerous));
+ | Some _ -> ()
+ | None ->
+ Current.Config.set_confirm current_config (Some Current.Level.Dangerous));
let profile_dir =
- Fpath.v (match profile_dir_arg with
+ Fpath.v
+ (match profile_dir_arg with
| Some d -> d
- | None ->
- Filename.concat (Sys.getenv "HOME") ".day11/profiles")
+ | None -> Filename.concat (Sys.getenv "HOME") ".day11/profiles")
in
let cache_dir =
- Fpath.v (match cache_dir_arg with
+ Fpath.v
+ (match cache_dir_arg with
| Some d -> d
- | None ->
- Filename.concat (Sys.getenv "HOME") ".day11/cache")
+ | None -> Filename.concat (Sys.getenv "HOME") ".day11/cache")
in
ignore (Bos.OS.Dir.create ~path:true cache_dir);
Docs_ci_lib.Startup_diagnostics.run ~profile_dir ~cache_dir;
@@ -83,63 +82,71 @@ let main () current_config github_auth mode profiles_arg profile_dir_arg
repo-polling on the resolved path string). *)
let day11_dir = Fpath.parent profile_dir in
let resolve_repo_path p =
- Fpath.v (Profile.resolve_repo ~day11_dir (Fpath.to_string p)) in
+ Fpath.v (Profile.resolve_repo ~day11_dir (Fpath.to_string p))
+ in
let remote_specs =
- List.map (fun arg ->
- match Docs_ci_lib.Remote_opam_repo.spec_of_arg arg with
- | Ok s -> { s with path = resolve_repo_path s.path }
- | Error (`Msg e) ->
- Fmt.epr "error: %s@." e;
- exit 2
- ) remotes_arg
+ List.map
+ (fun arg ->
+ match Docs_ci_lib.Remote_opam_repo.spec_of_arg arg with
+ | Ok s -> { s with path = resolve_repo_path s.path }
+ | Error (`Msg e) ->
+ Fmt.epr "error: %s@." e;
+ exit 2)
+ remotes_arg
in
if remote_specs <> [] then
- Logs.app (fun f -> f "Maintaining %d remote opam repo%s"
- (List.length remote_specs)
- (if List.length remote_specs = 1 then "" else "s"));
+ Logs.app (fun f ->
+ f "Maintaining %d remote opam repo%s" (List.length remote_specs)
+ (if List.length remote_specs = 1 then "" else "s"));
let pin_overlay_specs =
- List.map (fun arg ->
- match Docs_ci_lib.Github_pin_overlay.spec_of_arg arg with
- | Ok s -> { s with path = resolve_repo_path s.path }
- | Error (`Msg e) ->
- Fmt.epr "error: %s@." e;
- exit 2
- ) pin_overlays_arg
+ List.map
+ (fun arg ->
+ match Docs_ci_lib.Github_pin_overlay.spec_of_arg arg with
+ | Ok s -> { s with path = resolve_repo_path s.path }
+ | Error (`Msg e) ->
+ Fmt.epr "error: %s@." e;
+ exit 2)
+ pin_overlays_arg
in
if pin_overlay_specs <> [] then
- Logs.app (fun f -> f "Maintaining %d github pin overlay%s"
- (List.length pin_overlay_specs)
- (if List.length pin_overlay_specs = 1 then "" else "s"));
+ Logs.app (fun f ->
+ f "Maintaining %d github pin overlay%s"
+ (List.length pin_overlay_specs)
+ (if List.length pin_overlay_specs = 1 then "" else "s"));
let names =
match profiles_arg with
| [] ->
- (* Default: every profile in [profile_dir]. *)
- Profile.list ~dir:profile_dir
+ (* Default: every profile in [profile_dir]. *)
+ Profile.list ~dir:profile_dir
| ns -> ns
in
- if names = [] then begin
- Fmt.epr "no profiles in %a and none named on the command line@."
- Fpath.pp profile_dir;
- exit 2
- end;
- Logs.app (fun f -> f "Loading %d profile%s: %s"
- (List.length names) (if List.length names = 1 then "" else "s")
- (String.concat ", " names));
+ if names = [] then (
+ Fmt.epr "no profiles in %a and none named on the command line@." Fpath.pp
+ profile_dir;
+ exit 2);
+ Logs.app (fun f ->
+ f "Loading %d profile%s: %s" (List.length names)
+ (if List.length names = 1 then "" else "s")
+ (String.concat ", " names));
let profiles = load_profiles ~profile_dir names in
(* Optional NUMA-aware cpu slot pool. When configured, every
container launch acquires a slot with a pinned cpuset +
NUMA-local memory node, capping nested build parallelism
via cgroup v2. *)
- let cpu_slots = match cores_per_build with
+ let cpu_slots =
+ match cores_per_build with
| None | Some 0 -> None
| Some n ->
- let pool =
- Day11_runner.Cpu_slots.auto ~cores_per_build:n ~overcommit () in
- Logs.app (fun f -> f "CPU pool: %s"
- (Day11_runner.Cpu_slots.describe pool));
- Some pool
+ let pool =
+ Day11_runner.Cpu_slots.auto ~cores_per_build:n ~overcommit ()
+ in
+ Logs.app (fun f ->
+ f "CPU pool: %s" (Day11_runner.Cpu_slots.describe pool));
+ Some pool
in
- ignore @@ Eio_main.run @@ fun env ->
+ ignore
+ @@ Eio_main.run
+ @@ fun env ->
Lwt_eio.with_event_loop ~clock:(Eio.Stdenv.clock env) @@ fun _token ->
let eio_env = (env :> Eio_unix.Stdenv.base) in
(* Map from a profile's [opam_repositories] entry (a local path) to
@@ -149,15 +156,19 @@ let main () current_config github_auth mode profiles_arg profile_dir_arg
between. A profile entry whose path isn't backed by a [--remote]
spec falls back to a one-shot read of HEAD at startup. *)
let remote_schedule =
- Current_cache.Schedule.v ~valid_for:(Duration.of_hour 1) () in
- let remote_commits :
- (string, Current_git.Commit.t Current.t) Hashtbl.t =
- Hashtbl.create (List.length remote_specs) in
- List.iter (fun (s : Docs_ci_lib.Remote_opam_repo.spec) ->
- let commit = Docs_ci_lib.Remote_opam_repo.maintain_commit
- ~schedule:remote_schedule ~url:s.url ~path:s.path in
- Hashtbl.replace remote_commits (Fpath.to_string s.path) commit
- ) remote_specs;
+ Current_cache.Schedule.v ~valid_for:(Duration.of_hour 1) ()
+ in
+ let remote_commits : (string, Current_git.Commit.t Current.t) Hashtbl.t =
+ Hashtbl.create (List.length remote_specs)
+ in
+ List.iter
+ (fun (s : Docs_ci_lib.Remote_opam_repo.spec) ->
+ let commit =
+ Docs_ci_lib.Remote_opam_repo.maintain_commit ~schedule:remote_schedule
+ ~url:s.url ~path:s.path
+ in
+ Hashtbl.replace remote_commits (Fpath.to_string s.path) commit)
+ remote_specs;
(* Github-pin overlays: each spec generates an opam-repo overlay
under [<path>/repo/] from upstream HEAD on the same hourly
schedule. Profiles reference the overlay path the same way they
@@ -165,18 +176,20 @@ let main () current_config github_auth mode profiles_arg profile_dir_arg
git repo whose SHA changes when (and only when) upstream moves,
[Profile_ctx_loader] picks up the change without any further
plumbing. *)
- List.iter (fun (s : Docs_ci_lib.Github_pin_overlay.spec) ->
- let commit = Docs_ci_lib.Github_pin_overlay.maintain_commit
- ~schedule:remote_schedule ~url:s.url ~path:s.path in
- let overlay_path =
- Fpath.to_string (Fpath.(s.path / "repo")) in
- Hashtbl.replace remote_commits overlay_path commit
- ) pin_overlay_specs;
+ List.iter
+ (fun (s : Docs_ci_lib.Github_pin_overlay.spec) ->
+ let commit =
+ Docs_ci_lib.Github_pin_overlay.maintain_commit ~schedule:remote_schedule
+ ~url:s.url ~path:s.path
+ in
+ let overlay_path = Fpath.to_string Fpath.(s.path / "repo") in
+ Hashtbl.replace remote_commits overlay_path commit)
+ pin_overlay_specs;
let engine =
Current.Engine.create ~config:current_config (fun () ->
- Docs_ci_pipelines.Docs.v ~config
- ~eio_env ~cache_dir ~profiles ~remote_commits ?cpu_slots ()
- |> Current.ignore_value)
+ Docs_ci_pipelines.Docs.v ~config ~eio_env ~cache_dir ~profiles
+ ~remote_commits ?cpu_slots ()
+ |> Current.ignore_value)
in
let has_role =
if github_auth = None then Current_web.Site.allow_all else has_role
@@ -185,23 +198,18 @@ let main () current_config github_auth mode profiles_arg profile_dir_arg
let authn = Option.map Current_github.Auth.make_login_uri github_auth in
let site =
let dashboard_routes =
- Docs_ci_web.Web_routes.routes
- ~ctx:{ profile_dir; cache_dir } in
+ Docs_ci_web.Web_routes.routes ~ctx:{ profile_dir; cache_dir }
+ in
let routes =
- Routes.[
- (s "login" /? nil) @--> Current_github.Auth.login github_auth;
- ]
+ Routes.[ (s "login" /? nil) @--> Current_github.Auth.login github_auth ]
@ dashboard_routes
@ Current_web.routes engine
in
Current_web.Site.(v ?authn ~has_role ~secure_cookies)
~name:program_name routes
in
- Lwt_eio.Promise.await_lwt (Lwt.choose
- [
- Current.Engine.thread engine;
- Current_web.run ~mode site;
- ])
+ Lwt_eio.Promise.await_lwt
+ (Lwt.choose [ Current.Engine.thread engine; Current_web.run ~mode site ])
open Cmdliner
@@ -212,75 +220,79 @@ let setup_log =
let profiles_arg =
Arg.value
@@ Arg.opt Arg.(list string) []
- @@ Arg.info ~doc:"Comma-separated list of day11 profile names to run. \
- If unset, every profile in --profile-dir is used."
+ @@ Arg.info
+ ~doc:
+ "Comma-separated list of day11 profile names to run. If unset, every \
+ profile in --profile-dir is used."
~docv:"PROFILES" [ "profiles" ]
let profile_dir_arg =
Arg.value
@@ Arg.opt Arg.(some string) None
- @@ Arg.info ~doc:"Directory containing day11 profile JSON files. \
- Defaults to ~/.day11/profiles."
+ @@ Arg.info
+ ~doc:
+ "Directory containing day11 profile JSON files. Defaults to \
+ ~/.day11/profiles."
~docv:"DIR" [ "profile-dir" ]
let cache_dir_arg =
Arg.value
@@ Arg.opt Arg.(some string) None
- @@ Arg.info ~doc:"day11 cache root. Defaults to ~/.day11/cache."
- ~docv:"DIR" [ "cache-dir" ]
+ @@ Arg.info ~doc:"day11 cache root. Defaults to ~/.day11/cache." ~docv:"DIR"
+ [ "cache-dir" ]
let remotes_arg =
Arg.value
@@ Arg.opt_all Arg.string []
@@ Arg.info
- ~doc:"Mirror a remote opam-repository into a local path. \
- Repeatable. Format: $(b,URL=PATH). ocaml-docs-ci clones \
- $(b,URL) into $(b,PATH) at startup and fetches it \
- hourly; local commits are preserved (fast-forward-only \
- merge, fails if the working tree has diverged). Day11 \
- profiles reference $(b,PATH) as a regular local repo. \
- A relative $(b,PATH) is resolved against the .day11 root \
- (--profile-dir's parent), the same as a profile's \
- $(i,opam_repositories) entries — so a relative spec path \
- lines up with the matching relative entry in a profile."
+ ~doc:
+ "Mirror a remote opam-repository into a local path. Repeatable. \
+ Format: $(b,URL=PATH). ocaml-docs-ci clones $(b,URL) into $(b,PATH) \
+ at startup and fetches it hourly; local commits are preserved \
+ (fast-forward-only merge, fails if the working tree has diverged). \
+ Day11 profiles reference $(b,PATH) as a regular local repo. A \
+ relative $(b,PATH) is resolved against the .day11 root \
+ (--profile-dir's parent), the same as a profile's \
+ $(i,opam_repositories) entries — so a relative spec path lines up \
+ with the matching relative entry in a profile."
~docv:"URL=PATH" [ "remote" ]
let pin_overlays_arg =
Arg.value
@@ Arg.opt_all Arg.string []
@@ Arg.info
- ~doc:"Track a github URL and republish its $(b,*.opam) files \
- as a synthetic opam-repo overlay. Repeatable. Format: \
- $(b,URL=PATH). On the same hourly schedule as $(b,--remote), \
- ocaml-docs-ci clones $(b,URL) into $(b,PATH/upstream/), \
- rewrites each $(b,*.opam) with $(i,version:) set to \
- $(i,<latest-tag>+master.<YYYYMMDD>.<sha7>) and $(i,src:) \
- pointing at the pinned commit, and commits the result to \
- $(b,PATH/repo/) (its own git repo). Profiles reference \
- $(b,PATH/repo) as a regular local repo. As with \
- $(b,--remote), a relative $(b,PATH) is resolved against \
- the .day11 root (--profile-dir's parent)."
+ ~doc:
+ "Track a github URL and republish its $(b,*.opam) files as a \
+ synthetic opam-repo overlay. Repeatable. Format: $(b,URL=PATH). On \
+ the same hourly schedule as $(b,--remote), ocaml-docs-ci clones \
+ $(b,URL) into $(b,PATH/upstream/), rewrites each $(b,*.opam) with \
+ $(i,version:) set to $(i,<latest-tag>+master.<YYYYMMDD>.<sha7>) and \
+ $(i,src:) pointing at the pinned commit, and commits the result to \
+ $(b,PATH/repo/) (its own git repo). Profiles reference \
+ $(b,PATH/repo) as a regular local repo. As with $(b,--remote), a \
+ relative $(b,PATH) is resolved against the .day11 root \
+ (--profile-dir's parent)."
~docv:"URL=PATH" [ "github-pin-overlay" ]
let cores_per_build_arg =
Arg.value
@@ Arg.opt Arg.(some int) None
@@ Arg.info
- ~doc:"Cores per container. Enables cgroup cpuset pinning and \
- NUMA-local memory allocation (when the host has 2+ NUMA \
- nodes). Host CPUs are split into slots of this size; \
- each container sees exactly N cpus via [nproc]. 0 / \
- unset disables pinning."
+ ~doc:
+ "Cores per container. Enables cgroup cpuset pinning and NUMA-local \
+ memory allocation (when the host has 2+ NUMA nodes). Host CPUs are \
+ split into slots of this size; each container sees exactly N cpus \
+ via [nproc]. 0 / unset disables pinning."
~docv:"N" [ "cores-per-build" ]
let overcommit_arg =
Arg.value
@@ Arg.opt Arg.float 1.0
@@ Arg.info
- ~doc:"Multiplier on the strict CPU-bounded slot count. 1.0 \
- (default) gives each build exclusive cpus; 1.5 shares \
- cpusets 50% of the time; 2.0 doubles every cpuset. Only \
- effective when --cores-per-build is set."
+ ~doc:
+ "Multiplier on the strict CPU-bounded slot count. 1.0 (default) gives \
+ each build exclusive cpus; 1.5 shares cpusets 50% of the time; 2.0 \
+ doubles every cpuset. Only effective when --cores-per-build is set."
~docv:"FACTOR" [ "overcommit" ]
let version =
File "src/web/static_docs.ml", line 1, characters 0-0:
diff --git a/_build/default/src/web/static_docs.ml b/_build/default/src/web/.formatted/static_docs.ml
index c346c6d..cd562f6 100644
--- a/_build/default/src/web/static_docs.ml
+++ b/_build/default/src/web/.formatted/static_docs.ml
@@ -1,8 +1,8 @@
(** Per-profile static-file serving for rendered HTML.
- Profiles' [html_dir] field points at the dir voodoo writes
- HTML into. We mount it at [/profiles/<name>/docs/...] so the
- dashboard can deep-link into module pages. *)
+ Profiles' [html_dir] field points at the dir voodoo writes HTML into. We
+ mount it at [/profiles/<name>/docs/...] so the dashboard can deep-link into
+ module pages. *)
module Resource = Current_web.Resource
module Profile = Day11_batch.Profile
@@ -23,15 +23,16 @@ let mime_of_ext path =
| ".txt" -> "text/plain; charset=utf-8"
| _ -> "application/octet-stream"
-(** Validate that [tail] resolves to a path strictly inside [root].
- Rejects [..] traversal. Empty segments (from leading [/] or [//]
- runs) are dropped — they're benign and routes' wildcard captures
- sometimes include them. Returns [None] on suspicious input. *)
+(** Validate that [tail] resolves to a path strictly inside [root]. Rejects [..]
+ traversal. Empty segments (from leading [/] or [//] runs) are dropped —
+ they're benign and routes' wildcard captures sometimes include them. Returns
+ [None] on suspicious input. *)
let resolve_inside ~root tail =
if String.contains tail '\x00' then None
else
- let parts = String.split_on_char '/' tail
- |> List.filter (fun s -> s <> "") in
+ let parts =
+ String.split_on_char '/' tail |> List.filter (fun s -> s <> "")
+ in
if List.exists (fun s -> s = "..") parts then None
else if parts = [] then Some Fpath.(root / "index.html")
else
@@ -40,52 +41,55 @@ let resolve_inside ~root tail =
let read_file path =
try
- Some (
- let ic = open_in_bin (Fpath.to_string path) in
- Fun.protect ~finally:(fun () -> close_in ic) (fun () ->
- let len = in_channel_length ic in
- really_input_string ic len))
+ Some
+ (let ic = open_in_bin (Fpath.to_string path) in
+ Fun.protect
+ ~finally:(fun () -> close_in ic)
+ (fun () ->
+ let len = in_channel_length ic in
+ really_input_string ic len))
with _ -> None
-(** Resource for [/profiles/<name>/docs/<tail>]. Resolves [tail]
- relative to the profile's [html_dir], serves the file with a
- sniffed MIME type. Empty [tail] (i.e. just [/.../docs/])
- rewrites to [index.html]. *)
+(** Resource for [/profiles/<name>/docs/<tail>]. Resolves [tail] relative to the
+ profile's [html_dir], serves the file with a sniffed MIME type. Empty [tail]
+ (i.e. just [/.../docs/]) rewrites to [index.html]. *)
let resource ~profile_dir name tail =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
let open Lwt.Syntax in
let* response =
match Profile.load ~dir:profile_dir ~name with
| Error (`Msg e) ->
- Current_web.Context.respond_error web_ctx
- `Not_found (Printf.sprintf "no such profile: %s (%s)" name e)
- | Ok profile ->
- match profile.html_dir with
- | None ->
- Current_web.Context.respond_error web_ctx
- `Not_found
- (Printf.sprintf "profile %s has no html_dir configured" name)
- | Some root_str ->
- (* Serve through the [html-live] symlink (the live epoch). *)
- let root = Fpath.(v root_str / "html-live") in
- let tail = if tail = "" then "index.html" else tail in
- (match resolve_inside ~root tail with
- | None ->
- Current_web.Context.respond_error web_ctx
- `Bad_request (Printf.sprintf "bad path: %S" tail)
- | Some path ->
- match read_file path with
- | None ->
- Current_web.Context.respond_error web_ctx
- `Not_found "file not found"
- | Some body ->
- let headers = Cohttp.Header.init_with "Content-Type"
- (mime_of_ext (Fpath.to_string path)) in
- Cohttp_lwt_unix.Server.respond_string
- ~headers ~status:`OK ~body ())
+ Current_web.Context.respond_error web_ctx `Not_found
+ (Printf.sprintf "no such profile: %s (%s)" name e)
+ | Ok profile -> (
+ match profile.html_dir with
+ | None ->
+ Current_web.Context.respond_error web_ctx `Not_found
+ (Printf.sprintf "profile %s has no html_dir configured" name)
+ | Some root_str -> (
+ (* Serve through the [html-live] symlink (the live epoch). *)
+ let root = Fpath.(v root_str / "html-live") in
+ let tail = if tail = "" then "index.html" else tail in
+ match resolve_inside ~root tail with
+ | None ->
+ Current_web.Context.respond_error web_ctx `Bad_request
+ (Printf.sprintf "bad path: %S" tail)
+ | Some path -> (
+ match read_file path with
+ | None ->
+ Current_web.Context.respond_error web_ctx `Not_found
+ "file not found"
+ | Some body ->
+ let headers =
+ Cohttp.Header.init_with "Content-Type"
+ (mime_of_ext (Fpath.to_string path))
+ in
+ Cohttp_lwt_unix.Server.respond_string ~headers
+ ~status:`OK ~body ())))
in
Lwt.return response
end
File "src/web/templates.ml", line 1, characters 0-0:
diff --git a/_build/default/src/web/templates.ml b/_build/default/src/web/.formatted/templates.ml
index 1e1aa9e..4af51eb 100644
--- a/_build/default/src/web/templates.ml
+++ b/_build/default/src/web/.formatted/templates.ml
@@ -1,16 +1,16 @@
-(** Reusable in-page helpers for the dashboard pages. Pages render
- via {!Current_web.Context.respond_ok}, which already wraps the
- body in the site-wide chrome (the OCurrent nav with our pages
- listed via their [nav_link] methods). What lives here is the
- smaller bits that need to look the same across pages —
- breadcrumbs, status badges, short-SHA rendering, etc. *)
+(** Reusable in-page helpers for the dashboard pages. Pages render via
+ {!Current_web.Context.respond_ok}, which already wraps the body in the
+ site-wide chrome (the OCurrent nav with our pages listed via their
+ [nav_link] methods). What lives here is the smaller bits that need to look
+ the same across pages — breadcrumbs, status badges, short-SHA rendering,
+ etc. *)
open Tyxml.Html
-(** Inline stylesheet. Loaded as a [<style>] block at the top of
- each page body — small enough to inline, no static-asset
- plumbing to worry about. *)
-let style = {|
+(** Inline stylesheet. Loaded as a [<style>] block at the top of each page body
+ — small enough to inline, no static-asset plumbing to worry about. *)
+let style =
+ {|
.crumbs { color: #34495e; font-size: 0.9em;
margin: 0 0 1em 0; padding-bottom: 0.4em;
border-bottom: 1px solid #ecf0f1; }
@@ -35,26 +35,27 @@ let style = {|
let style_block = Tyxml.Html.style [ Unsafe.data style ]
-(** Status-aware text. Maps a [history.jsonl] / [build.jsonl] status
- string to a colour-coded [<span>]. *)
+(** Status-aware text. Maps a [history.jsonl] / [build.jsonl] status string to a
+ colour-coded [<span>]. *)
let status_span s =
- let cls = match s with
+ let cls =
+ match s with
| "ok" | "success" -> "ok"
| "fail" | "failure" | "error" -> "fail"
| "cascade" -> "cascade"
| "pending" | "in_progress" -> "pending"
- | _ -> "" in
+ | _ -> ""
+ in
span ~a:[ a_class [ cls ] ] [ txt s ]
(** First 12 characters of a SHA. *)
-let short_sha s =
- if String.length s <= 12 then s else String.sub s 0 12
+let short_sha s = if String.length s <= 12 then s else String.sub s 0 12
(** Render a SHA as monospace small text. *)
let sha_span s = span ~a:[ a_class [ "sha" ] ] [ txt (short_sha s) ]
-(** Breadcrumb element. [parts] is a list of [(href_opt, text)] —
- [None] for the current (non-link) page. *)
+(** Breadcrumb element. [parts] is a list of [(href_opt, text)] — [None] for the
+ current (non-link) page. *)
let breadcrumbs parts =
let sep = txt " › " in
let render = function
@@ -66,5 +67,4 @@ let breadcrumbs parts =
| [ x ] -> [ x ]
| x :: rest -> x :: sep :: interleave rest
in
- div ~a:[ a_class [ "crumbs" ] ]
- (interleave (List.map render parts))
+ div ~a:[ a_class [ "crumbs" ] ] (interleave (List.map render parts))
File "src/web/web_routes.ml", line 1, characters 0-0:
diff --git a/_build/default/src/web/web_routes.ml b/_build/default/src/web/.formatted/web_routes.ml
index e148f64..9c6318e 100644
--- a/_build/default/src/web/web_routes.ml
+++ b/_build/default/src/web/.formatted/web_routes.ml
@@ -1,44 +1,37 @@
(** Route table for the dashboard pages.
- The host wires this in alongside its own routes by appending
- [routes ~ctx] to the [Routes.[ ... ]] list passed to
- [Current_web.Site.v]. *)
+ The host wires this in alongside its own routes by appending [routes ~ctx]
+ to the [Routes.[ ... ]] list passed to [Current_web.Site.v]. *)
module Resource = Current_web.Resource
let routes ~(ctx : Pages.ctx) =
- let p = Pages.{ profile_dir = ctx.profile_dir;
- cache_dir = ctx.cache_dir } in
+ let p = Pages.{ profile_dir = ctx.profile_dir; cache_dir = ctx.cache_dir } in
let open Routes in
[
(s "profiles" /? nil) @--> (Pages.profiles_index ~ctx:p :> Resource.t);
- (s "profiles" / str /? nil) @-->
- (fun name -> (Pages.profile_dashboard ~ctx:p name :> Resource.t));
- (s "profiles" / str / s "snapshots" /? nil) @-->
- (fun name -> (Pages.snapshots_list ~ctx:p name :> Resource.t));
- (s "profiles" / str / s "recent" /? nil) @-->
- (fun name -> (Pages.recent_changes ~ctx:p name :> Resource.t));
- (s "profiles" / str / s "snapshots" / str /? nil) @-->
- (fun name key ->
- (Pages.snapshot_detail ~ctx:p name key :> Resource.t));
- (s "profiles" / str / s "snapshots" / str / s "diff" / str /? nil) @-->
- (fun name key_old key_new ->
- (Pages.snapshot_diff ~ctx:p name key_old key_new :> Resource.t));
- (s "profiles" / str / s "p" / str /? nil) @-->
- (fun name pkg ->
- (Pages.package_index ~ctx:p name pkg :> Resource.t));
- (s "profiles" / str / s "p" / str / str /? nil) @-->
- (fun name pkg ver ->
- (Pages.package_version ~ctx:p name pkg ver :> Resource.t));
- (s "profiles" / str / s "u" / str /? nil) @-->
- (fun name hash ->
- (Pages.universe_page ~ctx:p name hash :> Resource.t));
- (s "profiles" / str / s "builds" / str / s "log" /? nil) @-->
- (fun name hash ->
- (Pages.build_log_view ~ctx:p name hash :> Resource.t));
- (s "profiles" / str / s "docs" /? wildcard) @-->
- (fun name parts ->
- let tail = Parts.wildcard_match parts in
- (Static_docs.resource ~profile_dir:ctx.profile_dir name tail
- :> Resource.t));
+ ( (s "profiles" / str /? nil) @--> fun name ->
+ (Pages.profile_dashboard ~ctx:p name :> Resource.t) );
+ ( (s "profiles" / str / s "snapshots" /? nil) @--> fun name ->
+ (Pages.snapshots_list ~ctx:p name :> Resource.t) );
+ ( (s "profiles" / str / s "recent" /? nil) @--> fun name ->
+ (Pages.recent_changes ~ctx:p name :> Resource.t) );
+ ( (s "profiles" / str / s "snapshots" / str /? nil) @--> fun name key ->
+ (Pages.snapshot_detail ~ctx:p name key :> Resource.t) );
+ ( (s "profiles" / str / s "snapshots" / str / s "diff" / str /? nil)
+ @--> fun name key_old key_new ->
+ (Pages.snapshot_diff ~ctx:p name key_old key_new :> Resource.t) );
+ ( (s "profiles" / str / s "p" / str /? nil) @--> fun name pkg ->
+ (Pages.package_index ~ctx:p name pkg :> Resource.t) );
+ ( (s "profiles" / str / s "p" / str / str /? nil) @--> fun name pkg ver ->
+ (Pages.package_version ~ctx:p name pkg ver :> Resource.t) );
+ ( (s "profiles" / str / s "u" / str /? nil) @--> fun name hash ->
+ (Pages.universe_page ~ctx:p name hash :> Resource.t) );
+ ( (s "profiles" / str / s "builds" / str / s "log" /? nil)
+ @--> fun name hash -> (Pages.build_log_view ~ctx:p name hash :> Resource.t)
+ );
+ ( (s "profiles" / str / s "docs" /? wildcard) @--> fun name parts ->
+ let tail = Parts.wildcard_match parts in
+ (Static_docs.resource ~profile_dir:ctx.profile_dir name tail
+ :> Resource.t) );
]
File "day11/doc/generate.ml", line 1, characters 0-0:
diff --git a/_build/default/day11/doc/generate.ml b/_build/default/day11/doc/.formatted/generate.ml
index 1c23d68..935ae3b 100644
--- a/_build/default/day11/doc/generate.ml
+++ b/_build/default/day11/doc/.formatted/generate.ml
@@ -3,61 +3,62 @@ module Tool = Day11_opam_layer.Tool
module Installed_files = Day11_opam_layer.Installed_files
type build = Build.t
-
type node_kind = Build | Tool | Compile | Doc_all | Link
-(** One doc-side node (compile, doc-all or link) with everything dispatch
- and reporting need on the node itself rather than in parallel tables.
- [build_node] is the build layer it documents; [layer] is this node's
- own layer (its hash is [layer.hash]); [doc_deps] are the dependency
- doc nodes it mounts — for compile/doc-all these come from the build-dep
- recursion, for link from the solution's (wider) doc-deps. [universe] is
- the real [u/<hash>] output universe (matches the build log). *)
type doc_node = {
build_node : build;
kind : node_kind;
layer : build;
doc_deps : doc_node list;
compile_layer : build option;
- (** For a [Link] node, its own compile node's layer (the thing being
- linked); [None] for compile/doc-all nodes. *)
+ (** For a [Link] node, its own compile node's layer (the thing being
+ linked); [None] for compile/doc-all nodes. *)
compiler : OpamPackage.t option;
odoc_tool : Tool.t option;
universe : string;
blessed : bool;
}
+(** One doc-side node (compile, doc-all or link) with everything dispatch and
+ reporting need on the node itself rather than in parallel tables.
+ [build_node] is the build layer it documents; [layer] is this node's own
+ layer (its hash is [layer.hash]); [doc_deps] are the dependency doc nodes it
+ mounts — for compile/doc-all these come from the build-dep recursion, for
+ link from the solution's (wider) doc-deps. [universe] is the real [u/<hash>]
+ output universe (matches the build log). *)
(* Names of opam wrappers tagged [flags: compiler] — what the
solver pins as "the OCaml version" and what [odoc_tools] is
keyed on. Distinct from {!Doc_build.is_compiler_pkg}, which
identifies the {e real} compiler whose build installs stdlib. *)
-let solver_compiler_names = List.map OpamPackage.Name.of_string
- [ "ocaml-base-compiler"; "ocaml-variants"; "ocaml-system" ]
+let solver_compiler_names =
+ List.map OpamPackage.Name.of_string
+ [ "ocaml-base-compiler"; "ocaml-variants"; "ocaml-system" ]
let find_compiler solution =
- OpamPackage.Map.fold (fun pkg _deps acc ->
- match acc with
- | Some _ -> acc
- | None ->
- if List.exists (OpamPackage.Name.equal (OpamPackage.name pkg))
- solver_compiler_names
- then Some pkg
- else None
- ) solution None
+ OpamPackage.Map.fold
+ (fun pkg _deps acc ->
+ match acc with
+ | Some _ -> acc
+ | None ->
+ if
+ List.exists
+ (OpamPackage.Name.equal (OpamPackage.name pkg))
+ solver_compiler_names
+ then Some pkg
+ else None)
+ solution None
-(** Collect transitive build dep nodes into a [seen] map keyed by
- hash. Storing the {b full} [Build.t] (not just the hash) lets
- callers look the dep up by [(dep.universe, dep.pkg)] — the key
- that uniquely identifies a doc node. Looking up by build_hash
- alone collapses across doc-deps universes because multiple
- [(pkg, doc_universe)] variants can share a build_hash. *)
+(** Collect transitive build dep nodes into a [seen] map keyed by hash. Storing
+ the {b full} [Build.t] (not just the hash) lets callers look the dep up by
+ [(dep.universe, dep.pkg)] — the key that uniquely identifies a doc node.
+ Looking up by build_hash alone collapses across doc-deps universes because
+ multiple [(pkg, doc_universe)] variants can share a build_hash. *)
let collect_transitive_deps (seen : (string, Build.t) Hashtbl.t)
(node : Build.t) =
let rec walk (n : Build.t) =
- if not (Hashtbl.mem seen n.hash) then begin
+ if not (Hashtbl.mem seen n.hash) then (
Hashtbl.replace seen n.hash n;
- List.iter walk n.deps
- end
+ List.iter walk n.deps)
in
walk node
@@ -69,17 +70,15 @@ module Layer = Day11_layer.Layer
(** A dep doc layer's status when consulted at dispatch time. *)
type dep_layer_status =
- | Layer_ok of Fpath.t
- (** Layer succeeded; mount its dir as a lowerdir. *)
+ | Layer_ok of Fpath.t (** Layer succeeded; mount its dir as a lowerdir. *)
| Layer_missing
- (** No [layer.json] on disk — the dep hasn't been built yet.
- Indicates a sequencing bug: the executor should have waited
- for this dep before dispatching the current node. *)
+ (** No [layer.json] on disk — the dep hasn't been built yet. Indicates a
+ sequencing bug: the executor should have waited for this dep before
+ dispatching the current node. *)
| Layer_failed
- (** [layer.json] present with [exit_status <> 0] — dep build
- failed. Means the executor cascade-detection didn't catch
- this; downstream should fail rather than dispatch with a
- partial dep set. *)
+ (** [layer.json] present with [exit_status <> 0] — dep build failed. Means
+ the executor cascade-detection didn't catch this; downstream should
+ fail rather than dispatch with a partial dep set. *)
let inspect_layer env ~os_dir hash =
let layer = Layer.of_hash ~os_dir hash in
@@ -92,97 +91,96 @@ let pp_dep_status ppf = function
| Layer_missing -> Fmt.string ppf "missing"
| Layer_failed -> Fmt.string ppf "failed"
-(** Find dep compile layer dirs by looking up each transitive build
- dep's compile/doc-all hash from the precomputed mapping.
-
- Returns [Ok dirs] when every documentable transitive build dep's
- doc layer is present and successful. Deps with no doc node (no
- documentable libs) are legitimately skipped — those are CLI-only
- packages that depend on [ocaml] to build but install no findlib
- libraries.
-
- Returns [Error missing] when any documentable dep's doc layer is
- {b missing} or {b failed}: the dispatcher must NOT proceed in
- that state, because voodoo's [extra_paths] walk would only see a
- partial prep tree, the linker would silently emit unresolved
- references for libs whose [.odoc] files weren't mounted, and the
- resulting layer would be content-addressed by inputs that don't
- reflect the actual prep tree — so a re-dispatch would hit the
- cache and return the same broken artefacts forever. The earlier
- silent-skip behaviour was a known hazard described in
- {!page-doc_dep_graphs} "How a missing edge looks".
-
- {b Walks [build_deps]} (via [collect_transitive_deps] over
- [node.deps]). Correct closure for the {b compile} and {b doc-all}
- phases — see {!page-doc_dep_graphs} §2 and §4. {b Do not call
- this from the link phase}: link needs the [doc_deps] closure
- (which adds [{post}] and [x-extra-doc-deps]); see
- {!page-doc_dep_graphs} §3. *)
(* Inspect every dep doc layer in the transitive closure over [doc_deps]
(a DAG — compile/link split breaks doc-dep cycles), deduped by layer
hash. Replaces the old [build_to_doc_hash] + transitive build-dep walk:
[doc_deps] are already the documentable deps (with pass-through), so
flattening them yields the same layer set without any table. *)
+
+(** Find dep compile layer dirs by looking up each transitive build dep's
+ compile/doc-all hash from the precomputed mapping.
+
+ Returns [Ok dirs] when every documentable transitive build dep's doc layer
+ is present and successful. Deps with no doc node (no documentable libs) are
+ legitimately skipped — those are CLI-only packages that depend on [ocaml] to
+ build but install no findlib libraries.
+
+ Returns [Error missing] when any documentable dep's doc layer is {b missing}
+ or {b failed}: the dispatcher must NOT proceed in that state, because
+ voodoo's [extra_paths] walk would only see a partial prep tree, the linker
+ would silently emit unresolved references for libs whose [.odoc] files
+ weren't mounted, and the resulting layer would be content-addressed by
+ inputs that don't reflect the actual prep tree — so a re-dispatch would hit
+ the cache and return the same broken artefacts forever. The earlier
+ silent-skip behaviour was a known hazard described in {!page-doc_dep_graphs}
+ "How a missing edge looks".
+
+ {b Walks [build_deps]} (via [collect_transitive_deps] over [node.deps]).
+ Correct closure for the {b compile} and {b doc-all} phases — see
+ {!page-doc_dep_graphs} §2 and §4. {b Do not call this from the link phase}:
+ link needs the [doc_deps] closure (which adds [{post}] and
+ [x-extra-doc-deps]); see {!page-doc_dep_graphs} §3. *)
let find_dep_compile_layers env ~os_dir (doc_deps : doc_node list) =
let seen : (string, doc_node) Hashtbl.t = Hashtbl.create 16 in
let rec collect (dn : doc_node) =
- if not (Hashtbl.mem seen dn.layer.hash) then begin
+ if not (Hashtbl.mem seen dn.layer.hash) then (
Hashtbl.replace seen dn.layer.hash dn;
- List.iter collect dn.doc_deps
- end
+ List.iter collect dn.doc_deps)
in
List.iter collect doc_deps;
let dirs = ref [] and missing = ref [] in
- Hashtbl.iter (fun _ (dn : doc_node) ->
- match inspect_layer env ~os_dir dn.layer.hash with
- | Layer_ok d -> dirs := d :: !dirs
- | (Layer_missing | Layer_failed) as s ->
- missing := (dn.build_node.hash, dn.layer.hash, s) :: !missing
- ) seen;
+ Hashtbl.iter
+ (fun _ (dn : doc_node) ->
+ match inspect_layer env ~os_dir dn.layer.hash with
+ | Layer_ok d -> dirs := d :: !dirs
+ | (Layer_missing | Layer_failed) as s ->
+ missing := (dn.build_node.hash, dn.layer.hash, s) :: !missing)
+ seen;
if !missing = [] then Ok !dirs else Error !missing
-(** Collect transitive build dep layer dirs. Needed in doc containers
- so that [ocamlobjinfo] and other ocaml binaries are on PATH.
- Returns [Error] on a missing/failed BUILD dep for the same
- reasons as {!find_dep_compile_layers}.
+(** Collect transitive build dep layer dirs. Needed in doc containers so that
+ [ocamlobjinfo] and other ocaml binaries are on PATH. Returns [Error] on a
+ missing/failed BUILD dep for the same reasons as {!find_dep_compile_layers}.
- {b Always walks [build_deps]}, regardless of step. Binaries don't
- care about [{post}] or [x-extra-doc-deps]; they come from the same
- closure that produced the [.cmti] files. See
- {!page-doc_dep_graphs} "Layer-mount conventions". *)
+ {b Always walks [build_deps]}, regardless of step. Binaries don't care about
+ [{post}] or [x-extra-doc-deps]; they come from the same closure that
+ produced the [.cmti] files. See {!page-doc_dep_graphs} "Layer-mount
+ conventions". *)
let find_build_deps_layers env ~os_dir (node : build) =
let seen = Hashtbl.create 16 in
List.iter (collect_transitive_deps seen) node.deps;
let dirs = ref [] and missing = ref [] in
- Hashtbl.iter (fun _hash (dep : Build.t) ->
- match inspect_layer env ~os_dir dep.hash with
- | Layer_ok d -> dirs := d :: !dirs
- | (Layer_missing | Layer_failed) as s ->
- missing := (dep.hash, dep.hash, s) :: !missing
- ) seen;
+ Hashtbl.iter
+ (fun _hash (dep : Build.t) ->
+ match inspect_layer env ~os_dir dep.hash with
+ | Layer_ok d -> dirs := d :: !dirs
+ | (Layer_missing | Layer_failed) as s ->
+ missing := (dep.hash, dep.hash, s) :: !missing)
+ seen;
if !missing = [] then Ok !dirs else Error !missing
(** Format a missing-deps error for logging. *)
let pp_missing_deps ~kind ppf missing =
- Fmt.pf ppf "%s: %d dep layer%s not ready:" kind
- (List.length missing)
+ Fmt.pf ppf "%s: %d dep layer%s not ready:" kind (List.length missing)
(if List.length missing = 1 then "" else "s");
- List.iter (fun (build_hash, doc_hash, status) ->
- Fmt.pf ppf "@\n %s/%s — %a"
- (String.sub build_hash 0 (min 12 (String.length build_hash)))
- (String.sub doc_hash 0 (min 12 (String.length doc_hash)))
- pp_dep_status status
- ) missing
+ List.iter
+ (fun (build_hash, doc_hash, status) ->
+ Fmt.pf ppf "@\n %s/%s — %a"
+ (String.sub build_hash 0 (min 12 (String.length build_hash)))
+ (String.sub doc_hash 0 (min 12 (String.length doc_hash)))
+ pp_dep_status status)
+ missing
-let compile_package ~sw env benv ~os_dir ~odoc_tool ~blessed
- ~driver_tool ~doc_deps ~dag_hash (node : build) =
+let compile_package ~sw env benv ~os_dir ~odoc_tool ~blessed ~driver_tool
+ ~doc_deps ~dag_hash (node : build) =
match odoc_tool with
| None -> false
- | Some (odoc_tool : Tool.t) ->
- let config : Doc_build.doc_config =
- { driver_tool; odoc_tool; os_dir; blessed } in
- let build_layer = Build.dir ~os_dir node in
- (* No no-doc short-circuit: even packages with neither libs nor
+ | Some (odoc_tool : Tool.t) -> (
+ let config : Doc_build.doc_config =
+ { driver_tool; odoc_tool; os_dir; blessed }
+ in
+ let build_layer = Build.dir ~os_dir node in
+ (* No no-doc short-circuit: even packages with neither libs nor
[.mld] files (CLI-only opam wrappers etc.) go through voodoo,
which sees a stub [index.mld] dropped by [Prep] and writes a
real (mostly empty) layer. That keeps [Layer.is_ok] in sync
@@ -190,32 +188,36 @@ let compile_package ~sw env benv ~os_dir ~odoc_tool ~blessed
dispatchers don't misclassify the dep as missing. The cost is
one extra container per non-documentable package per profile,
which is small and amortised by day11's cache. *)
- match
- find_dep_compile_layers env ~os_dir doc_deps,
- find_build_deps_layers env ~os_dir node
- with
- | Error missing, _ ->
- Fmt.pr " %s: compile NOT DISPATCHED — %a@."
- (OpamPackage.to_string node.pkg)
- (pp_missing_deps ~kind:"dep compile") missing;
- false
- | _, Error missing ->
- Fmt.pr " %s: compile NOT DISPATCHED — %a@."
- (OpamPackage.to_string node.pkg)
- (pp_missing_deps ~kind:"build dep") missing;
- false
- | Ok dep_compile_layers, Ok build_deps_layers ->
- match Doc_build.compile ~sw env benv ~config ~build_layer
- ~build_deps_layers ~dep_compile_layers ~hash:dag_hash node.pkg with
- | Ok _ -> true
- | Error msg ->
- Printf.printf " %s: compile FAILED (%s)\n%!"
- (OpamPackage.to_string node.pkg) msg;
- false
+ match
+ ( find_dep_compile_layers env ~os_dir doc_deps,
+ find_build_deps_layers env ~os_dir node )
+ with
+ | Error missing, _ ->
+ Fmt.pr " %s: compile NOT DISPATCHED — %a@."
+ (OpamPackage.to_string node.pkg)
+ (pp_missing_deps ~kind:"dep compile")
+ missing;
+ false
+ | _, Error missing ->
+ Fmt.pr " %s: compile NOT DISPATCHED — %a@."
+ (OpamPackage.to_string node.pkg)
+ (pp_missing_deps ~kind:"build dep")
+ missing;
+ false
+ | Ok dep_compile_layers, Ok build_deps_layers -> (
+ match
+ Doc_build.compile ~sw env benv ~config ~build_layer
+ ~build_deps_layers ~dep_compile_layers ~hash:dag_hash node.pkg
+ with
+ | Ok _ -> true
+ | Error msg ->
+ Printf.printf " %s: compile FAILED (%s)\n%!"
+ (OpamPackage.to_string node.pkg)
+ msg;
+ false))
-let link_package ~sw env benv ~os_dir ~html_dir
- ~odoc_tool ~blessed ~driver_tool ~doc_deps ~(compile_node : build)
- ~dag_hash (node : build) =
+let link_package ~sw env benv ~os_dir ~html_dir ~odoc_tool ~blessed ~driver_tool
+ ~doc_deps ~(compile_node : build) ~dag_hash (node : build) =
let build_layer = Build.dir ~os_dir node in
(* No no-doc short-circuit: see [compile_package]. The compile node
has already produced a real layer for non-documentable packages
@@ -224,130 +226,156 @@ let link_package ~sw env benv ~os_dir ~html_dir
let compile_layer = Layer.of_hash ~os_dir compile_node.hash in
if not (Layer.is_ok env compile_layer) then false
else
- match odoc_tool with
- | None -> false
- | Some (odoc_tool : Tool.t) ->
- let config : Doc_build.doc_config =
- { driver_tool; odoc_tool; os_dir; blessed } in
- let compile_layer = Layer.dir compile_layer in
- (* The link's mount set is exactly the layers of its [doc_deps] —
+ match odoc_tool with
+ | None -> false
+ | Some (odoc_tool : Tool.t) -> (
+ let config : Doc_build.doc_config =
+ { driver_tool; odoc_tool; os_dir; blessed }
+ in
+ let compile_layer = Layer.dir compile_layer in
+ (* The link's mount set is exactly the layers of its [doc_deps] —
the transitive doc-dep closure built in the link pass — so
[find_dep_compile_layers] over them gives the same set (deduped
by layer hash). Returns [Error] (link NOT dispatched) if any is
missing/failed. *)
- match find_dep_compile_layers env ~os_dir doc_deps,
- find_build_deps_layers env ~os_dir node with
- | Error missing, _ ->
- Fmt.pr " %s: link NOT DISPATCHED — %a@."
- (OpamPackage.to_string node.pkg)
- (pp_missing_deps ~kind:"doc dep") missing;
- false
- | _, Error missing ->
- Fmt.pr " %s: link NOT DISPATCHED — %a@."
- (OpamPackage.to_string node.pkg)
- (pp_missing_deps ~kind:"build dep") missing;
- false
- | Ok dep_compile_layers, Ok build_deps_layers ->
- match Doc_build.link ~sw env benv ~config ~build_layer
- ~build_deps_layers ~compile_layer
- ~dep_compile_layers ~html_dir ~hash:dag_hash node.pkg with
- | Ok () -> true
- | Error msg ->
- Printf.printf " %s: link FAILED (%s)\n%!"
- (OpamPackage.to_string node.pkg) msg;
- false
+ match
+ ( find_dep_compile_layers env ~os_dir doc_deps,
+ find_build_deps_layers env ~os_dir node )
+ with
+ | Error missing, _ ->
+ Fmt.pr " %s: link NOT DISPATCHED — %a@."
+ (OpamPackage.to_string node.pkg)
+ (pp_missing_deps ~kind:"doc dep")
+ missing;
+ false
+ | _, Error missing ->
+ Fmt.pr " %s: link NOT DISPATCHED — %a@."
+ (OpamPackage.to_string node.pkg)
+ (pp_missing_deps ~kind:"build dep")
+ missing;
+ false
+ | Ok dep_compile_layers, Ok build_deps_layers -> (
+ match
+ Doc_build.link ~sw env benv ~config ~build_layer
+ ~build_deps_layers ~compile_layer ~dep_compile_layers ~html_dir
+ ~hash:dag_hash node.pkg
+ with
+ | Ok () -> true
+ | Error msg ->
+ Printf.printf " %s: link FAILED (%s)\n%!"
+ (OpamPackage.to_string node.pkg)
+ msg;
+ false))
-let doc_all_package ~sw env benv ~os_dir ~html_dir
- ~odoc_tool ~blessed
+let doc_all_package ~sw env benv ~os_dir ~html_dir ~odoc_tool ~blessed
~driver_tool ~doc_deps ~dag_hash (node : build) =
match odoc_tool with
| None -> false
- | Some (odoc_tool : Tool.t) ->
- let config : Doc_build.doc_config =
- { driver_tool; odoc_tool; os_dir; blessed } in
- let build_layer = Build.dir ~os_dir node in
- (* No no-doc short-circuit: see [compile_package]. *)
- match
- find_dep_compile_layers env ~os_dir doc_deps,
- find_build_deps_layers env ~os_dir node
- with
- | Error missing, _ ->
- Fmt.pr " %s: doc-all NOT DISPATCHED — %a@."
- (OpamPackage.to_string node.pkg)
- (pp_missing_deps ~kind:"dep compile") missing;
- false
- | _, Error missing ->
- Fmt.pr " %s: doc-all NOT DISPATCHED — %a@."
- (OpamPackage.to_string node.pkg)
- (pp_missing_deps ~kind:"build dep") missing;
- false
- | Ok dep_compile_layers, Ok build_deps_layers ->
- match Doc_build.doc_all ~sw env benv ~config ~build_layer
- ~build_deps_layers ~dep_compile_layers
- ~html_dir ~hash:dag_hash node.pkg with
- | Ok _ -> true
- | Error msg ->
- Printf.printf " %s: doc-all FAILED (%s)\n%!"
- (OpamPackage.to_string node.pkg) msg;
- false
+ | Some (odoc_tool : Tool.t) -> (
+ let config : Doc_build.doc_config =
+ { driver_tool; odoc_tool; os_dir; blessed }
+ in
+ let build_layer = Build.dir ~os_dir node in
+ (* No no-doc short-circuit: see [compile_package]. *)
+ match
+ ( find_dep_compile_layers env ~os_dir doc_deps,
+ find_build_deps_layers env ~os_dir node )
+ with
+ | Error missing, _ ->
+ Fmt.pr " %s: doc-all NOT DISPATCHED — %a@."
+ (OpamPackage.to_string node.pkg)
+ (pp_missing_deps ~kind:"dep compile")
+ missing;
+ false
+ | _, Error missing ->
+ Fmt.pr " %s: doc-all NOT DISPATCHED — %a@."
+ (OpamPackage.to_string node.pkg)
+ (pp_missing_deps ~kind:"build dep")
+ missing;
+ false
+ | Ok dep_compile_layers, Ok build_deps_layers -> (
+ match
+ Doc_build.doc_all ~sw env benv ~config ~build_layer
+ ~build_deps_layers ~dep_compile_layers ~html_dir ~hash:dag_hash
+ node.pkg
+ with
+ | Ok _ -> true
+ | Error msg ->
+ Printf.printf " %s: doc-all FAILED (%s)\n%!"
+ (OpamPackage.to_string node.pkg)
+ msg;
+ false))
(* ── Internal: shared DAG construction ───────────────────────── *)
-(** What [build_internal_plan] produces: the full node list, the
- consolidated per-node view ([meta], keyed by layer hash — the single
- source of truth for kind / universe / blessing / deps), and the doc
- driver tool. All the per-node dispatch facts that used to live in
- parallel hashtables now live on the {!doc_node} in [meta]. *)
type internal_plan = {
all_nodes : build list;
meta : (string, doc_node) Hashtbl.t;
driver_tool : Tool.t;
}
+(** What [build_internal_plan] produces: the full node list, the consolidated
+ per-node view ([meta], keyed by layer hash — the single source of truth for
+ kind / universe / blessing / deps), and the doc driver tool. All the
+ per-node dispatch facts that used to live in parallel hashtables now live on
+ the {!doc_node} in [meta]. *)
-(** Build the doc DAG: compute compile/link/doc-all nodes with
- deterministic hashes, derive all dispatch tables. Pure function
- of the inputs — no mutable state escapes. *)
-let build_internal_plan ~os_dir:_ ~(driver_tool : Tool.t) ~odoc_tools
- ~nodes ~solutions =
+(** Build the doc DAG: compute compile/link/doc-all nodes with deterministic
+ hashes, derive all dispatch tables. Pure function of the inputs — no mutable
+ state escapes. *)
+let build_internal_plan ~os_dir:_ ~(driver_tool : Tool.t) ~odoc_tools ~nodes
+ ~solutions =
(* Collect tool nodes *)
let tool_nodes =
let seen = Hashtbl.create 64 in
let add_nodes builds =
- List.iter (fun (n : build) ->
- if not (Hashtbl.mem seen n.hash) then
- Hashtbl.replace seen n.hash n
- ) builds
+ List.iter
+ (fun (n : build) ->
+ if not (Hashtbl.mem seen n.hash) then Hashtbl.replace seen n.hash n)
+ builds
in
add_nodes driver_tool.builds;
List.iter (fun (_, (tool : Tool.t)) -> add_nodes tool.builds) odoc_tools;
Hashtbl.fold (fun _ n acc -> n :: acc) seen []
in
- let driver_final = List.find (fun (n : build) ->
- String.equal n.hash driver_tool.hash) driver_tool.builds in
- let odoc_finals = List.map (fun (compiler, (tool : Tool.t)) ->
- let final = List.find (fun (n : build) ->
- String.equal n.hash tool.hash) tool.builds in
- (compiler, tool, final)
- ) odoc_tools in
+ let driver_final =
+ List.find
+ (fun (n : build) -> String.equal n.hash driver_tool.hash)
+ driver_tool.builds
+ in
+ let odoc_finals =
+ List.map
+ (fun (compiler, (tool : Tool.t)) ->
+ let final =
+ List.find
+ (fun (n : build) -> String.equal n.hash tool.hash)
+ tool.builds
+ in
+ (compiler, tool, final))
+ odoc_tools
+ in
(* Derive compiler per build node *)
let node_compiler : (string, OpamPackage.t) Hashtbl.t =
- Hashtbl.create (List.length nodes) in
+ Hashtbl.create (List.length nodes)
+ in
let rec derive_compiler (node : build) =
match Hashtbl.find_opt node_compiler node.hash with
| Some c -> Some c
| None ->
- if List.exists (OpamPackage.Name.equal (OpamPackage.name node.pkg))
- solver_compiler_names then begin
- Hashtbl.replace node_compiler node.hash node.pkg;
- Some node.pkg
- end else
- let result = List.find_map (fun (dep : build) ->
- derive_compiler dep
- ) node.deps in
- (match result with
- | Some c -> Hashtbl.replace node_compiler node.hash c
- | None -> ());
- result
+ if
+ List.exists
+ (OpamPackage.Name.equal (OpamPackage.name node.pkg))
+ solver_compiler_names
+ then (
+ Hashtbl.replace node_compiler node.hash node.pkg;
+ Some node.pkg)
+ else
+ let result =
+ List.find_map (fun (dep : build) -> derive_compiler dep) node.deps
+ in
+ (match result with
+ | Some c -> Hashtbl.replace node_compiler node.hash c
+ | None -> ());
+ result
in
List.iter (fun node -> ignore (derive_compiler node)) nodes;
@@ -358,40 +386,47 @@ let build_internal_plan ~os_dir:_ ~(driver_tool : Tool.t) ~odoc_tools
match Hashtbl.find_opt node_compiler build_hash with
| None -> None
| Some compiler ->
- List.find_opt (fun (c, _) ->
- OpamPackage.equal c compiler) odoc_tools
- |> Option.map snd
+ List.find_opt (fun (c, _) -> OpamPackage.equal c compiler) odoc_tools
+ |> Option.map snd
in
let find_odoc_final_for_hash build_hash =
match Hashtbl.find_opt node_compiler build_hash with
| None -> None
| Some compiler ->
- List.find_opt (fun (c, _, _) ->
- OpamPackage.equal c compiler) odoc_finals
- |> Option.map (fun (_, _, final) -> final)
+ List.find_opt
+ (fun (c, _, _) -> OpamPackage.equal c compiler)
+ odoc_finals
+ |> Option.map (fun (_, _, final) -> final)
in
(* Build indexes *)
(* Index ALL nodes (build + tool) by hash so find_dep_compile_layers
can locate dep compile layers for tool packages like ocaml-compiler
that aren't in the regular build DAG but have documentable libs. *)
let build_by_hash : (string, build) Hashtbl.t =
- Hashtbl.create (List.length nodes + List.length tool_nodes) in
- List.iter (fun (node : build) ->
- Hashtbl.replace build_by_hash node.hash node) nodes;
- List.iter (fun (node : build) ->
- if not (Hashtbl.mem build_by_hash node.hash) then
- Hashtbl.replace build_by_hash node.hash node) tool_nodes;
+ Hashtbl.create (List.length nodes + List.length tool_nodes)
+ in
+ List.iter
+ (fun (node : build) -> Hashtbl.replace build_by_hash node.hash node)
+ nodes;
+ List.iter
+ (fun (node : build) ->
+ if not (Hashtbl.mem build_by_hash node.hash) then
+ Hashtbl.replace build_by_hash node.hash node)
+ tool_nodes;
let needs_split : (string, bool) Hashtbl.t = Hashtbl.create 64 in
- List.iter (fun (_target, (result : Day11_solution.Solve_result.t)) ->
- let compiler = find_compiler result.build_deps in
- let compiler_s = match compiler with
- | Some c -> OpamPackage.to_string c | None -> "" in
- OpamPackage.Map.iter (fun pkg _deps ->
- let pkg_s = OpamPackage.to_string pkg in
- if Doc_deps.needs_separate_link result pkg then
- Hashtbl.replace needs_split (pkg_s ^ ":" ^ compiler_s) true
- ) result.build_deps
- ) solutions;
+ List.iter
+ (fun (_target, (result : Day11_solution.Solve_result.t)) ->
+ let compiler = find_compiler result.build_deps in
+ let compiler_s =
+ match compiler with Some c -> OpamPackage.to_string c | None -> ""
+ in
+ OpamPackage.Map.iter
+ (fun pkg _deps ->
+ let pkg_s = OpamPackage.to_string pkg in
+ if Doc_deps.needs_separate_link result pkg then
+ Hashtbl.replace needs_split (pkg_s ^ ":" ^ compiler_s) true)
+ result.build_deps)
+ solutions;
(* Universe-aware lookup: (pkg_str, universe_str) -> build_hash.
A package identified only by (name, version) is ambiguous across
build universes — different transitive dep closures of the same
@@ -399,12 +434,15 @@ let build_internal_plan ~os_dir:_ ~(driver_tool : Tool.t) ~odoc_tools
different .odoc files. Always key by [build_hash], or by
(pkg_str, universe_str), which is what the DAG uses. *)
let pkg_universe_to_hash : (string * string, string) Hashtbl.t =
- Hashtbl.create (List.length nodes) in
- Hashtbl.iter (fun bh (node : build) ->
- let pkg_s = OpamPackage.to_string node.pkg in
- let u_s = Day11_solution.Universe.to_string node.universe in
- Hashtbl.replace pkg_universe_to_hash (pkg_s, u_s) bh
- ) build_by_hash;
+ Hashtbl.create (List.length nodes)
+ in
+ Hashtbl.iter
+ (fun bh (node : build) ->
+ let pkg_s = OpamPackage.to_string node.pkg in
+ let u_s = Day11_solution.Universe.to_string node.universe in
+ Hashtbl.replace pkg_universe_to_hash (pkg_s, u_s) bh)
+ build_by_hash;
+
(* Defensive fallback for [node_compiler]: [derive_compiler] only
assigns a compiler to a node if one is reachable through its
build-dep closure. Packages like [conf-pkg-config] have no
@@ -414,26 +452,29 @@ let build_internal_plan ~os_dir:_ ~(driver_tool : Tool.t) ~odoc_tools
[compute_compile_hash], perturbing every ancestor's compile
hash that stacks them as a dep. Assign a compiler from the
containing solution so conf-* nodes get a stable hash. *)
-
- List.iter (fun (_target, (result : Day11_solution.Solve_result.t)) ->
- match find_compiler result.build_deps with
- | None -> ()
- | Some compiler ->
- (* Universe is now keyed by doc-deps closure (see dag.ml), so
+ List.iter
+ (fun (_target, (result : Day11_solution.Solve_result.t)) ->
+ match find_compiler result.build_deps with
+ | None -> ()
+ | Some compiler ->
+ (* Universe is now keyed by doc-deps closure (see dag.ml), so
the lookup must use [doc_deps] transitively too — otherwise
[pkg_universe_to_hash] never resolves. *)
- let trans = Day11_solution.Deps.transitive_deps result.doc_deps in
- OpamPackage.Map.iter (fun pkg deps ->
- let u_s = Day11_solution.Universe.to_string
- (Day11_solution.Universe.of_deps deps) in
- let key = (OpamPackage.to_string pkg, u_s) in
- match Hashtbl.find_opt pkg_universe_to_hash key with
- | None -> ()
- | Some bh ->
- if not (Hashtbl.mem node_compiler bh) then
- Hashtbl.replace node_compiler bh compiler
- ) trans
- ) solutions;
+ let trans = Day11_solution.Deps.transitive_deps result.doc_deps in
+ OpamPackage.Map.iter
+ (fun pkg deps ->
+ let u_s =
+ Day11_solution.Universe.to_string
+ (Day11_solution.Universe.of_deps deps)
+ in
+ let key = (OpamPackage.to_string pkg, u_s) in
+ match Hashtbl.find_opt pkg_universe_to_hash key with
+ | None -> ()
+ | Some bh ->
+ if not (Hashtbl.mem node_compiler bh) then
+ Hashtbl.replace node_compiler bh compiler)
+ trans)
+ solutions;
(* For each solution S, walk its transitive build-dep closure to
determine the universe of each (pkg) in S, then record
@@ -454,78 +495,93 @@ let build_internal_plan ~os_dir:_ ~(driver_tool : Tool.t) ~odoc_tools
link/compile dispatch can read the right doc_dep set without
guessing which solution to consult. *)
let doc_dep_hashes : (string * string, string list) Hashtbl.t =
- Hashtbl.create 64 in
+ Hashtbl.create 64
+ in
let add_dep_bh ~compiler_s bh dep_bh =
let key = (bh, compiler_s) in
- let existing = try Hashtbl.find doc_dep_hashes key
- with Not_found -> [] in
+ let existing = try Hashtbl.find doc_dep_hashes key with Not_found -> [] in
if not (List.mem dep_bh existing) then
Hashtbl.replace doc_dep_hashes key (dep_bh :: existing)
in
- List.iter (fun (_target, (result : Day11_solution.Solve_result.t)) ->
- (* Same shift as above — doc_deps drive the universe; without that
+ List.iter
+ (fun (_target, (result : Day11_solution.Solve_result.t)) ->
+ (* Same shift as above — doc_deps drive the universe; without that
[lookup_bh] returns None for any pkg only reachable via
[{post & with-doc}]. *)
- let trans = Day11_solution.Deps.transitive_deps result.doc_deps in
- let compiler_s = match find_compiler result.build_deps with
- | Some c -> OpamPackage.to_string c
- | None -> "" in
- let lookup_bh pkg =
- match OpamPackage.Map.find_opt pkg trans with
- | None -> None
- | Some deps ->
- let u_s = Day11_solution.Universe.to_string
- (Day11_solution.Universe.of_deps deps) in
- Hashtbl.find_opt pkg_universe_to_hash
- (OpamPackage.to_string pkg, u_s)
- in
- OpamPackage.Map.iter (fun pkg doc_deps_set ->
- match lookup_bh pkg with
- | None -> ()
- | Some bh ->
- OpamPackage.Set.iter (fun dep ->
- match lookup_bh dep with
- | Some dep_bh -> add_dep_bh ~compiler_s bh dep_bh
+ let trans = Day11_solution.Deps.transitive_deps result.doc_deps in
+ let compiler_s =
+ match find_compiler result.build_deps with
+ | Some c -> OpamPackage.to_string c
+ | None -> ""
+ in
+ let lookup_bh pkg =
+ match OpamPackage.Map.find_opt pkg trans with
+ | None -> None
+ | Some deps ->
+ let u_s =
+ Day11_solution.Universe.to_string
+ (Day11_solution.Universe.of_deps deps)
+ in
+ Hashtbl.find_opt pkg_universe_to_hash
+ (OpamPackage.to_string pkg, u_s)
+ in
+ OpamPackage.Map.iter
+ (fun pkg doc_deps_set ->
+ match lookup_bh pkg with
| None -> ()
- ) doc_deps_set
- ) result.doc_deps
- ) solutions;
+ | Some bh ->
+ OpamPackage.Set.iter
+ (fun dep ->
+ match lookup_bh dep with
+ | Some dep_bh -> add_dep_bh ~compiler_s bh dep_bh
+ | None -> ())
+ doc_deps_set)
+ result.doc_deps)
+ solutions;
let needs_split_bh : (string, bool) Hashtbl.t = Hashtbl.create 64 in
(* If ANY solution marks a package as needing split (because of
x-extra-doc-deps), apply it to ALL build hashes for that package.
Otherwise the blessed universe might not get split link. *)
let split_pkgs : (string, unit) Hashtbl.t = Hashtbl.create 64 in
- Hashtbl.iter (fun key _ ->
- match String.index_opt key ':' with
- | None -> ()
- | Some i ->
- let pkg_s = String.sub key 0 i in
- Hashtbl.replace split_pkgs pkg_s ()
- ) needs_split;
- Hashtbl.iter (fun bh (node : build) ->
- let pkg_s = OpamPackage.to_string node.pkg in
- if Hashtbl.mem split_pkgs pkg_s then
- Hashtbl.replace needs_split_bh bh true
- ) build_by_hash;
+ Hashtbl.iter
+ (fun key _ ->
+ match String.index_opt key ':' with
+ | None -> ()
+ | Some i ->
+ let pkg_s = String.sub key 0 i in
+ Hashtbl.replace split_pkgs pkg_s ())
+ needs_split;
+ Hashtbl.iter
+ (fun bh (node : build) ->
+ let pkg_s = OpamPackage.to_string node.pkg in
+ if Hashtbl.mem split_pkgs pkg_s then
+ Hashtbl.replace needs_split_bh bh true)
+ build_by_hash;
(* Blessing must operate over the same universe space that DAG nodes
advertise — and after the doc-deps universe switch in dag.ml each
[node.universe] reflects [doc_deps], not [build_deps]. Feed
[doc_deps] in here too so [Universe.equal node.universe blessed_u]
can match. *)
- let blessed_universes = Day11_batch.Blessing.compute_blessed_universes
- (List.map (fun (t, (r : Day11_solution.Solve_result.t)) ->
- (t, r.doc_deps)) solutions) in
+ let blessed_universes =
+ Day11_batch.Blessing.compute_blessed_universes
+ (List.map
+ (fun (t, (r : Day11_solution.Solve_result.t)) -> (t, r.doc_deps))
+ solutions)
+ in
let build_hash_blessed : (string, bool) Hashtbl.t =
- Hashtbl.create (List.length nodes) in
+ Hashtbl.create (List.length nodes)
+ in
- List.iter (fun (node : build) ->
- match Hashtbl.find_opt blessed_universes node.pkg with
- | Some blessed_u when Day11_solution.Universe.equal node.universe blessed_u ->
- Hashtbl.replace build_hash_blessed node.hash true
- | _ -> ()
- ) nodes;
+ List.iter
+ (fun (node : build) ->
+ match Hashtbl.find_opt blessed_universes node.pkg with
+ | Some blessed_u
+ when Day11_solution.Universe.equal node.universe blessed_u ->
+ Hashtbl.replace build_hash_blessed node.hash true
+ | _ -> ())
+ nodes;
(* Build doc DAG nodes with deterministic hashes *)
let compile_nodes : (string, build) Hashtbl.t = Hashtbl.create 64 in
@@ -536,28 +592,41 @@ let build_internal_plan ~os_dir:_ ~(driver_tool : Tool.t) ~odoc_tools
match Hashtbl.find_opt compile_hash_cache node.hash with
| Some h -> h
| None ->
- let blessed = match Hashtbl.find_opt build_hash_blessed node.hash with
- | Some true -> true | _ -> false in
- let composite_tool_hash = match find_odoc_tool_for_hash node.hash with
- | Some odoc_tool ->
- Day11_layer.Hash.of_strings [ driver_tool.hash; odoc_tool.hash ]
- | None -> "" in
- (* Include only DIRECT deps' compile hashes. Each direct dep's
+ let blessed =
+ match Hashtbl.find_opt build_hash_blessed node.hash with
+ | Some true -> true
+ | _ -> false
+ in
+ let composite_tool_hash =
+ match find_odoc_tool_for_hash node.hash with
+ | Some odoc_tool ->
+ Day11_layer.Hash.of_strings [ driver_tool.hash; odoc_tool.hash ]
+ | None -> ""
+ in
+ (* Include only DIRECT deps' compile hashes. Each direct dep's
compile hash transitively encodes its own deps via recursion,
so sensitivity to the full transitive closure is preserved
without walking the full subtree for every node. Avoids the
O(N²) blowup of the previous v2 formulation for large DAGs. *)
- let dep_compile_hashes =
- List.map compute_compile_hash node.deps in
- let phase = if Hashtbl.mem needs_split_bh node.hash
- then "compile" else "doc-all" in
- let universe = Command.compute_universe_hash [ node.hash ] in
- let hash = Day11_layer.Hash.of_strings
- ([ phase; "v3"; node.hash; universe; composite_tool_hash;
- (if blessed then "blessed" else "unblessed") ]
- @ List.sort String.compare dep_compile_hashes) in
- Hashtbl.replace compile_hash_cache node.hash hash;
- hash
+ let dep_compile_hashes = List.map compute_compile_hash node.deps in
+ let phase =
+ if Hashtbl.mem needs_split_bh node.hash then "compile" else "doc-all"
+ in
+ let universe = Command.compute_universe_hash [ node.hash ] in
...TRUNCATED BY DUNE...
+ Hashtbl.replace seen n.hash ();
+ true))
+ (nodes @ tool_nodes @ compile_list @ doc_all_list @ !link_nodes_list)
in
(* Consolidated per-node view, keyed by each node's own layer hash —
the single source of truth for kind / universe / blessing / deps.
Covers every node in [all_nodes]: the doc nodes from above, plus the
plain build and tool nodes (which have no doc deps). *)
let meta : (string, doc_node) Hashtbl.t =
- Hashtbl.create (List.length all_doc_nodes) in
- List.iter (fun (dn : doc_node) -> Hashtbl.replace meta dn.layer.hash dn)
+ Hashtbl.create (List.length all_doc_nodes)
+ in
+ List.iter
+ (fun (dn : doc_node) -> Hashtbl.replace meta dn.layer.hash dn)
(compile_docall_doc_nodes @ link_doc_nodes);
let add_plain kind (n : build) =
if not (Hashtbl.mem meta n.hash) then
- Hashtbl.replace meta n.hash {
- build_node = n; kind; layer = n; doc_deps = [];
- compile_layer = None;
- compiler = Hashtbl.find_opt node_compiler n.hash;
- odoc_tool = None;
- universe =
- (match kind with
- | Tool -> ""
- | _ ->
- Command.compute_universe_hash [ Day11_layer.Dir.name n.hash ]);
- blessed =
- (match Hashtbl.find_opt build_hash_blessed n.hash with
- | Some b -> b | None -> false);
- }
+ Hashtbl.replace meta n.hash
+ {
+ build_node = n;
+ kind;
+ layer = n;
+ doc_deps = [];
+ compile_layer = None;
+ compiler = Hashtbl.find_opt node_compiler n.hash;
+ odoc_tool = None;
+ universe =
+ (match kind with
+ | Tool -> ""
+ | _ -> Command.compute_universe_hash [ Day11_layer.Dir.name n.hash ]);
+ blessed =
+ (match Hashtbl.find_opt build_hash_blessed n.hash with
+ | Some b -> b
+ | None -> false);
+ }
in
List.iter (add_plain Build) nodes;
List.iter (add_plain Tool) tool_nodes;
{ all_nodes = all_doc_nodes; meta; driver_tool }
-(** Build a dispatch function from the plan tables.
- The returned closure takes a fresh [~sw] per call so the caller
- can bound the lifetime of spawned subprocesses to each build. *)
+(** Build a dispatch function from the plan tables. The returned closure takes a
+ fresh [~sw] per call so the caller can bound the lifetime of spawned
+ subprocesses to each build. *)
let make_dispatch benv ~os_dir ~html_dir ~(plan : internal_plan)
~tool_source_dirs ~mounts ~build_one =
(* A node not in [meta] is a build or tool node: build it from a
@@ -766,41 +896,45 @@ let make_dispatch benv ~os_dir ~html_dir ~(plan : internal_plan)
let dispatch_other ~sw env (node : build) =
let name = OpamPackage.name node.pkg in
match OpamPackage.Name.Map.find_opt name tool_source_dirs with
- | Some dir ->
- let src_mount =
- Day11_container.Mount.bind_ro ~src:dir "/home/opam/src" in
- let strategy = Day11_opam_build.Tools.source_dir_strategy node.pkg in
- (match Day11_opam_build.Build_layer.build ~sw env benv
- ~opam_repositories:[] ~mounts:(src_mount :: mounts) node
- ~strategy () with
- | Day11_opam_build.Types.Success _ -> true | _ -> false)
- | None -> ignore (sw, env); build_one node
+ | Some dir -> (
+ let src_mount =
+ Day11_container.Mount.bind_ro ~src:dir "/home/opam/src"
+ in
+ let strategy = Day11_opam_build.Tools.source_dir_strategy node.pkg in
+ match
+ Day11_opam_build.Build_layer.build ~sw env benv ~opam_repositories:[]
+ ~mounts:(src_mount :: mounts) node ~strategy ()
+ with
+ | Day11_opam_build.Types.Success _ -> true
+ | _ -> false)
+ | None ->
+ ignore (sw, env);
+ build_one node
in
fun ~sw env (node : build) ->
match Hashtbl.find_opt plan.meta node.hash with
| None -> dispatch_other ~sw env node
- | Some dn ->
- let build_node = dn.build_node in
- (match dn.kind with
- | Compile ->
- compile_package ~sw env benv ~os_dir ~odoc_tool:dn.odoc_tool
- ~blessed:dn.blessed ~driver_tool:plan.driver_tool
- ~doc_deps:dn.doc_deps ~dag_hash:node.hash build_node
- | Doc_all ->
- doc_all_package ~sw env benv ~os_dir ~html_dir
- ~odoc_tool:dn.odoc_tool ~blessed:dn.blessed
- ~driver_tool:plan.driver_tool
- ~doc_deps:dn.doc_deps ~dag_hash:node.hash build_node
- | Link ->
- (match dn.compile_layer with
- | None -> true (* a link always has a compile sibling *)
- | Some compile_node ->
- link_package ~sw env benv ~os_dir ~html_dir
+ | Some dn -> (
+ let build_node = dn.build_node in
+ match dn.kind with
+ | Compile ->
+ compile_package ~sw env benv ~os_dir ~odoc_tool:dn.odoc_tool
+ ~blessed:dn.blessed ~driver_tool:plan.driver_tool
+ ~doc_deps:dn.doc_deps ~dag_hash:node.hash build_node
+ | Doc_all ->
+ doc_all_package ~sw env benv ~os_dir ~html_dir
~odoc_tool:dn.odoc_tool ~blessed:dn.blessed
- ~driver_tool:plan.driver_tool
- ~doc_deps:dn.doc_deps ~compile_node
- ~dag_hash:node.hash build_node)
- | Build | Tool -> dispatch_other ~sw env node)
+ ~driver_tool:plan.driver_tool ~doc_deps:dn.doc_deps
+ ~dag_hash:node.hash build_node
+ | Link -> (
+ match dn.compile_layer with
+ | None -> true (* a link always has a compile sibling *)
+ | Some compile_node ->
+ link_package ~sw env benv ~os_dir ~html_dir
+ ~odoc_tool:dn.odoc_tool ~blessed:dn.blessed
+ ~driver_tool:plan.driver_tool ~doc_deps:dn.doc_deps
+ ~compile_node ~dag_hash:node.hash build_node)
+ | Build | Tool -> dispatch_other ~sw env node)
(* ── Public API ──────────────────────────────────────────────── *)
@@ -820,32 +954,41 @@ let node_kind_of_plan (plan : internal_plan) (n : build) =
let dag_entries_of_plan (plan : internal_plan) :
Day11_lib.Dag_marshal.entry list =
let convert_kind : node_kind -> Day11_lib.Dag_marshal.kind = function
- | Build -> Build | Tool -> Tool | Compile -> Compile
- | Doc_all -> Doc_all | Link -> Link
+ | Build -> Build
+ | Tool -> Tool
+ | Compile -> Compile
+ | Doc_all -> Doc_all
+ | Link -> Link
in
- List.map (fun (n : build) ->
- (* Every node — build, tool, and doc — is in [meta] with its kind,
+ List.map
+ (fun (n : build) ->
+ (* Every node — build, tool, and doc — is in [meta] with its kind,
real universe and per-universe blessing. *)
- let kind, universe, blessed =
- match Hashtbl.find_opt plan.meta n.hash with
- | Some dn -> dn.kind, dn.universe, dn.blessed
- | None -> Build, "", false
- in
- { Day11_lib.Dag_marshal.hash = n.hash; pkg = n.pkg;
- kind = convert_kind kind;
- deps = List.map (fun (d : build) -> d.hash) n.deps;
- universe; blessed }
- ) plan.all_nodes
+ let kind, universe, blessed =
+ match Hashtbl.find_opt plan.meta n.hash with
+ | Some dn -> (dn.kind, dn.universe, dn.blessed)
+ | None -> (Build, "", false)
+ in
+ {
+ Day11_lib.Dag_marshal.hash = n.hash;
+ pkg = n.pkg;
+ kind = convert_kind kind;
+ deps = List.map (fun (d : build) -> d.hash) n.deps;
+ universe;
+ blessed;
+ })
+ plan.all_nodes
let write_dag_if_requested ~snapshot_dir plan =
match snapshot_dir with
| None -> ()
- | Some dir ->
- match Day11_lib.Dag_marshal.write ~snapshot_dir:dir
- (dag_entries_of_plan plan) with
- | Ok () -> ()
- | Error (`Msg m) ->
- Printf.eprintf " warning: failed to write dag.json: %s\n%!" m
+ | Some dir -> (
+ match
+ Day11_lib.Dag_marshal.write ~snapshot_dir:dir (dag_entries_of_plan plan)
+ with
+ | Ok () -> ()
+ | Error (`Msg m) ->
+ Printf.eprintf " warning: failed to write dag.json: %s\n%!" m)
(* Map each real output universe ([u/<hash>]) to the package versions it
contains — the doc-dep closure of the build it documents. Derived from
@@ -859,45 +1002,46 @@ let universe_manifests_of_plan (plan : internal_plan) =
match Hashtbl.find_opt pkg_cache dn.layer.hash with
| Some p -> p
| None ->
- let self = OpamPackage.to_string dn.build_node.pkg in
- let all =
- List.sort_uniq compare
- (self :: List.concat_map pkgs_of dn.doc_deps) in
- Hashtbl.replace pkg_cache dn.layer.hash all;
- all
+ let self = OpamPackage.to_string dn.build_node.pkg in
+ let all =
+ List.sort_uniq compare (self :: List.concat_map pkgs_of dn.doc_deps)
+ in
+ Hashtbl.replace pkg_cache dn.layer.hash all;
+ all
in
let tbl : (string, string list) Hashtbl.t = Hashtbl.create 1024 in
- Hashtbl.iter (fun _ (dn : doc_node) ->
- match dn.kind with
- | Doc_all | Link ->
- if dn.universe <> "" && not (Hashtbl.mem tbl dn.universe) then
- Hashtbl.replace tbl dn.universe (pkgs_of dn)
- | _ -> ()
- ) plan.meta;
+ Hashtbl.iter
+ (fun _ (dn : doc_node) ->
+ match dn.kind with
+ | Doc_all | Link ->
+ if dn.universe <> "" && not (Hashtbl.mem tbl dn.universe) then
+ Hashtbl.replace tbl dn.universe (pkgs_of dn)
+ | _ -> ())
+ plan.meta;
Hashtbl.fold (fun h pkgs acc -> (h, pkgs) :: acc) tbl []
let write_universes_if_requested ~snapshot_dir plan =
match snapshot_dir with
| None -> ()
- | Some dir ->
- let universes = universe_manifests_of_plan plan in
- match Day11_lib.Universe_manifest.write_all ~snapshot_dir:dir
- universes with
- | Ok () ->
- Printf.printf " Wrote %d universe manifests\n%!"
- (List.length universes)
- | Error (`Msg m) ->
- Printf.eprintf " warning: failed to write universes: %s\n%!" m
+ | Some dir -> (
+ let universes = universe_manifests_of_plan plan in
+ match
+ Day11_lib.Universe_manifest.write_all ~snapshot_dir:dir universes
+ with
+ | Ok () ->
+ Printf.printf " Wrote %d universe manifests\n%!"
+ (List.length universes)
+ | Error (`Msg m) ->
+ Printf.eprintf " warning: failed to write universes: %s\n%!" m)
-let run ~sw env benv ~np ~os_dir ~html_dir ~(driver_tool : Tool.t)
- ~odoc_tools ~tool_source_dirs ~mounts
- ~run_log
- ~build_one ?(on_pkg_complete = fun _ ~cached:_ ~success:_ -> ())
- ?(on_doc_complete = fun _ ~cached:_ ~success:_ -> ())
- ?snapshot_dir
- ~nodes ~solutions ~blessing_maps:_ () =
- let plan = build_internal_plan ~os_dir ~driver_tool ~odoc_tools
- ~nodes ~solutions in
+let run ~sw env benv ~np ~os_dir ~html_dir ~(driver_tool : Tool.t) ~odoc_tools
+ ~tool_source_dirs ~mounts ~run_log ~build_one
+ ?(on_pkg_complete = fun _ ~cached:_ ~success:_ -> ())
+ ?(on_doc_complete = fun _ ~cached:_ ~success:_ -> ()) ?snapshot_dir ~nodes
+ ~solutions ~blessing_maps:_ () =
+ let plan =
+ build_internal_plan ~os_dir ~driver_tool ~odoc_tools ~nodes ~solutions
+ in
Printf.printf " Doc DAG: %d total nodes\n%!" (List.length plan.all_nodes);
Day11_lib.Run_log.write_dag_structure run_log plan.all_nodes;
write_dag_if_requested ~snapshot_dir plan;
@@ -913,19 +1057,19 @@ let run ~sw env benv ~np ~os_dir ~html_dir ~(driver_tool : Tool.t)
let open Day11_opam_build.Dag_executor in
let is_cached (node : Build.t) =
let layer = Build.layer ~os_dir node in
- if not (Layer.exists env layer) then
- Not_cached
- else begin
+ if not (Layer.exists env layer) then Not_cached
+ else (
Day11_layer.Last_used.touch env (Layer.dir layer);
- if not (Layer.is_ok env layer) then Cached_fail
- else Cached_ok
- end
+ if not (Layer.is_ok env layer) then Cached_fail else Cached_ok)
+ in
+ let dispatch =
+ make_dispatch benv ~os_dir ~html_dir ~plan ~tool_source_dirs ~mounts
+ ~build_one
in
- let dispatch = make_dispatch benv ~os_dir ~html_dir ~plan
- ~tool_source_dirs ~mounts ~build_one in
let doc_cascaded : (string, unit) Hashtbl.t = Hashtbl.create 256 in
let node_kind = node_kind_of_plan plan in
- Day11_opam_build.Dag_executor.execute env ~np ~priority:node_priority ~is_cached
+ Day11_opam_build.Dag_executor.execute env ~np ~priority:node_priority
+ ~is_cached
~on_complete:(fun ~stats ~cached node success ->
let kind_tag = node_kind node in
(* Record doc outcomes at the terminal doc phase (Link for
@@ -933,38 +1077,44 @@ let run ~sw env benv ~np ~os_dir ~html_dir ~(driver_tool : Tool.t)
Fire before the cascade guard so cascaded doc failures still
get recorded in the summary. *)
(match kind_tag with
- | Doc_all | Link -> on_doc_complete node ~cached ~success
- | Build | Tool | Compile -> ());
+ | Doc_all | Link -> on_doc_complete node ~cached ~success
+ | Build | Tool | Compile -> ());
if Hashtbl.mem doc_cascaded node.hash then ()
- else begin
+ else
let status = if success then "ok" else "fail" in
- let kind = match kind_tag with
- | Compile -> "compile" | Doc_all -> "doc-all"
- | Link -> "link" | Tool -> "tool" | Build -> "build" in
- let layer = Fpath.to_string
- (Day11_opam_layer.Build.dir ~os_dir node) in
+ let kind =
+ match kind_tag with
+ | Compile -> "compile"
+ | Doc_all -> "doc-all"
+ | Link -> "link"
+ | Tool -> "tool"
+ | Build -> "build"
+ in
+ let layer = Fpath.to_string (Day11_opam_layer.Build.dir ~os_dir node) in
Day11_lib.Run_log.log_build_result run_log
~pkg:(OpamPackage.to_string node.pkg)
- ~hash:node.hash ~status ~failed_dep:None
- ~kind ~layer_dir:layer ();
+ ~hash:node.hash ~status ~failed_dep:None ~kind ~layer_dir:layer ();
(match kind_tag with
- | Build | Tool -> on_pkg_complete node ~cached ~success
- | Compile | Doc_all | Link -> ());
- if success &&
- (match node_kind node with Doc_all | Link -> true | _ -> false)
+ | Build | Tool -> on_pkg_complete node ~cached ~success
+ | Compile | Doc_all | Link -> ());
+ if
+ success
+ && match node_kind node with Doc_all | Link -> true | _ -> false
then Atomic.incr doc_count;
- if (not cached) &&
- (stats.completed mod 100 = 0 || not success) then
+ if (not cached) && (stats.completed mod 100 = 0 || not success) then
Printf.printf " [%d/%d, %d ok, %d failed, %d cascade] %s: %s\n%!"
- stats.completed stats.total stats.ok stats.failed
- stats.cascaded (OpamPackage.to_string node.pkg)
- (if success then "OK" else "FAIL")
- end)
+ stats.completed stats.total stats.ok stats.failed stats.cascaded
+ (OpamPackage.to_string node.pkg)
+ (if success then "OK" else "FAIL"))
~on_cascade:(fun ~failed ~failed_dep ->
Hashtbl.replace doc_cascaded failed.hash ();
- let kind = match node_kind failed with
- | Compile -> "compile" | Doc_all -> "doc-all"
- | Link -> "link" | _ -> "build" in
+ let kind =
+ match node_kind failed with
+ | Compile -> "compile"
+ | Doc_all -> "doc-all"
+ | Link -> "link"
+ | _ -> "build"
+ in
Day11_lib.Run_log.log_build_result run_log
~pkg:(OpamPackage.to_string failed.pkg)
~hash:failed.hash ~status:"cascade"
@@ -973,8 +1123,7 @@ let run ~sw env benv ~np ~os_dir ~html_dir ~(driver_tool : Tool.t)
plan.all_nodes
(fun node ->
let ok = dispatch ~sw env node in
- if ok &&
- (match node_kind node with Doc_all | Link -> true | _ -> false)
+ if ok && match node_kind node with Doc_all | Link -> true | _ -> false
then Atomic.incr doc_count;
ok);
(* Count results *)
@@ -982,18 +1131,28 @@ let run ~sw env benv ~np ~os_dir ~html_dir ~(driver_tool : Tool.t)
let count_success hash =
if Layer.is_ok env (Layer.of_hash ~os_dir hash) then incr total_doc_count
in
- Hashtbl.iter (fun _ (dn : doc_node) ->
- match dn.kind with
- | Compile | Doc_all -> count_success dn.layer.hash
- | _ -> ()) plan.meta;
+ Hashtbl.iter
+ (fun _ (dn : doc_node) ->
+ match dn.kind with
+ | Compile | Doc_all -> count_success dn.layer.hash
+ | _ -> ())
+ plan.meta;
let html_root = html_dir in
let total_html =
if Bos.OS.Dir.exists html_root |> Result.get_ok then
- let find_result = Day11_sys.Run.run ~sw env
- Bos.Cmd.(v "find" % Fpath.to_string html_root
- % "-name" % "*.html" % "-type" % "f") None in
- List.length (String.split_on_char '\n'
- (String.trim find_result.output)
+ let find_result =
+ Day11_sys.Run.run ~sw env
+ Bos.Cmd.(
+v "find"
+ % Fpath.to_string html_root
+ % "-name"
+ % "*.html"
+ % "-type"
+ % "f")
+ None
+ in
+ List.length
+ (String.split_on_char '\n' (String.trim find_result.output)
|> List.filter (fun s -> s <> ""))
else 0
in
@@ -1001,25 +1160,29 @@ let run ~sw env benv ~np ~os_dir ~html_dir ~(driver_tool : Tool.t)
let unique_compilers solutions =
let seen = Hashtbl.create 4 in
- List.filter_map (fun (_target, (result : Day11_solution.Solve_result.t)) ->
- match find_compiler result.build_deps with
- | Some c when not (Hashtbl.mem seen (OpamPackage.to_string c)) ->
- Hashtbl.replace seen (OpamPackage.to_string c) ();
- Some c
- | _ -> None
- ) solutions
+ List.filter_map
+ (fun (_target, (result : Day11_solution.Solve_result.t)) ->
+ match find_compiler result.build_deps with
+ | Some c when not (Hashtbl.mem seen (OpamPackage.to_string c)) ->
+ Hashtbl.replace seen (OpamPackage.to_string c) ();
+ Some c
+ | _ -> None)
+ solutions
-(** Resolve tools (driver + per-compiler odoc). Returns the tools
- and source dirs, or None if driver solving fails. *)
+(** Resolve tools (driver + per-compiler odoc). Returns the tools and source
+ dirs, or None if driver solving fails. *)
let resolve_tools ~sw env benv ~packages ~repos ~odoc_repo ~cache
?driver_compiler ~solutions () =
- let all_pin_dirs, all_source_dirs = match odoc_repo with
+ let all_pin_dirs, all_source_dirs =
+ match odoc_repo with
| Some dir ->
- let pins = Day11_opam_build.Tools.read_pins_from_dir dir in
- let source_dirs = OpamPackage.Name.Map.fold (fun name _ acc ->
- OpamPackage.Name.Map.add name dir acc
- ) pins OpamPackage.Name.Map.empty in
- ([ dir ], source_dirs)
+ let pins = Day11_opam_build.Tools.read_pins_from_dir dir in
+ let source_dirs =
+ OpamPackage.Name.Map.fold
+ (fun name _ acc -> OpamPackage.Name.Map.add name dir acc)
+ pins OpamPackage.Name.Map.empty
+ in
+ ([ dir ], source_dirs)
| None -> ([], OpamPackage.Name.Map.empty)
in
(* The driver is just a binary — it doesn't need to match the
@@ -1030,22 +1193,28 @@ let resolve_tools ~sw env benv ~packages ~repos ~odoc_repo ~cache
let pick_latest_driver_compiler () =
let n = OpamPackage.Name.of_string "ocaml-base-compiler" in
let versions = Day11_opam.Git_packages.get_versions packages n in
- let non_avoided = OpamPackage.Version.Map.filter
- (fun _v opam -> not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam))
- versions in
- let candidates = if OpamPackage.Version.Map.is_empty non_avoided
- then versions else non_avoided in
+ let non_avoided =
+ OpamPackage.Version.Map.filter
+ (fun _v opam -> not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam))
+ versions
+ in
+ let candidates =
+ if OpamPackage.Version.Map.is_empty non_avoided then versions
+ else non_avoided
+ in
OpamPackage.Version.Map.max_binding_opt candidates
|> Option.map (fun (v, _) -> OpamPackage.create n v)
in
- let driver_compiler = match driver_compiler with
+ let driver_compiler =
+ match driver_compiler with
| Some c -> c
- | None ->
- match pick_latest_driver_compiler () with
- | Some pkg -> pkg
- | None ->
- failwith "resolve_tools: no [ocaml-base-compiler] package \
- found in the profile's opam_repositories"
+ | None -> (
+ match pick_latest_driver_compiler () with
+ | Some pkg -> pkg
+ | None ->
+ failwith
+ "resolve_tools: no [ocaml-base-compiler] package found in the \
+ profile's opam_repositories")
in
(* Pick the latest available [odoc-driver]. Same shape as
{!pick_latest_odoc} below — picks across the profile's repos so
@@ -1057,103 +1226,122 @@ let resolve_tools ~sw env benv ~packages ~repos ~odoc_repo ~cache
let pick_latest_odoc_driver () =
let n = OpamPackage.Name.of_string "odoc-driver" in
let versions = Day11_opam.Git_packages.get_versions packages n in
- let non_avoided = OpamPackage.Version.Map.filter
- (fun _v opam -> not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam))
- versions in
- let candidates = if OpamPackage.Version.Map.is_empty non_avoided
- then versions else non_avoided in
+ let non_avoided =
+ OpamPackage.Version.Map.filter
+ (fun _v opam -> not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam))
+ versions
+ in
+ let candidates =
+ if OpamPackage.Version.Map.is_empty non_avoided then versions
+ else non_avoided
+ in
OpamPackage.Version.Map.max_binding_opt candidates
|> Option.map (fun (v, _) -> OpamPackage.create n v)
in
- let driver_pkg = match pick_latest_odoc_driver () with
+ let driver_pkg =
+ match pick_latest_odoc_driver () with
| Some pkg -> pkg
| None ->
- failwith "resolve_tools: no [odoc-driver] package found in the \
- profile's opam_repositories"
+ failwith
+ "resolve_tools: no [odoc-driver] package found in the profile's \
+ opam_repositories"
in
let compiler_versions = unique_compilers solutions in
- if compiler_versions = [] then begin
+ if compiler_versions = [] then (
Printf.printf "No compiler versions found in solutions, skipping docs\n%!";
- None
- end else
- (* Pick a concrete [odoc] target. With [odoc_repo] set, we want
+ None)
+ else
+ (* Pick a concrete [odoc] target. With [odoc_repo] set, we want
[odoc.dev] from the local checkout. Otherwise pick the latest
non-avoid-version [odoc] available across the profile's
repos — gives [odoc.3.2.0+ox] when an oxcaml/local overlay is
present, and [odoc.3.1.0] for mainline-only profiles. *)
- let pick_latest_odoc () =
- let n = OpamPackage.Name.of_string "odoc" in
- let versions = Day11_opam.Git_packages.get_versions packages n in
- let non_avoided = OpamPackage.Version.Map.filter
- (fun _v opam -> not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam))
- versions in
- let candidates = if OpamPackage.Version.Map.is_empty non_avoided
- then versions else non_avoided in
- OpamPackage.Version.Map.max_binding_opt candidates
- |> Option.map (fun (v, _) -> OpamPackage.create n v)
- in
- let odoc_pkg = match odoc_repo with
- | Some _ -> OpamPackage.of_string "odoc.dev"
- | None ->
- match pick_latest_odoc () with
- | Some pkg -> pkg
- | None ->
- failwith "resolve_tools: no [odoc] package found in the \
- profile's opam_repositories"
- in
- (* All tool solves are independent — fan them out across fibers so
+ let pick_latest_odoc () =
+ let n = OpamPackage.Name.of_string "odoc" in
+ let versions = Day11_opam.Git_packages.get_versions packages n in
+ let non_avoided =
+ OpamPackage.Version.Map.filter
+ (fun _v opam ->
+ not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam))
+ versions
+ in
+ let candidates =
+ if OpamPackage.Version.Map.is_empty non_avoided then versions
+ else non_avoided
+ in
+ OpamPackage.Version.Map.max_binding_opt candidates
+ |> Option.map (fun (v, _) -> OpamPackage.create n v)
+ in
+ let odoc_pkg =
+ match odoc_repo with
+ | Some _ -> OpamPackage.of_string "odoc.dev"
+ | None -> (
+ match pick_latest_odoc () with
+ | Some pkg -> pkg
+ | None ->
+ failwith
+ "resolve_tools: no [odoc] package found in the profile's \
+ opam_repositories")
+ in
+ (* All tool solves are independent — fan them out across fibers so
they share the fork-helper-driven solver pool instead of running
sequentially. With 9+ unique compilers this turns ~18s of
wall-clock into ~3s. *)
- let tasks =
- `Driver :: List.map (fun c -> `Odoc c) compiler_versions
- in
- Printf.printf "Planning doc driver + %d odoc tools in parallel...\n%!"
- (List.length compiler_versions);
- let results =
- Eio.Fiber.List.map ~max_fibers:(List.length tasks) (function
- | `Driver ->
- let r = Day11_opam_build.Tools.plan_tool ~sw env benv
- ~packages ~repos ~doc:false ~cache
- ~ocaml_version:driver_compiler driver_pkg in
- (`Driver, r)
- | `Odoc compiler_v ->
- let r = Day11_opam_build.Tools.plan_tool ~sw env benv
- ~packages ~repos ~pin_dirs:all_pin_dirs
- ~source_dirs:all_source_dirs ~doc:false ~cache
- ~ocaml_version:compiler_v odoc_pkg in
- (`Odoc compiler_v, r)
- ) tasks
- in
- let driver_result = List.find_map (function
- | `Driver, r -> Some r | _ -> None) results in
- let odoc_tools = List.filter_map (function
- | `Odoc compiler_v, Ok ((tool : Tool.t), _) ->
- Printf.printf " %s: %d nodes\n%!"
- (OpamPackage.to_string compiler_v) (List.length tool.builds);
- Some (compiler_v, tool)
- | `Odoc compiler_v, Error (`Msg e) ->
- Printf.printf " %s: odoc solve failed: %s\n%!"
- (OpamPackage.to_string compiler_v) e;
- None
- | _ -> None) results in
- match driver_result with
- | None
- | Some (Error (`Msg _)) ->
- let msg = match driver_result with
- | Some (Error (`Msg e)) -> e | _ -> "missing" in
- Printf.printf "Doc driver solve failed: %s\n%!" msg;
- None
- | Some (Ok (driver_tool, _)) ->
- Printf.printf "Driver: %d nodes\n%!" (List.length driver_tool.builds);
- Some (driver_tool, odoc_tools, all_source_dirs)
+ let tasks = `Driver :: List.map (fun c -> `Odoc c) compiler_versions in
+ Printf.printf "Planning doc driver + %d odoc tools in parallel...\n%!"
+ (List.length compiler_versions);
+ let results =
+ Eio.Fiber.List.map ~max_fibers:(List.length tasks)
+ (function
+ | `Driver ->
+ let r =
+ Day11_opam_build.Tools.plan_tool ~sw env benv ~packages ~repos
+ ~doc:false ~cache ~ocaml_version:driver_compiler driver_pkg
+ in
+ (`Driver, r)
+ | `Odoc compiler_v ->
+ let r =
+ Day11_opam_build.Tools.plan_tool ~sw env benv ~packages ~repos
+ ~pin_dirs:all_pin_dirs ~source_dirs:all_source_dirs ~doc:false
+ ~cache ~ocaml_version:compiler_v odoc_pkg
+ in
+ (`Odoc compiler_v, r))
+ tasks
+ in
+ let driver_result =
+ List.find_map (function `Driver, r -> Some r | _ -> None) results
+ in
+ let odoc_tools =
+ List.filter_map
+ (function
+ | `Odoc compiler_v, Ok ((tool : Tool.t), _) ->
+ Printf.printf " %s: %d nodes\n%!"
+ (OpamPackage.to_string compiler_v)
+ (List.length tool.builds);
+ Some (compiler_v, tool)
+ | `Odoc compiler_v, Error (`Msg e) ->
+ Printf.printf " %s: odoc solve failed: %s\n%!"
+ (OpamPackage.to_string compiler_v)
+ e;
+ None
+ | _ -> None)
+ results
+ in
+ match driver_result with
+ | None | Some (Error (`Msg _)) ->
+ let msg =
+ match driver_result with Some (Error (`Msg e)) -> e | _ -> "missing"
+ in
+ Printf.printf "Doc driver solve failed: %s\n%!" msg;
+ None
+ | Some (Ok (driver_tool, _)) ->
+ Printf.printf "Driver: %d nodes\n%!" (List.length driver_tool.builds);
+ Some (driver_tool, odoc_tools, all_source_dirs)
-let plan_doc_dag ~sw env (ctx : Day11_batch.Profile_ctx.t)
- ~mounts ~build_one
+let plan_doc_dag ~sw env (ctx : Day11_batch.Profile_ctx.t) ~mounts ~build_one
?(on_pkg_complete = fun _ ~success:_ -> ())
- ?(on_doc_complete = fun _ ~success:_ -> ())
- ?snapshot_dir
- ~nodes ~solutions ~blessing_maps:_ () =
+ ?(on_doc_complete = fun _ ~success:_ -> ()) ?snapshot_dir ~nodes ~solutions
+ ~blessing_maps:_ () =
(* The profile's [html_dir] is the *base* for epoch dirs. Each doc run
builds into [base/epoch-<hash>/html] (hash = the doc toolchain, see
Epoch.compute); the live site is served via a [base/html-live]
@@ -1161,114 +1349,122 @@ let plan_doc_dag ~sw env (ctx : Day11_batch.Profile_ctx.t)
Docs_ci_lib.Epoch_promote). Without a per-profile base every profile
would spill HTML into the shared [<os_dir>/html], mixing oxcaml docs
with mainline. *)
- let epoch_base = match ctx.profile.html_dir with
+ let epoch_base =
+ match ctx.profile.html_dir with
| Some d -> Fpath.v d
- | None -> Fpath.(ctx.os_dir / "html") in
- match resolve_tools ~sw env ctx.benv
- ~packages:ctx.git_packages ~repos:ctx.repos_with_shas
- ~odoc_repo:ctx.profile.odoc_repo ~cache:ctx.hash_cache
- ?driver_compiler:ctx.driver_compiler ~solutions () with
+ | None -> Fpath.(ctx.os_dir / "html")
+ in
+ match
+ resolve_tools ~sw env ctx.benv ~packages:ctx.git_packages
+ ~repos:ctx.repos_with_shas ~odoc_repo:ctx.profile.odoc_repo
+ ~cache:ctx.hash_cache ?driver_compiler:ctx.driver_compiler ~solutions ()
+ with
| None -> None
| Some (driver_tool, odoc_tools, all_source_dirs) ->
- let epoch_hash =
- Day11_lib.Epoch.compute ~tool_hashes:
- ((driver_tool : Tool.t).hash
- :: List.map (fun (_, (t : Tool.t)) -> t.hash) odoc_tools)
- in
- let epoch = Day11_lib.Epoch.create ~base_dir:epoch_base epoch_hash in
- let html_dir = Fpath.(epoch.Day11_lib.Epoch.dir / "html") in
- ignore (Bos.OS.Dir.create ~path:true html_dir);
- let plan = build_internal_plan ~os_dir:ctx.os_dir
- ~driver_tool ~odoc_tools ~nodes ~solutions in
- let dispatch = make_dispatch ctx.benv ~os_dir:ctx.os_dir ~html_dir
- ~plan ~tool_source_dirs:all_source_dirs ~mounts ~build_one in
- let kind_of = node_kind_of_plan plan in
- (* Wrap [dispatch] to fire the appropriate recording callback after
+ let epoch_hash =
+ Day11_lib.Epoch.compute
+ ~tool_hashes:
+ ((driver_tool : Tool.t).hash
+ :: List.map (fun (_, (t : Tool.t)) -> t.hash) odoc_tools)
+ in
+ let epoch = Day11_lib.Epoch.create ~base_dir:epoch_base epoch_hash in
+ let html_dir = Fpath.(epoch.Day11_lib.Epoch.dir / "html") in
+ ignore (Bos.OS.Dir.create ~path:true html_dir);
+ let plan =
+ build_internal_plan ~os_dir:ctx.os_dir ~driver_tool ~odoc_tools ~nodes
+ ~solutions
+ in
+ let dispatch =
+ make_dispatch ctx.benv ~os_dir:ctx.os_dir ~html_dir ~plan
+ ~tool_source_dirs:all_source_dirs ~mounts ~build_one
+ in
+ let kind_of = node_kind_of_plan plan in
+ (* Wrap [dispatch] to fire the appropriate recording callback after
each node executes. Callbacks fire *only* for nodes that actually
ran — failed deps that prevented OCurrent from invoking
dispatch don't reach this point, which is the right semantics:
cascade attribution is derivable from the DAG, not stored. *)
- let dispatch_with_callbacks ~sw env (node : build) =
- let success = dispatch ~sw env node in
- (match kind_of node with
- | Build | Tool -> on_pkg_complete node ~success
- | Compile | Doc_all | Link -> on_doc_complete node ~success);
- success
- in
- write_dag_if_requested ~snapshot_dir plan;
- write_universes_if_requested ~snapshot_dir plan;
- Some { all_nodes = plan.all_nodes;
- node_kind = kind_of;
- build_one = dispatch_with_callbacks;
- epoch_hash; epoch_base }
+ let dispatch_with_callbacks ~sw env (node : build) =
+ let success = dispatch ~sw env node in
+ (match kind_of node with
+ | Build | Tool -> on_pkg_complete node ~success
+ | Compile | Doc_all | Link -> on_doc_complete node ~success);
+ success
+ in
+ write_dag_if_requested ~snapshot_dir plan;
+ write_universes_if_requested ~snapshot_dir plan;
+ Some
+ {
+ all_nodes = plan.all_nodes;
+ node_kind = kind_of;
+ build_one = dispatch_with_callbacks;
+ epoch_hash;
+ epoch_base;
+ }
-let build_tools_and_run ~sw env (ctx : Day11_batch.Profile_ctx.t)
- ~np ~mounts ~build_one
- ?(on_pkg_complete = fun _ ~cached:_ ~success:_ -> ())
- ?(on_doc_complete = fun _ ~cached:_ ~success:_ -> ())
- ?snapshot_dir
- ~run_log
+let build_tools_and_run ~sw env (ctx : Day11_batch.Profile_ctx.t) ~np ~mounts
+ ~build_one ?(on_pkg_complete = fun _ ~cached:_ ~success:_ -> ())
+ ?(on_doc_complete = fun _ ~cached:_ ~success:_ -> ()) ?snapshot_dir ~run_log
~nodes ~solutions ~blessing_maps:_ () =
- let html_dir = match ctx.profile.html_dir with
+ let html_dir =
+ match ctx.profile.html_dir with
| Some d -> Fpath.v d
- | None -> Fpath.(ctx.os_dir / "html") in
+ | None -> Fpath.(ctx.os_dir / "html")
+ in
ignore (Bos.OS.Dir.create ~path:true html_dir);
Printf.printf "\nPlanning doc tools...\n%!";
- match resolve_tools ~sw env ctx.benv
- ~packages:ctx.git_packages ~repos:ctx.repos_with_shas
- ~odoc_repo:ctx.profile.odoc_repo ~cache:ctx.hash_cache
- ?driver_compiler:ctx.driver_compiler ~solutions () with
+ match
+ resolve_tools ~sw env ctx.benv ~packages:ctx.git_packages
+ ~repos:ctx.repos_with_shas ~odoc_repo:ctx.profile.odoc_repo
+ ~cache:ctx.hash_cache ?driver_compiler:ctx.driver_compiler ~solutions ()
+ with
| None ->
- (* When doc tool solving fails — e.g. running against an old
+ (* When doc tool solving fails — e.g. running against an old
opam-repository commit where odoc-driver's deps can't be
satisfied — still run the build DAG so the batch produces
package outcomes. Docs are skipped, but packages get built and
recorded just as they would in a --no-doc run. *)
- Printf.printf "Tool solving failed, skipping docs; \
- running build-only DAG\n%!";
- let is_cached (node : Day11_opam_layer.Build.t) =
- let open Day11_opam_build.Dag_executor in
- let layer = Day11_opam_layer.Build.layer ~os_dir:ctx.os_dir node in
- if not (Day11_layer.Layer.exists env layer) then Not_cached
- else begin
- Day11_layer.Last_used.touch env (Day11_layer.Layer.dir layer);
- if Day11_layer.Layer.is_ok env layer then Cached_ok
- else Cached_fail
- end
- in
- Day11_opam_build.Dag_executor.execute env ~np ~is_cached
- ~on_complete:(fun ~stats ~cached node success ->
- let kind = "build" in
- let layer = Fpath.to_string
- (Day11_opam_layer.Build.dir ~os_dir:ctx.os_dir node) in
- Day11_lib.Run_log.log_build_result run_log
- ~pkg:(OpamPackage.to_string node.pkg)
- ~hash:node.hash
- ~status:(if success then "ok" else "fail")
- ~failed_dep:None ~kind ~layer_dir:layer ();
- on_pkg_complete node ~cached ~success;
- if (not cached) &&
- (stats.completed mod 100 = 0 || not success) then
- Printf.printf " [%d/%d, %d ok, %d failed, %d cascade] %s: %s\n%!"
- stats.completed stats.total stats.ok stats.failed
- stats.cascaded (OpamPackage.to_string node.pkg)
- (if success then "OK" else "FAIL"))
- ~on_cascade:(fun ~failed ~failed_dep ->
- Day11_lib.Run_log.log_build_result run_log
- ~pkg:(OpamPackage.to_string failed.pkg)
- ~hash:failed.hash ~status:"cascade"
- ~failed_dep:(Some (OpamPackage.to_string failed_dep.pkg))
- ~kind:"build" ())
- nodes build_one
+ Printf.printf
+ "Tool solving failed, skipping docs; running build-only DAG\n%!";
+ let is_cached (node : Day11_opam_layer.Build.t) =
+ let open Day11_opam_build.Dag_executor in
+ let layer = Day11_opam_layer.Build.layer ~os_dir:ctx.os_dir node in
+ if not (Day11_layer.Layer.exists env layer) then Not_cached
+ else (
+ Day11_layer.Last_used.touch env (Day11_layer.Layer.dir layer);
+ if Day11_layer.Layer.is_ok env layer then Cached_ok else Cached_fail)
+ in
+ Day11_opam_build.Dag_executor.execute env ~np ~is_cached
+ ~on_complete:(fun ~stats ~cached node success ->
+ let kind = "build" in
+ let layer =
+ Fpath.to_string (Day11_opam_layer.Build.dir ~os_dir:ctx.os_dir node)
+ in
+ Day11_lib.Run_log.log_build_result run_log
+ ~pkg:(OpamPackage.to_string node.pkg)
+ ~hash:node.hash
+ ~status:(if success then "ok" else "fail")
+ ~failed_dep:None ~kind ~layer_dir:layer ();
+ on_pkg_complete node ~cached ~success;
+ if (not cached) && (stats.completed mod 100 = 0 || not success) then
+ Printf.printf " [%d/%d, %d ok, %d failed, %d cascade] %s: %s\n%!"
+ stats.completed stats.total stats.ok stats.failed stats.cascaded
+ (OpamPackage.to_string node.pkg)
+ (if success then "OK" else "FAIL"))
+ ~on_cascade:(fun ~failed ~failed_dep ->
+ Day11_lib.Run_log.log_build_result run_log
+ ~pkg:(OpamPackage.to_string failed.pkg)
+ ~hash:failed.hash ~status:"cascade"
+ ~failed_dep:(Some (OpamPackage.to_string failed_dep.pkg))
+ ~kind:"build" ())
+ nodes build_one
| Some (driver_tool, odoc_tools, all_source_dirs) ->
- Printf.printf "Running unified build+doc DAG...\n%!";
- let doc_count, doc_html =
- run ~sw env ctx.benv ~np ~os_dir:ctx.os_dir ~html_dir
- ~driver_tool ~odoc_tools
- ~tool_source_dirs:all_source_dirs ~mounts
- ~run_log
- ~build_one ~on_pkg_complete ~on_doc_complete
- ?snapshot_dir
- ~nodes ~solutions ~blessing_maps:[] () in
- Printf.printf "\n=== Docs: %d packages, %d HTML files ===\n%!"
- doc_count doc_html
+ Printf.printf "Running unified build+doc DAG...\n%!";
+ let doc_count, doc_html =
+ run ~sw env ctx.benv ~np ~os_dir:ctx.os_dir ~html_dir ~driver_tool
+ ~odoc_tools ~tool_source_dirs:all_source_dirs ~mounts ~run_log
+ ~build_one ~on_pkg_complete ~on_doc_complete ?snapshot_dir ~nodes
+ ~solutions ~blessing_maps:[] ()
+ in
+ Printf.printf "\n=== Docs: %d packages, %d HTML files ===\n%!" doc_count
+ doc_html
File "src/web/pages.ml", line 1, characters 0-0:
diff --git a/_build/default/src/web/pages.ml b/_build/default/src/web/.formatted/pages.ml
index 330b515..6608caa 100644
--- a/_build/default/src/web/pages.ml
+++ b/_build/default/src/web/.formatted/pages.ml
@@ -1,73 +1,69 @@
(** Dashboard page resources.
- Each page is a {!Current_web.Resource.t} that reads its data
- from the on-disk {!Day11_batch}/{!Day11_lib} layout — no caching,
- no background indexing — and renders via TyXML. The site
- chrome (top nav) is added by [Context.respond_ok].
+ Each page is a {!Current_web.Resource.t} that reads its data from the
+ on-disk {!Day11_batch}/{!Day11_lib} layout — no caching, no background
+ indexing — and renders via TyXML. The site chrome (top nav) is added by
+ [Context.respond_ok].
- Wired up in {!Routes}; that module is the public entry point
- for ocaml-docs-ci to register these pages. *)
+ Wired up in {!Routes}; that module is the public entry point for
+ ocaml-docs-ci to register these pages. *)
open Tyxml.Html
module Resource = Current_web.Resource
module Context = Current_web.Context
module Profile = Day11_batch.Profile
-(** Shared per-process context. [profile_dir] is the directory that
- holds the [<name>.json] profile files; [cache_dir] is the day11
- cache root from which snapshot dirs are derived. *)
-type ctx = {
- profile_dir : Fpath.t;
- cache_dir : Fpath.t;
-}
-
-(** Memoise an expensive file read by (path, mtime). The cache is
- process-wide and never trimmed — call sites are bounded (one
- [dag.json] per snapshot, one [layer_status.jsonl] per os_dir),
- and a stale entry is just memory, never wrong data, because the
- mtime changes the cache key. *)
-let memo_by_mtime
- : type a. (Fpath.t, float * a) Hashtbl.t -> Fpath.t -> (unit -> a) -> a
- = fun cache p compute ->
+type ctx = { profile_dir : Fpath.t; cache_dir : Fpath.t }
+(** Shared per-process context. [profile_dir] is the directory that holds the
+ [<name>.json] profile files; [cache_dir] is the day11 cache root from which
+ snapshot dirs are derived. *)
+
+(** Memoise an expensive file read by (path, mtime). The cache is process-wide
+ and never trimmed — call sites are bounded (one [dag.json] per snapshot, one
+ [layer_status.jsonl] per os_dir), and a stale entry is just memory, never
+ wrong data, because the mtime changes the cache key. *)
+let memo_by_mtime : type a.
+ (Fpath.t, float * a) Hashtbl.t -> Fpath.t -> (unit -> a) -> a =
+ fun cache p compute ->
let p_s = Fpath.to_string p in
let mtime = try (Unix.stat p_s).Unix.st_mtime with _ -> 0.0 in
match Hashtbl.find_opt cache p with
| Some (m, v) when m = mtime -> v
| _ ->
- let v = compute () in
- Hashtbl.replace cache p (mtime, v);
- v
+ let v = compute () in
+ Hashtbl.replace cache p (mtime, v);
+ v
let dag_cache :
- (Fpath.t, float *
- (Day11_lib.Dag_marshal.entry list, [ `Msg of string ]) result)
- Hashtbl.t = Hashtbl.create 8
+ ( Fpath.t,
+ float * (Day11_lib.Dag_marshal.entry list, [ `Msg of string ]) result )
+ Hashtbl.t =
+ Hashtbl.create 8
let read_dag_cached snapshot_dir =
let p = Fpath.(snapshot_dir / "dag.json") in
- memo_by_mtime dag_cache p
- (fun () -> Day11_lib.Dag_marshal.read ~snapshot_dir)
+ memo_by_mtime dag_cache p (fun () -> Day11_lib.Dag_marshal.read ~snapshot_dir)
let layer_status_cache :
- (Fpath.t, float * (string, Day11_layer.Layer_status.entry) Hashtbl.t)
- Hashtbl.t = Hashtbl.create 4
+ ( Fpath.t,
+ float * (string, Day11_layer.Layer_status.entry) Hashtbl.t )
+ Hashtbl.t =
+ Hashtbl.create 4
let load_layer_status_cached os_dir =
let p = Fpath.(os_dir / "layer_status.jsonl") in
- memo_by_mtime layer_status_cache p
- (fun () -> Day11_layer.Layer_status.load ~os_dir)
+ memo_by_mtime layer_status_cache p (fun () ->
+ Day11_layer.Layer_status.load ~os_dir)
-(** [snapshots_base ctx name] is the on-disk dir holding all
- snapshots for the named profile. Mirrors
- [Day11_profile_ctx_loader.snapshots_base_for]. *)
-let snapshots_base ctx name =
- Fpath.(parent ctx.cache_dir / "snapshots" / name)
+(** [snapshots_base ctx name] is the on-disk dir holding all snapshots for the
+ named profile. Mirrors [Day11_profile_ctx_loader.snapshots_base_for]. *)
+let snapshots_base ctx name = Fpath.(parent ctx.cache_dir / "snapshots" / name)
(** Look up the OCurrent job_id for a given build_hash by querying the
- Current_cache sqlite db. Returns the most recent job_id (highest
- finished timestamp) or [None] if not cached. Accepts either the
- short (12-char) form or the full 32-char hash — we match on the
- [substr(key,1,N)] prefix for whichever length we got. *)
+ Current_cache sqlite db. Returns the most recent job_id (highest finished
+ timestamp) or [None] if not cached. Accepts either the short (12-char) form
+ or the full 32-char hash — we match on the [substr(key,1,N)] prefix for
+ whichever length we got. *)
let job_db_path = "/home/jjl25/ocaml-docs-ci-oi-sharing/var/db/sqlite.db"
let job_id_for_hash hash =
@@ -77,66 +73,75 @@ let job_id_for_hash hash =
else
try
let db = Sqlite3.db_open ~mode:`READONLY job_db_path in
- let stmt = Sqlite3.prepare db
- "SELECT job_id FROM cache \
- WHERE substr(key,1,?) = ? AND op LIKE 'day11-%' \
- ORDER BY finished DESC LIMIT 1" in
+ let stmt =
+ Sqlite3.prepare db
+ "SELECT job_id FROM cache WHERE substr(key,1,?) = ? AND op LIKE \
+ 'day11-%' ORDER BY finished DESC LIMIT 1"
+ in
let _ = Sqlite3.bind_int stmt 1 n in
let _ = Sqlite3.bind_blob stmt 2 prefix in
let result = ref None in
(match Sqlite3.step stmt with
- | Sqlite3.Rc.ROW ->
- (match Sqlite3.column stmt 0 with
+ | Sqlite3.Rc.ROW -> (
+ match Sqlite3.column stmt 0 with
| Sqlite3.Data.TEXT s -> result := Some s
| _ -> ())
- | _ -> ());
+ | _ -> ());
ignore (Sqlite3.finalize stmt);
ignore (Sqlite3.db_close db);
!result
with _ -> None
-(** Batched variant. Issues a single SELECT for the union of given
- hashes (12-char prefixes) instead of one query per hash. The
- [snapshot_detail] failures table calls this once with all the
- failed-node hashes — 100+ SQL round-trips collapse to one. *)
+(** Batched variant. Issues a single SELECT for the union of given hashes
+ (12-char prefixes) instead of one query per hash. The [snapshot_detail]
+ failures table calls this once with all the failed-node hashes — 100+ SQL
+ round-trips collapse to one. *)
let job_ids_for_hashes hashes =
let result : (string, string) Hashtbl.t = Hashtbl.create 64 in
- let prefixes = List.filter_map (fun h ->
- if String.length h = 0 then None
- else Some (String.sub h 0 (min 12 (String.length h)))) hashes in
+ let prefixes =
+ List.filter_map
+ (fun h ->
+ if String.length h = 0 then None
+ else Some (String.sub h 0 (min 12 (String.length h))))
+ hashes
+ in
match prefixes with
| [] -> result
| _ when not (Sys.file_exists job_db_path) -> result
- | _ ->
- try
- let db = Sqlite3.db_open ~mode:`READONLY job_db_path in
- let placeholders = String.concat ","
- (List.mapi (fun i _ -> Printf.sprintf "?%d" (i + 1)) prefixes) in
- let sql = Printf.sprintf
- "SELECT substr(key,1,12) AS prefix, job_id, MAX(finished) \
- FROM cache \
- WHERE substr(key,1,12) IN (%s) AND op LIKE 'day11-%%' \
- GROUP BY substr(key,1,12)"
- placeholders in
- let stmt = Sqlite3.prepare db sql in
- List.iteri (fun i p ->
- ignore (Sqlite3.bind_blob stmt (i + 1) p)) prefixes;
- let rec loop () =
- match Sqlite3.step stmt with
- | Sqlite3.Rc.ROW ->
- (match Sqlite3.column stmt 0, Sqlite3.column stmt 1 with
- | Sqlite3.Data.BLOB p, Sqlite3.Data.TEXT j
- | Sqlite3.Data.TEXT p, Sqlite3.Data.TEXT j ->
- Hashtbl.replace result p j
- | _ -> ());
- loop ()
- | _ -> ()
- in
- loop ();
- ignore (Sqlite3.finalize stmt);
- ignore (Sqlite3.db_close db);
- result
- with _ -> result
+ | _ -> (
+ try
+ let db = Sqlite3.db_open ~mode:`READONLY job_db_path in
+ let placeholders =
+ String.concat ","
+ (List.mapi (fun i _ -> Printf.sprintf "?%d" (i + 1)) prefixes)
+ in
+ let sql =
+ Printf.sprintf
+ "SELECT substr(key,1,12) AS prefix, job_id, MAX(finished) FROM \
+ cache WHERE substr(key,1,12) IN (%s) AND op LIKE 'day11-%%' GROUP \
+ BY substr(key,1,12)"
+ placeholders
+ in
+ let stmt = Sqlite3.prepare db sql in
+ List.iteri
+ (fun i p -> ignore (Sqlite3.bind_blob stmt (i + 1) p))
+ prefixes;
+ let rec loop () =
+ match Sqlite3.step stmt with
+ | Sqlite3.Rc.ROW ->
+ (match (Sqlite3.column stmt 0, Sqlite3.column stmt 1) with
+ | Sqlite3.Data.BLOB p, Sqlite3.Data.TEXT j
+ | Sqlite3.Data.TEXT p, Sqlite3.Data.TEXT j ->
+ Hashtbl.replace result p j
+ | _ -> ());
+ loop ()
+ | _ -> ()
+ in
+ loop ();
+ ignore (Sqlite3.finalize stmt);
+ ignore (Sqlite3.db_close db);
+ result
+ with _ -> result)
(** List a profile's snapshots, newest first by mtime. *)
let list_snapshots_newest_first ctx name =
@@ -144,16 +149,16 @@ let list_snapshots_newest_first ctx name =
match Bos.OS.Dir.contents base with
| Error _ -> []
| Ok entries ->
- entries
- |> List.filter_map (fun p ->
- try
- if Bos.OS.Dir.exists p |> Result.value ~default:false then
- let stat = Unix.stat (Fpath.to_string p) in
- Some (p, stat.Unix.st_mtime)
- else None
- with _ -> None)
- |> List.sort (fun (_, a) (_, b) -> compare b a)
- |> List.map fst
+ entries
+ |> List.filter_map (fun p ->
+ try
+ if Bos.OS.Dir.exists p |> Result.value ~default:false then
+ let stat = Unix.stat (Fpath.to_string p) in
+ Some (p, stat.Unix.st_mtime)
+ else None
+ with _ -> None)
+ |> List.sort (fun (_, a) (_, b) -> compare b a)
+ |> List.map fst
(** Read [packages/] under a snapshot dir. *)
let snapshot_packages snapshot_dir =
@@ -162,54 +167,53 @@ let snapshot_packages snapshot_dir =
| Error _ -> []
| Ok entries -> List.map Fpath.basename entries |> List.sort compare
-(** Latest status from [packages/<pkg>/history.jsonl] in a snapshot
- dir, or [None] if the file is missing or empty. Reads the LAST
- line of the file (the rolling history is append-only). *)
+(** Latest status from [packages/<pkg>/history.jsonl] in a snapshot dir, or
+ [None] if the file is missing or empty. Reads the LAST line of the file (the
+ rolling history is append-only). *)
let latest_pkg_status snapshot_dir pkg_str =
let h = Fpath.(snapshot_dir / "packages" / pkg_str / "history.jsonl") in
match Bos.OS.File.read_lines h with
| Error _ -> None
- | Ok lines ->
- let last = List.fold_left (fun _ l -> l) "" lines in
- if last = "" then None
- else
- try
- let json = Yojson.Safe.from_string last in
- let open Yojson.Safe.Util in
- Some (json |> member "status" |> to_string)
- with _ -> None
+ | Ok lines -> (
+ let last = List.fold_left (fun _ l -> l) "" lines in
+ if last = "" then None
+ else
+ try
+ let json = Yojson.Safe.from_string last in
+ let open Yojson.Safe.Util in
+ Some (json |> member "status" |> to_string)
+ with _ -> None)
(** Latest [(status, category, build_hash)] for a package, or [None]. *)
let latest_pkg_status_full snapshot_dir pkg_str =
let h = Fpath.(snapshot_dir / "packages" / pkg_str / "history.jsonl") in
match Bos.OS.File.read_lines h with
| Error _ -> None
- | Ok lines ->
- let last = List.fold_left (fun _ l -> l) "" lines in
- if last = "" then None
- else
- try
- let json = Yojson.Safe.from_string last in
- let open Yojson.Safe.Util in
- let status = json |> member "status" |> to_string in
- let category =
- try json |> member "category" |> to_string
- with _ -> status in
- let build_hash =
- try json |> member "build_hash" |> to_string
- with _ -> "" in
- Some (status, category, build_hash)
- with _ -> None
-
-(** Find the snapshot key chronologically just before [current_key]
- in this profile, by mtime. Returns [None] if [current_key] is the
- oldest. Used for the "Diff against previous" button on
- {!snapshot_detail}. *)
+ | Ok lines -> (
+ let last = List.fold_left (fun _ l -> l) "" lines in
+ if last = "" then None
+ else
+ try
+ let json = Yojson.Safe.from_string last in
+ let open Yojson.Safe.Util in
+ let status = json |> member "status" |> to_string in
+ let category =
+ try json |> member "category" |> to_string with _ -> status
+ in
+ let build_hash =
+ try json |> member "build_hash" |> to_string with _ -> ""
+ in
+ Some (status, category, build_hash)
+ with _ -> None)
+
+(** Find the snapshot key chronologically just before [current_key] in this
+ profile, by mtime. Returns [None] if [current_key] is the oldest. Used for
+ the "Diff against previous" button on {!snapshot_detail}. *)
let find_previous_snapshot_key ctx name current_key =
let snaps = list_snapshots_newest_first ctx name in
let keys = List.map Fpath.basename snaps in
let rec walk = function
- | [] | [_] -> None
+ | [] | [ _ ] -> None
| k :: next :: _ when k = current_key -> Some next
| _ :: rest -> walk rest
in
@@ -222,34 +226,49 @@ let profiles_index ~ctx =
inherit Resource.t
val! can_get = `Viewer
method! nav_link = Some "Profiles"
+
method! private get web_ctx =
let names = Profile.list ~dir:ctx.profile_dir in
let row name =
let snaps = list_snapshots_newest_first ctx name in
let snap_count = List.length snaps in
- let latest = match snaps with
+ let latest =
+ match snaps with
| [] -> txt "—"
| s :: _ ->
- let key = Fpath.basename s in
- a ~a:[ a_href (Printf.sprintf "/profiles/%s/snapshots/%s"
- name key) ]
- [ Templates.sha_span key ]
+ let key = Fpath.basename s in
+ a
+ ~a:
+ [
+ a_href (Printf.sprintf "/profiles/%s/snapshots/%s" name key);
+ ]
+ [ Templates.sha_span key ]
in
- tr [
- td [ a ~a:[ a_href ("/profiles/" ^ name) ] [ txt name ] ];
- td [ txt (string_of_int snap_count) ];
- td [ latest ];
- ]
+ tr
+ [
+ td [ a ~a:[ a_href ("/profiles/" ^ name) ] [ txt name ] ];
+ td [ txt (string_of_int snap_count) ];
+ td [ latest ];
+ ]
in
- Context.respond_ok web_ctx [
- Templates.style_block;
- h2 [ txt "Profiles" ];
- table ~a:[ a_class [ "data" ] ]
- ~thead:(thead [ tr [ th [ txt "Name" ];
- th [ txt "Snapshots" ];
- th [ txt "Latest" ] ] ])
- (List.map row names)
- ]
+ Context.respond_ok web_ctx
+ [
+ Templates.style_block;
+ h2 [ txt "Profiles" ];
+ table
+ ~a:[ a_class [ "data" ] ]
+ ~thead:
+ (thead
+ [
+ tr
+ [
+ th [ txt "Name" ];
+ th [ txt "Snapshots" ];
+ th [ txt "Latest" ];
+ ];
+ ])
+ (List.map row names);
+ ]
end
(* ── /profiles/<name> ─────────────────────────────────────────── *)
@@ -258,29 +277,41 @@ let profile_dashboard ~ctx name =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
let snaps = list_snapshots_newest_first ctx name in
- let crumbs = Templates.breadcrumbs [
- Some "/profiles", "Profiles"; None, name
- ] in
- let body = match snaps with
+ let crumbs =
+ Templates.breadcrumbs [ (Some "/profiles", "Profiles"); (None, name) ]
+ in
+ let body =
+ match snaps with
| [] -> [ p [ txt "No snapshots yet for this profile." ] ]
| s :: _ ->
- let key = Fpath.basename s in
- let snapshot_link =
- a ~a:[ a_href (Printf.sprintf "/profiles/%s/snapshots/%s"
- name key) ]
- [ txt key ] in
- let snapshots_link =
- a ~a:[ a_href (Printf.sprintf "/profiles/%s/snapshots" name) ]
- [ txt (Printf.sprintf "All snapshots (%d)"
- (List.length snaps)) ] in
- let recent_link =
- a ~a:[ a_href (Printf.sprintf "/profiles/%s/recent" name) ]
- [ txt "Recent changes" ] in
- [ p [ txt "Latest snapshot: "; snapshot_link ];
- ul [ li [ recent_link ];
- li [ snapshots_link ] ] ]
+ let key = Fpath.basename s in
+ let snapshot_link =
+ a
+ ~a:
+ [
+ a_href (Printf.sprintf "/profiles/%s/snapshots/%s" name key);
+ ]
+ [ txt key ]
+ in
+ let snapshots_link =
+ a
+ ~a:[ a_href (Printf.sprintf "/profiles/%s/snapshots" name) ]
+ [
+ txt (Printf.sprintf "All snapshots (%d)" (List.length snaps));
+ ]
+ in
+ let recent_link =
+ a
+ ~a:[ a_href (Printf.sprintf "/profiles/%s/recent" name) ]
+ [ txt "Recent changes" ]
+ in
+ [
+ p [ txt "Latest snapshot: "; snapshot_link ];
+ ul [ li [ recent_link ]; li [ snapshots_link ] ];
+ ]
in
Context.respond_ok web_ctx
([ Templates.style_block; crumbs; h2 [ txt name ] ] @ body)
@@ -294,12 +325,13 @@ let snapshots_list ~ctx name =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
let req = Context.request web_ctx in
let uri = Cohttp.Request.uri req in
let page =
match Uri.get_query_param uri "page" with
- | Some s -> (try max 1 (int_of_string s) with _ -> 1)
+ | Some s -> ( try max 1 (int_of_string s) with _ -> 1)
| None -> 1
in
let snaps = list_snapshots_newest_first ctx name in
@@ -307,57 +339,83 @@ let snapshots_list ~ctx name =
let n_pages = max 1 ((total + page_size - 1) / page_size) in
let page = min page n_pages in
let start = (page - 1) * page_size in
- let visible = snaps
- |> List.filteri (fun i _ -> i >= start && i < start + page_size) in
+ let visible =
+ snaps |> List.filteri (fun i _ -> i >= start && i < start + page_size)
+ in
let row dir =
let key = Fpath.basename dir in
let mtime =
try
let s = Unix.stat (Fpath.to_string dir) in
let tm = Unix.gmtime s.st_mtime in
- Printf.sprintf "%04d-%02d-%02d %02d:%02d"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min
+ Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.tm_year + 1900)
+ (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min
with _ -> "—"
in
- tr [
- td [ a ~a:[ a_href (Printf.sprintf "/profiles/%s/snapshots/%s"
- name key) ]
- [ Templates.sha_span key ] ];
- td [ txt mtime ];
- ]
+ tr
+ [
+ td
+ [
+ a
+ ~a:
+ [
+ a_href
+ (Printf.sprintf "/profiles/%s/snapshots/%s" name key);
+ ]
+ [ Templates.sha_span key ];
+ ];
+ td [ txt mtime ];
+ ]
in
let pager =
if n_pages <= 1 then []
else
let link p label =
- a ~a:[ a_href (Printf.sprintf
- "/profiles/%s/snapshots?page=%d" name p) ]
+ a
+ ~a:
+ [
+ a_href
+ (Printf.sprintf "/profiles/%s/snapshots?page=%d" name p);
+ ]
[ txt label ]
in
- [ div ~a:[ a_class [ "pager" ] ]
- (List.concat [
- (if page > 1 then [ link (page - 1) "‹ Prev"; txt " " ]
- else []);
- [ txt (Printf.sprintf "Page %d of %d (%d snapshots)"
- page n_pages total) ];
- (if page < n_pages then [ txt " "; link (page + 1) "Next ›" ]
- else []);
- ]) ]
+ [
+ div
+ ~a:[ a_class [ "pager" ] ]
+ (List.concat
+ [
+ (if page > 1 then [ link (page - 1) "‹ Prev"; txt " " ]
+ else []);
+ [
+ txt
+ (Printf.sprintf "Page %d of %d (%d snapshots)" page
+ n_pages total);
+ ];
+ (if page < n_pages then [ txt " "; link (page + 1) "Next ›" ]
+ else []);
+ ]);
+ ]
+ in
+ let crumbs =
+ Templates.breadcrumbs
+ [
+ (Some "/profiles", "Profiles");
+ (Some ("/profiles/" ^ name), name);
+ (None, "Snapshots");
+ ]
in
- let crumbs = Templates.breadcrumbs [
- Some "/profiles", "Profiles";
- Some ("/profiles/" ^ name), name;
- None, "Snapshots";
- ] in
Context.respond_ok web_ctx
- ([ Templates.style_block; crumbs;
+ ([
+ Templates.style_block;
+ crumbs;
h2 [ txt (name ^ " — snapshots") ];
- table ~a:[ a_class [ "data" ] ]
- ~thead:(thead [ tr [ th [ txt "Key" ];
- th [ txt "Created (UTC)" ] ] ])
- (List.map row visible) ]
- @ pager)
+ table
+ ~a:[ a_class [ "data" ] ]
+ ~thead:
+ (thead [ tr [ th [ txt "Key" ]; th [ txt "Created (UTC)" ] ] ])
+ (List.map row visible);
+ ]
+ @ pager)
end
(* ── /profiles/<name>/snapshots/<key> ─────────────────────────── *)
@@ -366,6 +424,7 @@ let snapshot_detail ~ctx name key =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
let _t0 = Unix.gettimeofday () in
let timing label fn =
@@ -376,38 +435,45 @@ let snapshot_detail ~ctx name key =
r
in
let snapshot_dir = Fpath.(snapshots_base ctx name / key) in
- let crumbs = Templates.breadcrumbs [
- Some "/profiles", "Profiles";
- Some ("/profiles/" ^ name), name;
- Some (Printf.sprintf "/profiles/%s/snapshots" name), "Snapshots";
- None, key;
- ] in
+ let crumbs =
+ Templates.breadcrumbs
+ [
+ (Some "/profiles", "Profiles");
+ (Some ("/profiles/" ^ name), name);
+ (Some (Printf.sprintf "/profiles/%s/snapshots" name), "Snapshots");
+ (None, key);
+ ]
+ in
let repos_json =
match Bos.OS.File.read Fpath.(snapshot_dir / "repos.json") with
| Error _ -> None
- | Ok s -> (try Some (Yojson.Safe.from_string s) with _ -> None)
+ | Ok s -> ( try Some (Yojson.Safe.from_string s) with _ -> None)
in
- let repos = match repos_json with
+ let repos =
+ match repos_json with
| None -> []
- | Some json ->
- (try
- let open Yojson.Safe.Util in
- json |> member "repos" |> to_list
- |> List.map (fun r ->
- let path = r |> member "path" |> to_string in
- let commit = r |> member "commit" |> to_string in
- (path, commit))
- with _ -> [])
+ | Some json -> (
+ try
+ let open Yojson.Safe.Util in
+ json
+ |> member "repos"
+ |> to_list
+ |> List.map (fun r ->
+ let path = r |> member "path" |> to_string in
+ let commit = r |> member "commit" |> to_string in
+ (path, commit))
+ with _ -> [])
in
(* The ISO-8601 timestamp of when this snapshot was first seen,
written by [Snapshot.save]. Surfaced in the page header. *)
- let created = match repos_json with
+ let created =
+ match repos_json with
| None -> None
- | Some json ->
- (match Yojson.Safe.Util.member "created" json with
- | `String s -> Some s
- | _ -> None
- | exception _ -> None)
+ | Some json -> (
+ match Yojson.Safe.Util.member "created" json with
+ | `String s -> Some s
+ | _ -> None
+ | exception _ -> None)
in
(* Read the live HEAD of [path] (a local git repo). Returns
[None] if [path] isn't a git repo or the read fails — non-git
@@ -415,13 +481,15 @@ let snapshot_detail ~ctx name key =
blank. Captures stderr alongside stdout so a transient
"fatal: ambiguous argument" doesn't pollute the page. *)
let read_live_head path =
- let cmd = Printf.sprintf
- "git -C %s rev-parse HEAD 2>/dev/null"
- (Filename.quote path) in
+ let cmd =
+ Printf.sprintf "git -C %s rev-parse HEAD 2>/dev/null"
+ (Filename.quote path)
+ in
try
let ic = Unix.open_process_in cmd in
- let line = try Some (String.trim (input_line ic))
- with End_of_file -> None in
+ let line =
+ try Some (String.trim (input_line ic)) with End_of_file -> None
+ in
let _ = Unix.close_process_in ic in
match line with
| Some s when String.length s = 40 -> Some s
@@ -431,15 +499,17 @@ let snapshot_detail ~ctx name key =
(* Subject line of [commit] in the git repo at [path]. Returns
[None] if the commit isn't present locally or the read fails. *)
let read_commit_subject path commit =
- let cmd = Printf.sprintf
- "git -C %s log -1 --format=%%s %s 2>/dev/null"
- (Filename.quote path) (Filename.quote commit) in
+ let cmd =
+ Printf.sprintf "git -C %s log -1 --format=%%s %s 2>/dev/null"
+ (Filename.quote path) (Filename.quote commit)
+ in
try
let ic = Unix.open_process_in cmd in
- let line = try Some (String.trim (input_line ic))
- with End_of_file -> None in
+ let line =
+ try Some (String.trim (input_line ic)) with End_of_file -> None
+ in
let _ = Unix.close_process_in ic in
- (match line with Some "" -> None | l -> l)
+ match line with Some "" -> None | l -> l
with _ -> None
in
(* For a github-pin-overlay path of the form ".../overlays/<n>/repo",
@@ -450,469 +520,729 @@ let snapshot_detail ~ctx name key =
let upstream_head_for path =
let suffix = "/repo" in
if Astring.String.is_suffix ~affix:suffix path then
- let base = String.sub path 0 (String.length path - String.length suffix) in
+ let base =
+ String.sub path 0 (String.length path - String.length suffix)
+ in
let upstream = base ^ "/upstream" in
- if Sys.file_exists upstream
- then Option.map (fun h -> (upstream, h)) (read_live_head upstream)
+ if Sys.file_exists upstream then
+ Option.map (fun h -> (upstream, h)) (read_live_head upstream)
else None
else None
in
- let repos_table = match repos with
+ let repos_table =
+ match repos with
| [] -> p [ em [ txt "No repos.json on disk." ] ]
| _ ->
- let row (p, c) =
- let live = read_live_head p in
- let live_cell = match live with
- | None -> em [ txt "—" ]
- | Some h when h = c -> Templates.sha_span h
- | Some h -> span ~a:[ a_class [ "warn" ] ]
- [ Templates.sha_span h ]
- in
- let msg_cell = match read_commit_subject p c with
- | Some m -> td [ txt m ]
- | None -> td [ em [ txt "—" ] ]
- in
- let upstream_rows = match upstream_head_for p with
- | None -> []
- | Some (upath, uhead) ->
- [ tr [ td [ code [ txt (upath ^ " (upstream)") ] ];
- td [ em [ txt "—" ] ];
- td [ em [ txt "—" ] ];
- td [ Templates.sha_span uhead ] ] ]
+ let row (p, c) =
+ let live = read_live_head p in
+ let live_cell =
+ match live with
+ | None -> em [ txt "—" ]
+ | Some h when h = c -> Templates.sha_span h
+ | Some h ->
+ span ~a:[ a_class [ "warn" ] ] [ Templates.sha_span h ]
+ in
+ let msg_cell =
+ match read_commit_subject p c with
+ | Some m -> td [ txt m ]
+ | None -> td [ em [ txt "—" ] ]
+ in
+ let upstream_rows =
+ match upstream_head_for p with
+ | None -> []
+ | Some (upath, uhead) ->
+ [
+ tr
+ [
+ td [ code [ txt (upath ^ " (upstream)") ] ];
+ td [ em [ txt "—" ] ];
+ td [ em [ txt "—" ] ];
+ td [ Templates.sha_span uhead ];
+ ];
+ ]
+ in
+ tr
+ [
+ td [ code [ txt p ] ];
+ td [ Templates.sha_span c ];
+ msg_cell;
+ td [ live_cell ];
+ ]
+ :: upstream_rows
in
- tr [ td [ code [ txt p ] ];
- td [ Templates.sha_span c ];
- msg_cell;
- td [ live_cell ] ] :: upstream_rows
- in
- table ~a:[ a_class [ "data" ] ]
- ~thead:(thead [ tr [ th [ txt "Repo" ];
- th [ txt "Snapshot" ];
- th [ txt "Message" ];
- th [ txt "Latest" ] ] ])
- (List.concat_map row repos)
+ table
+ ~a:[ a_class [ "data" ] ]
+ ~thead:
+ (thead
+ [
+ tr
+ [
+ th [ txt "Repo" ];
+ th [ txt "Snapshot" ];
+ th [ txt "Message" ];
+ th [ txt "Latest" ];
+ ];
+ ])
+ (List.concat_map row repos)
in
let totals =
match Day11_lib.Status_index.read ~dir:snapshot_dir with
- | None -> [ p [ em [ txt "Status not yet generated for \
- this snapshot — run is in \
- progress or pre-finish." ] ] ]
+ | None ->
+ [
+ p
+ [
+ em
+ [
+ txt
+ "Status not yet generated for this snapshot — run is \
+ in progress or pre-finish.";
+ ];
+ ];
+ ]
| Some st ->
- let is_doc_cat c =
- c = "doc_success" || c = "doc_failure"
- in
- let partition rows =
- List.partition (fun (c, _) -> is_doc_cat c) rows
- in
- let build_blessed = snd (partition st.blessed_totals) in
- let doc_blessed = fst (partition st.blessed_totals) in
- let build_nonblessed = snd (partition st.non_blessed_totals) in
- let doc_nonblessed = fst (partition st.non_blessed_totals) in
- let breakdown_row label rows =
- let parts = List.map
- (fun (cat, n) -> Printf.sprintf "%s=%d" cat n) rows in
- let total = List.fold_left (fun acc (_, n) -> acc + n) 0 rows in
- let txt_str = match parts with
- | [] -> "0"
- | _ -> Printf.sprintf "%d (%s)" total
- (String.concat ", " parts) in
- tr [ th [ txt label ]; td [ txt txt_str ] ]
- in
- [ table ~a:[ a_class [ "data" ] ]
- [ breakdown_row "Blessed builds" build_blessed;
- breakdown_row "Non-blessed builds" build_nonblessed;
- breakdown_row "Blessed docs" doc_blessed;
- breakdown_row "Non-blessed docs" doc_nonblessed ];
- p ~a:[ a_class [ "crumbs" ] ]
- [ em [ txt "Builds count compiled package layers; docs \
- count successful compile+link (or doc-all) \
- stages. Counts are per build_hash (a package \
- solved in N universes counts as N). 'Blessed' \
- means the entry is the chosen primary \
- universe per package AND the entry was \
- written in the current run — i.e. it's still \
- live. Older blessed entries superseded by a \
- re-solve count as non-blessed." ] ] ]
+ let is_doc_cat c = c = "doc_success" || c = "doc_failure" in
+ let partition rows =
+ List.partition (fun (c, _) -> is_doc_cat c) rows
+ in
+ let build_blessed = snd (partition st.blessed_totals) in
+ let doc_blessed = fst (partition st.blessed_totals) in
+ let build_nonblessed = snd (partition st.non_blessed_totals) in
+ let doc_nonblessed = fst (partition st.non_blessed_totals) in
+ let breakdown_row label rows =
+ let parts =
+ List.map (fun (cat, n) -> Printf.sprintf "%s=%d" cat n) rows
+ in
+ let total = List.fold_left (fun acc (_, n) -> acc + n) 0 rows in
+ let txt_str =
+ match parts with
+ | [] -> "0"
+ | _ -> Printf.sprintf "%d (%s)" total (String.concat ", " parts)
+ in
+ tr [ th [ txt label ]; td [ txt txt_str ] ]
+ in
+ [
+ table
+ ~a:[ a_class [ "data" ] ]
+ [
+ breakdown_row "Blessed builds" build_blessed;
+ breakdown_row "Non-blessed builds" build_nonblessed;
+ breakdown_row "Blessed docs" doc_blessed;
+ breakdown_row "Non-blessed docs" doc_nonblessed;
+ ];
+ p
+ ~a:[ a_class [ "crumbs" ] ]
+ [
+ em
+ [
+ txt
+ "Builds count compiled package layers; docs count \
+ successful compile+link (or doc-all) stages. Counts \
+ are per build_hash (a package solved in N universes \
+ counts as N). 'Blessed' means the entry is the chosen \
+ primary universe per package AND the entry was \
+ written in the current run — i.e. it's still live. \
+ Older blessed entries superseded by a re-solve count \
+ as non-blessed.";
+ ];
+ ];
+ ]
in
let pkgs = snapshot_packages snapshot_dir in
let pkg_link p =
match String.index_opt p '.' with
| None ->
- a ~a:[ a_href (Printf.sprintf "/profiles/%s/p/%s" name p) ]
- [ txt p ]
+ a
+ ~a:[ a_href (Printf.sprintf "/profiles/%s/p/%s" name p) ]
+ [ txt p ]
| Some i ->
- let n = String.sub p 0 i in
- let v = String.sub p (i + 1) (String.length p - i - 1) in
- a ~a:[ a_href (Printf.sprintf "/profiles/%s/p/%s/%s" name n v) ]
- [ txt p ]
+ let n = String.sub p 0 i in
+ let v = String.sub p (i + 1) (String.length p - i - 1) in
+ a
+ ~a:[ a_href (Printf.sprintf "/profiles/%s/p/%s/%s" name n v) ]
+ [ txt p ]
in
(* pkg_table is rendered after [dag_data] is available so we
can list every package from dag.json (not just those with
per-snapshot history). See further down. *)
let _ = pkgs in
- let diff_link = match find_previous_snapshot_key ctx name key with
+ let diff_link =
+ match find_previous_snapshot_key ctx name key with
| None -> []
| Some prev ->
- [ p [ a ~a:[ a_href (Printf.sprintf
- "/profiles/%s/snapshots/%s/diff/%s"
- name prev key) ]
- [ txt "Diff against previous snapshot ("
- ; Templates.sha_span prev
- ; txt ")" ] ] ]
+ [
+ p
+ [
+ a
+ ~a:
+ [
+ a_href
+ (Printf.sprintf "/profiles/%s/snapshots/%s/diff/%s"
+ name prev key);
+ ]
+ [
+ txt "Diff against previous snapshot (";
+ Templates.sha_span prev;
+ txt ")";
+ ];
+ ];
+ ]
in
let kind_label : Day11_lib.Dag_marshal.kind -> string = function
- | Build -> "build" | Tool -> "tool" | Compile -> "compile"
- | Doc_all -> "doc-all" | Link -> "link"
...TRUNCATED BY DUNE...
| ("failure" | "cascade") when hash <> "" ->
- let target = match job_id_for_hash hash with
- | Some job_id -> "/job/" ^ job_id
- | None ->
- Printf.sprintf "/profiles/%s/builds/%s/log" profile_name hash
- in
- a ~a:[ a_href target ] [ span ]
+ let target =
+ match job_id_for_hash hash with
+ | Some job_id -> "/job/" ^ job_id
+ | None ->
+ Printf.sprintf "/profiles/%s/builds/%s/log" profile_name hash
+ in
+ a ~a:[ a_href target ] [ span ]
| _ -> span
in
match change with
| Added (v, sn, hn) ->
- tr [ td [ pkg_link ]; td [ ver_link v ];
- td [ status_cell ~version:v sn hn ];
- td [ em [ txt "added" ] ] ]
+ tr
+ [
+ td [ pkg_link ];
+ td [ ver_link v ];
+ td [ status_cell ~version:v sn hn ];
+ td [ em [ txt "added" ] ];
+ ]
| Removed v ->
- tr [ td [ pkg_link ]; td [ txt v ];
- td []; td [ em [ txt "removed" ] ] ]
+ tr [ td [ pkg_link ]; td [ txt v ]; td []; td [ em [ txt "removed" ] ] ]
| Status_changed (v, so, sn, hn) ->
- tr [ td [ pkg_link ]; td [ ver_link v ];
- td [ Templates.status_span so; txt " → ";
- status_cell ~version:v sn hn ];
- td [ em [ txt "status changed" ] ] ]
+ tr
+ [
+ td [ pkg_link ];
+ td [ ver_link v ];
+ td
+ [
+ Templates.status_span so; txt " → "; status_cell ~version:v sn hn;
+ ];
+ td [ em [ txt "status changed" ] ];
+ ]
| Version_changed (v_old, v_new, s_new, h_new) ->
- tr [ td [ pkg_link ];
- td [ ver_link v_old; txt " → "; ver_link v_new ];
- td [ status_cell ~version:v_new s_new h_new ];
- td [ em [ txt "version changed" ] ] ]
+ tr
+ [
+ td [ pkg_link ];
+ td [ ver_link v_old; txt " → "; ver_link v_new ];
+ td [ status_cell ~version:v_new s_new h_new ];
+ td [ em [ txt "version changed" ] ];
+ ]
let diff_table_thead =
- thead [ tr [ th [ txt "Package" ];
- th [ txt "Version" ];
- th [ txt "Status" ];
- th [ txt "Change" ] ] ]
+ thead
+ [
+ tr
+ [
+ th [ txt "Package" ];
+ th [ txt "Version" ];
+ th [ txt "Status" ];
+ th [ txt "Change" ];
+ ];
+ ]
(* ── /profiles/<name>/snapshots/<key>/diff/<other> ────────────── *)
@@ -1315,13 +1696,15 @@ let diff_table_thead =
incomplete-snapshot banner so the reader knows which snapshot is
still settling. *)
let pending_pkg_names pkgs =
- List.fold_left (fun acc ((n, _), (st, _)) ->
- if st = "pending" then n :: acc else acc) [] pkgs
+ List.fold_left
+ (fun acc ((n, _), (st, _)) -> if st = "pending" then n :: acc else acc)
+ [] pkgs
let snapshot_diff ~ctx name key_old key_new =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
let dir_old = Fpath.(snapshots_base ctx name / key_old) in
let dir_new = Fpath.(snapshots_base ctx name / key_new) in
@@ -1331,8 +1714,7 @@ let snapshot_diff ~ctx name key_old key_new =
let m_old_raw = load dir_old and m_new_raw = load dir_new in
let p_old = pending_pkg_names m_old_raw
and p_new = pending_pkg_names m_new_raw in
- let pending_old = List.length p_old
- and pending_new = List.length p_new in
+ let pending_old = List.length p_old and pending_new = List.length p_new in
let drop =
let t = Hashtbl.create (pending_old + pending_new) in
List.iter (fun n -> Hashtbl.replace t n ()) p_old;
@@ -1342,43 +1724,67 @@ let snapshot_diff ~ctx name key_old key_new =
let strip = List.filter (fun ((n, _), _) -> not (Hashtbl.mem drop n)) in
let m_old = strip m_old_raw and m_new = strip m_new_raw in
let changes = compute_diff_changes m_old m_new in
- let crumbs = Templates.breadcrumbs [
- Some "/profiles", "Profiles";
- Some ("/profiles/" ^ name), name;
- Some (Printf.sprintf "/profiles/%s/snapshots" name), "Snapshots";
- Some (Printf.sprintf "/profiles/%s/snapshots/%s" name key_old),
- Templates.short_sha key_old;
- None, "diff " ^ Templates.short_sha key_new;
- ] in
+ let crumbs =
+ Templates.breadcrumbs
+ [
+ (Some "/profiles", "Profiles");
+ (Some ("/profiles/" ^ name), name);
+ (Some (Printf.sprintf "/profiles/%s/snapshots" name), "Snapshots");
+ ( Some (Printf.sprintf "/profiles/%s/snapshots/%s" name key_old),
+ Templates.short_sha key_old );
+ (None, "diff " ^ Templates.short_sha key_new);
+ ]
+ in
let incomplete_notice =
let mk label key n =
- Printf.sprintf "%s snapshot %s is incomplete: %d package%s still pending"
- label (Templates.short_sha key) n (if n = 1 then "" else "s")
+ Printf.sprintf
+ "%s snapshot %s is incomplete: %d package%s still pending" label
+ (Templates.short_sha key) n
+ (if n = 1 then "" else "s")
in
- match pending_old, pending_new with
+ match (pending_old, pending_new) with
| 0, 0 -> []
- | _, 0 -> [ p ~a:[ a_class [ "warn" ] ]
- [ txt (mk "Old" key_old pending_old) ] ]
- | 0, _ -> [ p ~a:[ a_class [ "warn" ] ]
- [ txt (mk "New" key_new pending_new) ] ]
+ | _, 0 ->
+ [
+ p ~a:[ a_class [ "warn" ] ] [ txt (mk "Old" key_old pending_old) ];
+ ]
+ | 0, _ ->
+ [
+ p ~a:[ a_class [ "warn" ] ] [ txt (mk "New" key_new pending_new) ];
+ ]
| _, _ ->
- [ p ~a:[ a_class [ "warn" ] ]
- [ txt (mk "Old" key_old pending_old) ];
- p ~a:[ a_class [ "warn" ] ]
- [ txt (mk "New" key_new pending_new) ] ]
+ [
+ p ~a:[ a_class [ "warn" ] ] [ txt (mk "Old" key_old pending_old) ];
+ p ~a:[ a_class [ "warn" ] ] [ txt (mk "New" key_new pending_new) ];
+ ]
in
let body =
if changes = [] then [ p [ em [ txt "No differences." ] ] ]
- else [ table ~a:[ a_class [ "data" ] ]
- ~thead:diff_table_thead
- (List.map (render_change_row ~profile_name:name ~html_dir) changes) ]
+ else
+ [
+ table
+ ~a:[ a_class [ "data" ] ]
+ ~thead:diff_table_thead
+ (List.map
+ (render_change_row ~profile_name:name ~html_dir)
+ changes);
+ ]
in
- Context.respond_ok web_ctx ([
- Templates.style_block; crumbs;
- h2 [ txt (Printf.sprintf "%s — diff" name) ];
- p [ txt "From "; Templates.sha_span key_old;
- txt " to "; Templates.sha_span key_new ];
- ] @ incomplete_notice @ body)
+ Context.respond_ok web_ctx
+ ([
+ Templates.style_block;
+ crumbs;
+ h2 [ txt (Printf.sprintf "%s — diff" name) ];
+ p
+ [
+ txt "From ";
+ Templates.sha_span key_old;
+ txt " to ";
+ Templates.sha_span key_new;
+ ];
+ ]
+ @ incomplete_notice
+ @ body)
end
(* ── /profiles/<name>/recent[?n=K&page=N&status=fail|change] ──── *)
@@ -1392,18 +1798,19 @@ let recent_changes ~ctx name =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
let req = Context.request web_ctx in
let uri = Cohttp.Request.uri req in
let n =
match Uri.get_query_param uri "n" with
- | Some s -> (try max 1 (min 200 (int_of_string s))
- with _ -> recent_default_n)
+ | Some s -> (
+ try max 1 (min 200 (int_of_string s)) with _ -> recent_default_n)
| None -> recent_default_n
in
let page =
match Uri.get_query_param uri "page" with
- | Some s -> (try max 1 (int_of_string s) with _ -> 1)
+ | Some s -> ( try max 1 (int_of_string s) with _ -> 1)
| None -> 1
in
let status_filter =
@@ -1421,8 +1828,7 @@ let recent_changes ~ctx name =
the older end of the last pair). *)
let visible_snaps =
snaps
- |> List.filteri (fun i _ ->
- i >= start_pair && i <= start_pair + n)
+ |> List.filteri (fun i _ -> i >= start_pair && i <= start_pair + n)
in
let os_dir = os_dir_for ~ctx name in
let html_dir = html_dir_for ~ctx name in
@@ -1431,9 +1837,8 @@ let recent_changes ~ctx name =
try
let s = Unix.stat (Fpath.to_string dir) in
let tm = Unix.gmtime s.st_mtime in
- Printf.sprintf "%04d-%02d-%02d %02d:%02d UTC"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min
+ Printf.sprintf "%04d-%02d-%02d %02d:%02d UTC" (tm.tm_year + 1900)
+ (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min
with _ -> "—"
in
(* Walk visible snapshots newest-to-oldest. Each adjacent
@@ -1441,93 +1846,136 @@ let recent_changes ~ctx name =
no changes after filtering are skipped entirely. *)
let rec pairs acc = function
| dir_new :: (dir_old :: _ as rest) ->
- pairs ((dir_new, dir_old) :: acc) rest
+ pairs ((dir_new, dir_old) :: acc) rest
| _ -> List.rev acc
in
let sections =
pairs [] visible_snaps
|> List.filter_map (fun (dir_new, dir_old) ->
- let changes = compute_diff_changes (load dir_old) (load dir_new) in
- let changes = match status_filter with
- | `Change -> changes
- | `Fail -> List.filter (fun (_, c) -> is_change_failure c) changes
- in
- if changes = [] then None
- else
- let key_new = Fpath.basename dir_new in
- let key_old = Fpath.basename dir_old in
- let header =
- h3 [
- a ~a:[ a_href (Printf.sprintf
- "/profiles/%s/snapshots/%s" name key_new) ]
- [ Templates.sha_span key_new ];
- txt (" — " ^ mtime_str dir_new ^ " ");
- a ~a:[ a_href (Printf.sprintf
- "/profiles/%s/snapshots/%s/diff/%s"
- name key_old key_new) ]
- [ txt "(full diff)" ];
- ]
- in
- let table_el =
- table ~a:[ a_class [ "data" ] ]
- ~thead:diff_table_thead
- (List.map (render_change_row ~profile_name:name ~html_dir) changes)
- in
- Some [ header; table_el ])
+ let changes =
+ compute_diff_changes (load dir_old) (load dir_new)
+ in
+ let changes =
+ match status_filter with
+ | `Change -> changes
+ | `Fail ->
+ List.filter (fun (_, c) -> is_change_failure c) changes
+ in
+ if changes = [] then None
+ else
+ let key_new = Fpath.basename dir_new in
+ let key_old = Fpath.basename dir_old in
+ let header =
+ h3
+ [
+ a
+ ~a:
+ [
+ a_href
+ (Printf.sprintf "/profiles/%s/snapshots/%s" name
+ key_new);
+ ]
+ [ Templates.sha_span key_new ];
+ txt (" — " ^ mtime_str dir_new ^ " ");
+ a
+ ~a:
+ [
+ a_href
+ (Printf.sprintf
+ "/profiles/%s/snapshots/%s/diff/%s" name
+ key_old key_new);
+ ]
+ [ txt "(full diff)" ];
+ ]
+ in
+ let table_el =
+ table
+ ~a:[ a_class [ "data" ] ]
+ ~thead:diff_table_thead
+ (List.map
+ (render_change_row ~profile_name:name ~html_dir)
+ changes)
+ in
+ Some [ header; table_el ])
|> List.concat
in
- let crumbs = Templates.breadcrumbs [
- Some "/profiles", "Profiles";
- Some ("/profiles/" ^ name), name;
- None, "Recent changes";
- ] in
+ let crumbs =
+ Templates.breadcrumbs
+ [
+ (Some "/profiles", "Profiles");
+ (Some ("/profiles/" ^ name), name);
+ (None, "Recent changes");
+ ]
+ in
let filter_link ?(label = "") which =
- let href = Printf.sprintf "/profiles/%s/recent?n=%d&status=%s"
- name n which in
+ let href =
+ Printf.sprintf "/profiles/%s/recent?n=%d&status=%s" name n which
+ in
let lbl = if label = "" then which else label in
- if (which = "change" && status_filter = `Change)
- || (which = "fail" && status_filter = `Fail)
+ if
+ (which = "change" && status_filter = `Change)
+ || (which = "fail" && status_filter = `Fail)
then b [ txt lbl ]
else a ~a:[ a_href href ] [ txt lbl ]
in
- let filters = p ~a:[ a_class [ "crumbs" ] ] [
- txt "Show: ";
- filter_link ~label:"all changes" "change";
- txt " · ";
- filter_link ~label:"only newly failing" "fail";
- ] in
+ let filters =
+ p
+ ~a:[ a_class [ "crumbs" ] ]
+ [
+ txt "Show: ";
+ filter_link ~label:"all changes" "change";
+ txt " · ";
+ filter_link ~label:"only newly failing" "fail";
+ ]
+ in
let pager =
if n_pages <= 1 then []
else
let link p_num label =
- a ~a:[ a_href (Printf.sprintf
- "/profiles/%s/recent?n=%d&status=%s&page=%d"
- name n
- (match status_filter with
- | `Change -> "change" | `Fail -> "fail")
- p_num) ]
+ a
+ ~a:
+ [
+ a_href
+ (Printf.sprintf "/profiles/%s/recent?n=%d&status=%s&page=%d"
+ name n
+ (match status_filter with
+ | `Change -> "change"
+ | `Fail -> "fail")
+ p_num);
+ ]
[ txt label ]
in
- [ div ~a:[ a_class [ "pager" ] ]
- (List.concat [
- (if page > 1 then [ link (page - 1) "‹ Newer"; txt " " ]
- else []);
- [ txt (Printf.sprintf "Page %d of %d (%d snapshot pairs)"
- page n_pages total_pairs) ];
- (if page < n_pages then [ txt " "; link (page + 1) "Older ›" ]
- else []);
- ]) ]
+ [
+ div
+ ~a:[ a_class [ "pager" ] ]
+ (List.concat
+ [
+ (if page > 1 then [ link (page - 1) "‹ Newer"; txt " " ]
+ else []);
+ [
+ txt
+ (Printf.sprintf "Page %d of %d (%d snapshot pairs)" page
+ n_pages total_pairs);
+ ];
+ (if page < n_pages then
+ [ txt " "; link (page + 1) "Older ›" ]
+ else []);
+ ]);
+ ]
in
let body =
- if sections = [] then
- [ p [ em [ txt "No changes in this window." ] ] ]
+ if sections = [] then [ p [ em [ txt "No changes in this window." ] ] ]
else sections
in
Context.respond_ok web_ctx
- ([ Templates.style_block; crumbs;
+ ([
+ Templates.style_block;
+ crumbs;
h2 [ txt (name ^ " — recent changes") ];
- filters ]
- @ body @ pager)
+ filters;
+ ]
+ @ body
+ @ pager)
end
(* ── /profiles/<name>/p/<pkg> ─────────────────────────────────── *)
@@ -1536,41 +1984,70 @@ let package_index ~ctx name pkg =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
(* Find versions of [pkg] across all snapshots. *)
let snaps = list_snapshots_newest_first ctx name in
- let versions = List.fold_left (fun acc snap ->
- let pdir = Fpath.(snap / "packages") in
- match Bos.OS.Dir.contents pdir with
- | Error _ -> acc
- | Ok entries ->
- List.fold_left (fun acc p ->
- let basename = Fpath.basename p in
- if String.length basename > String.length pkg + 1
- && String.sub basename 0 (String.length pkg + 1)
- = pkg ^ "." then
- let v = String.sub basename (String.length pkg + 1)
- (String.length basename - String.length pkg - 1) in
- if List.mem v acc then acc else v :: acc
- else acc) acc entries
- ) [] snaps |> List.sort compare in
- let crumbs = Templates.breadcrumbs [
- Some "/profiles", "Profiles";
- Some ("/profiles/" ^ name), name;
- None, "package: " ^ pkg;
- ] in
- let body = match versions with
- | [] -> [ p [ em [ txt "No builds of this package in any \
- snapshot." ] ] ]
+ let versions =
+ List.fold_left
+ (fun acc snap ->
+ let pdir = Fpath.(snap / "packages") in
+ match Bos.OS.Dir.contents pdir with
+ | Error _ -> acc
+ | Ok entries ->
+ List.fold_left
+ (fun acc p ->
+ let basename = Fpath.basename p in
+ if
+ String.length basename > String.length pkg + 1
+ && String.sub basename 0 (String.length pkg + 1)
+ = pkg ^ "."
+ then
+ let v =
+ String.sub basename
+ (String.length pkg + 1)
+ (String.length basename - String.length pkg - 1)
+ in
+ if List.mem v acc then acc else v :: acc
+ else acc)
+ acc entries)
+ [] snaps
+ |> List.sort compare
+ in
+ let crumbs =
+ Templates.breadcrumbs
+ [
+ (Some "/profiles", "Profiles");
+ (Some ("/profiles/" ^ name), name);
+ (None, "package: " ^ pkg);
+ ]
+ in
+ let body =
+ match versions with
+ | [] ->
+ [ p [ em [ txt "No builds of this package in any snapshot." ] ] ]
| _ ->
- [ ul (List.map (fun v ->
- li [ a ~a:[ a_href (Printf.sprintf
- "/profiles/%s/p/%s/%s" name pkg v) ]
- [ txt (pkg ^ "." ^ v) ] ]) versions) ]
+ [
+ ul
+ (List.map
+ (fun v ->
+ li
+ [
+ a
+ ~a:
+ [
+ a_href
+ (Printf.sprintf "/profiles/%s/p/%s/%s" name pkg
+ v);
+ ]
+ [ txt (pkg ^ "." ^ v) ];
+ ])
+ versions);
+ ]
in
Context.respond_ok web_ctx
- ([ Templates.style_block; crumbs;
- h2 [ txt (name ^ " / " ^ pkg) ] ] @ body)
+ ([ Templates.style_block; crumbs; h2 [ txt (name ^ " / " ^ pkg) ] ]
+ @ body)
end
(* ── /profiles/<name>/p/<pkg>/<ver> ───────────────────────────── *)
@@ -1579,6 +2056,7 @@ let package_version ~ctx name pkg ver =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
let pkg_str = pkg ^ "." ^ ver in
let snaps = list_snapshots_newest_first ctx name in
@@ -1589,100 +2067,129 @@ let package_version ~ctx name pkg ver =
(* Pair each history entry with the universe of its build_hash,
read from that snapshot's dag.json (the only place the
build_hash → universe mapping is persisted). *)
- let entries = List.concat_map (fun snap ->
- let pdir = Fpath.(snap / "packages") in
- (* dag.json carries the real per-node universe + blessing, keyed
+ let entries =
+ List.concat_map
+ (fun snap ->
+ let pdir = Fpath.(snap / "packages") in
+ (* dag.json carries the real per-node universe + blessing, keyed
by the build_hash of each history entry. *)
- let dag_info_of =
- match Day11_lib.Dag_marshal.read ~snapshot_dir:snap with
- | Error _ -> fun _ -> None
- | Ok dag ->
- let h = Hashtbl.create (List.length dag) in
- List.iter (fun (e : Day11_lib.Dag_marshal.entry) ->
- Hashtbl.replace h e.hash (e.universe, e.blessed)) dag;
- fun bh -> Hashtbl.find_opt h bh
- in
- List.map (fun (e : Day11_lib.History.entry) ->
- (e, dag_info_of e.build_hash))
- (Day11_lib.History.read_latest ~packages_dir:pdir ~pkg_str)
- ) snaps in
- let crumbs = Templates.breadcrumbs [
- Some "/profiles", "Profiles";
- Some ("/profiles/" ^ name), name;
- Some (Printf.sprintf "/profiles/%s/p/%s" name pkg),
- "package: " ^ pkg;
- None, ver;
- ] in
- let history_rows = List.map (fun ((e : Day11_lib.History.entry),
- dag_info) ->
- (* Prefer linking to the OCurrent job page (gives a Rebuild
+ let dag_info_of =
+ match Day11_lib.Dag_marshal.read ~snapshot_dir:snap with
+ | Error _ -> fun _ -> None
+ | Ok dag ->
+ let h = Hashtbl.create (List.length dag) in
+ List.iter
+ (fun (e : Day11_lib.Dag_marshal.entry) ->
+ Hashtbl.replace h e.hash (e.universe, e.blessed))
+ dag;
+ fun bh -> Hashtbl.find_opt h bh
+ in
+ List.map
+ (fun (e : Day11_lib.History.entry) ->
+ (e, dag_info_of e.build_hash))
+ (Day11_lib.History.read_latest ~packages_dir:pdir ~pkg_str))
+ snaps
+ in
+ let crumbs =
+ Templates.breadcrumbs
+ [
+ (Some "/profiles", "Profiles");
+ (Some ("/profiles/" ^ name), name);
+ ( Some (Printf.sprintf "/profiles/%s/p/%s" name pkg),
+ "package: " ^ pkg );
+ (None, ver);
+ ]
+ in
+ let history_rows =
+ List.map
+ (fun ((e : Day11_lib.History.entry), dag_info) ->
+ (* Prefer linking to the OCurrent job page (gives a Rebuild
button and structured log) when we can find it; fall back
to the raw layer.log file when the cache no longer has the
job_id (e.g. for entries pre-dating the SQLite cache). *)
- let hash_cell =
- let target = match job_id_for_hash e.build_hash with
- | Some job_id -> "/job/" ^ job_id
- | None ->
- Printf.sprintf "/profiles/%s/builds/%s/log"
- name e.build_hash
- in
- a ~a:[ a_href target ] [ Templates.sha_span e.build_hash ]
- in
- let error_cell = match e.error with
- | Some err -> [ code [ txt err ] ]
- | None -> []
- in
- (* Doc entries carry category "doc_success"/"doc_failure"; build
+ let hash_cell =
+ let target =
+ match job_id_for_hash e.build_hash with
+ | Some job_id -> "/job/" ^ job_id
+ | None ->
+ Printf.sprintf "/profiles/%s/builds/%s/log" name
+ e.build_hash
+ in
+ a ~a:[ a_href target ] [ Templates.sha_span e.build_hash ]
+ in
+ let error_cell =
+ match e.error with Some err -> [ code [ txt err ] ] | None -> []
+ in
+ (* Doc entries carry category "doc_success"/"doc_failure"; build
entries are "success" or a build_* failure category. *)
- let is_doc_entry =
- String.length e.category >= 3
- && String.sub e.category 0 3 = "doc"
- in
- (* Category is just the node kind: "docs" or "build". The
+ let is_doc_entry =
+ String.length e.category >= 3 && String.sub e.category 0 3 = "doc"
+ in
+ (* Category is just the node kind: "docs" or "build". The
outcome is already in the Status column and any failure
detail in Error. *)
- let category_cell = txt (if is_doc_entry then "docs" else "build") in
- let universe, blessed = match dag_info with
- | Some (u, b) -> u, b
- | None -> "", false
- in
- (* Universe applies to both build and doc nodes — link it to the
+ let category_cell =
+ txt (if is_doc_entry then "docs" else "build")
+ in
+ let universe, blessed =
+ match dag_info with Some (u, b) -> (u, b) | None -> ("", false)
+ in
+ (* Universe applies to both build and doc nodes — link it to the
universe page. From dag.json (the real u/<hash> universe). *)
- let universe_cell =
- if universe <> "" then
- a ~a:[ a_href (Printf.sprintf "/profiles/%s/u/%s" name universe) ]
- [ Templates.sha_span universe ]
- else em [ txt "—" ]
- in
- (* "Blessed" is a per-universe doc concept; show it on doc rows. *)
- let blessed_cell =
- if is_doc_entry then
- if blessed then span ~a:[ a_class [ "ok" ] ] [ txt "blessed" ]
- else txt "—"
- else em [ txt "—" ]
- in
- tr [ td [ txt e.ts ];
- td [ txt e.run ];
- td [ Templates.status_span e.status ];
- td [ category_cell ];
- td [ universe_cell ];
- td [ blessed_cell ];
- td [ hash_cell ];
- td error_cell ]
- ) entries in
- let history_block = match history_rows with
+ let universe_cell =
+ if universe <> "" then
+ a
+ ~a:
+ [
+ a_href (Printf.sprintf "/profiles/%s/u/%s" name universe);
+ ]
+ [ Templates.sha_span universe ]
+ else em [ txt "—" ]
+ in
+ (* "Blessed" is a per-universe doc concept; show it on doc rows. *)
+ let blessed_cell =
+ if is_doc_entry then
+ if blessed then span ~a:[ a_class [ "ok" ] ] [ txt "blessed" ]
+ else txt "—"
+ else em [ txt "—" ]
+ in
+ tr
+ [
+ td [ txt e.ts ];
+ td [ txt e.run ];
+ td [ Templates.status_span e.status ];
+ td [ category_cell ];
+ td [ universe_cell ];
+ td [ blessed_cell ];
+ td [ hash_cell ];
+ td error_cell;
+ ])
+ entries
+ in
+ let history_block =
+ match history_rows with
| [] -> [ p [ em [ txt "No history entries." ] ] ]
| _ ->
- [ table ~a:[ a_class [ "data" ] ]
- ~thead:(thead [ tr [ th [ txt "Time" ];
- th [ txt "Run" ];
- th [ txt "Status" ];
- th [ txt "Category" ];
- th [ txt "Universe" ];
- th [ txt "Blessed" ];
- th [ txt "Hash" ];
- th [ txt "Error" ] ] ])
- history_rows ]
+ [
+ table
+ ~a:[ a_class [ "data" ] ]
+ ~thead:
+ (thead
+ [
+ tr
+ [
+ th [ txt "Time" ];
+ th [ txt "Run" ];
+ th [ txt "Status" ];
+ th [ txt "Category" ];
+ th [ txt "Universe" ];
+ th [ txt "Blessed" ];
+ th [ txt "Hash" ];
+ th [ txt "Error" ];
+ ];
+ ])
+ history_rows;
+ ]
in
let docs_para =
let docs_present =
@@ -1691,106 +2198,155 @@ let package_version ~ctx name pkg ver =
| None -> false
in
if docs_present then
- p [ a ~a:[ a_href (Printf.sprintf
- "/profiles/%s/docs/p/%s/%s/doc/index.html"
- name pkg ver) ]
- [ txt "Open rendered docs" ] ]
- else
- p [ em [ txt "No rendered docs for this version." ] ]
+ p
+ [
+ a
+ ~a:
+ [
+ a_href
+ (Printf.sprintf "/profiles/%s/docs/p/%s/%s/doc/index.html"
+ name pkg ver);
+ ]
+ [ txt "Open rendered docs" ];
+ ]
+ else p [ em [ txt "No rendered docs for this version." ] ]
in
- Context.respond_ok web_ctx ([
- Templates.style_block; crumbs;
- h2 [ txt pkg_str ];
- docs_para;
- h3 [ txt "History" ];
- ] @ history_block)
+ Context.respond_ok web_ctx
+ ([
+ Templates.style_block;
+ crumbs;
+ h2 [ txt pkg_str ];
+ docs_para;
+ h3 [ txt "History" ];
+ ]
+ @ history_block)
end
(* ── /profiles/<name>/u/<hash> ────────────────────────────────── *)
-(** The package versions making up a universe (a doc-dep closure).
- The manifest is written per-snapshot, but a universe hash is
- content-addressed, so any snapshot recording it gives the same
- set — we take the first match scanning newest-first. *)
+(** The package versions making up a universe (a doc-dep closure). The manifest
+ is written per-snapshot, but a universe hash is content-addressed, so any
+ snapshot recording it gives the same set — we take the first match scanning
+ newest-first. *)
let universe_page ~ctx name hash =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
let snaps = list_snapshots_newest_first ctx name in
- let manifest = List.find_map (fun snap ->
- Day11_lib.Universe_manifest.read_manifest ~snapshot_dir:snap ~hash)
- snaps
+ let manifest =
+ List.find_map
+ (fun snap ->
+ Day11_lib.Universe_manifest.read_manifest ~snapshot_dir:snap ~hash)
+ snaps
+ in
+ let crumbs =
+ Templates.breadcrumbs
+ [
+ (Some "/profiles", "Profiles");
+ (Some ("/profiles/" ^ name), name);
+ (None, "universe");
+ ]
in
- let crumbs = Templates.breadcrumbs [
- Some "/profiles", "Profiles";
- Some ("/profiles/" ^ name), name;
- None, "universe";
- ] in
- let body = match manifest with
+ let body =
+ match manifest with
| None ->
- [ p [ em [ txt "No manifest found for this universe in any \
- snapshot. It may pre-date universe metadata, \
- or the snapshots have been pruned." ] ] ]
+ [
+ p
+ [
+ em
+ [
+ txt
+ "No manifest found for this universe in any snapshot. \
+ It may pre-date universe metadata, or the snapshots \
+ have been pruned.";
+ ];
+ ];
+ ]
| Some m ->
- let row pv =
- let cell = match String.index_opt pv '.' with
- | None -> td [ txt pv ]
- | Some i ->
- let n = String.sub pv 0 i in
- let v = String.sub pv (i + 1) (String.length pv - i - 1) in
- td [ a ~a:[ a_href (Printf.sprintf
- "/profiles/%s/p/%s/%s" name n v) ]
- [ txt pv ] ]
+ let row pv =
+ let cell =
+ match String.index_opt pv '.' with
+ | None -> td [ txt pv ]
+ | Some i ->
+ let n = String.sub pv 0 i in
+ let v = String.sub pv (i + 1) (String.length pv - i - 1) in
+ td
+ [
+ a
+ ~a:
+ [
+ a_href
+ (Printf.sprintf "/profiles/%s/p/%s/%s" name n v);
+ ]
+ [ txt pv ];
+ ]
+ in
+ tr [ cell ]
in
- tr [ cell ]
- in
- [ p [ txt (Printf.sprintf "%d packages in this universe."
- (List.length m.packages)) ];
- table ~a:[ a_class [ "data" ] ]
- ~thead:(thead [ tr [ th [ txt "Package" ] ] ])
- (List.map row m.packages) ]
+ [
+ p
+ [
+ txt
+ (Printf.sprintf "%d packages in this universe."
+ (List.length m.packages));
+ ];
+ table
+ ~a:[ a_class [ "data" ] ]
+ ~thead:(thead [ tr [ th [ txt "Package" ] ] ])
+ (List.map row m.packages);
+ ]
in
Context.respond_ok web_ctx
- ([ Templates.style_block; crumbs;
- h2 [ txt "Universe "; Templates.sha_span hash ] ] @ body)
+ ([
+ Templates.style_block;
+ crumbs;
+ h2 [ txt "Universe "; Templates.sha_span hash ];
+ ]
+ @ body)
end
(* ── /profiles/<name>/builds/<hash>/log ──────────────────────── *)
-(** Read [layer.log] for a build hash and serve it as text/plain.
- The hash points into the per-arch cache dir (derived from the
- profile's [os_dir_name]). Layer dirs use the first 12 chars of
- the full hash as the directory name; we accept either. Used as
- the link target from the [build_hash] cell of the package
- history table — the answer to "why did this build fail?". *)
+(** Read [layer.log] for a build hash and serve it as text/plain. The hash
+ points into the per-arch cache dir (derived from the profile's
+ [os_dir_name]). Layer dirs use the first 12 chars of the full hash as the
+ directory name; we accept either. Used as the link target from the
+ [build_hash] cell of the package history table — the answer to "why did this
+ build fail?". *)
let build_log_view ~ctx name hash =
object
inherit Resource.t
val! can_get = `Viewer
+
method! private get web_ctx =
let open Lwt.Syntax in
let* response =
match Profile.load ~dir:ctx.profile_dir ~name with
| Error (`Msg e) ->
- Context.respond_error web_ctx
- `Not_found (Printf.sprintf "no such profile: %s (%s)" name e)
- | Ok profile ->
- let os_dir = Profile.os_dir_name profile in
- let short = if String.length hash <= 12 then hash
- else String.sub hash 0 12 in
- let log_path = Fpath.(ctx.cache_dir / os_dir / short / "layer.log") in
- (match Bos.OS.File.read log_path with
- | Error _ ->
- Context.respond_error web_ctx
- `Not_found (Printf.sprintf
- "no log for build %s (looked at %s)"
- short (Fpath.to_string log_path))
- | Ok body ->
- let headers = Cohttp.Header.init_with "Content-Type"
- "text/plain; charset=utf-8" in
- Cohttp_lwt_unix.Server.respond_string
- ~headers ~status:`OK ~body ())
+ Context.respond_error web_ctx `Not_found
+ (Printf.sprintf "no such profile: %s (%s)" name e)
+ | Ok profile -> (
+ let os_dir = Profile.os_dir_name profile in
+ let short =
+ if String.length hash <= 12 then hash else String.sub hash 0 12
+ in
+ let log_path =
+ Fpath.(ctx.cache_dir / os_dir / short / "layer.log")
+ in
+ match Bos.OS.File.read log_path with
+ | Error _ ->
+ Context.respond_error web_ctx `Not_found
+ (Printf.sprintf "no log for build %s (looked at %s)" short
+ (Fpath.to_string log_path))
+ | Ok body ->
+ let headers =
+ Cohttp.Header.init_with "Content-Type"
+ "text/plain; charset=utf-8"
+ in
+ Cohttp_lwt_unix.Server.respond_string ~headers ~status:`OK ~body
+ ())
in
Lwt.return response
end
dune build @fmt failed
"/usr/bin/env" "bash" "-c" "opam exec -- dune build @fmt --ignore-promoted-rules || (echo "dune build @fmt failed"; exit 2)" failed with exit status 2
2026-06-09 21:24.55: Job failed: Failed: Build failed