├── .dockerignore ├── .gitignore ├── .ocamlformat ├── Dockerfile ├── LICENSE.md ├── Makefile ├── README.md ├── doc ├── docs-ci-client-cli-tool.md └── pipeline-diagram.md ├── docker-compose.yml ├── docker ├── README.md ├── init │ ├── Dockerfile │ └── init.sh ├── storage │ ├── Dockerfile │ └── entrypoint.sh └── worker │ └── Dockerfile ├── dune ├── dune-project ├── dune-workspace ├── migrations ├── 20230726075248_initial.down.sql ├── 20230726075248_initial.up.sql ├── 20230815051930_create_package_index.down.sql ├── 20230815051930_create_package_index.up.sql ├── 20230921005634_add_attributes_to_pipeline.down.sql ├── 20230921005634_add_attributes_to_pipeline.up.sql ├── 20240123102438_remove_odoc_commit.down.sql └── 20240123102438_remove_odoc_commit.up.sql ├── ocaml-docs-ci-client.opam ├── ocaml-docs-ci.opam ├── ocaml-docs-ci.opam.template ├── src ├── api │ ├── pipeline │ │ ├── client.ml │ │ ├── client.mli │ │ ├── dune │ │ ├── raw.ml │ │ └── schema.capnp │ └── solver │ │ ├── dune │ │ ├── raw.ml │ │ ├── schema.capnp │ │ ├── solver.ml │ │ └── worker.ml ├── cli │ ├── dune │ ├── epoch.md │ ├── epoch.ml │ ├── logging.ml │ ├── main.ml │ └── ocaml-docs-ci-client.md ├── dune ├── lib │ ├── compile.ml │ ├── compile.mli │ ├── config.ml │ ├── config.mli │ ├── dune │ ├── epoch.ml │ ├── epoch.mli │ ├── html.ml │ ├── html.mli │ ├── index.ml │ ├── init.ml │ ├── init.mli │ ├── jobs.ml │ ├── live.ml │ ├── live.mli │ ├── log.ml │ ├── misc.ml │ ├── mld.ml │ ├── mld.mli │ ├── monitor.ml │ ├── monitor.mli │ ├── o.ml │ ├── opam_repository.ml │ ├── opam_repository.mli │ ├── package.ml │ ├── package.mli │ ├── platform.ml │ ├── prep.ml │ ├── prep.mli │ ├── process.ml │ ├── record.ml │ ├── remote_cache.ml │ ├── retry.ml │ ├── retry.mli │ ├── solver.ml │ ├── solver.mli │ ├── solver_pool.ml │ ├── solver_pool.mli │ ├── spec.ml │ ├── spec.mli │ ├── storage.ml │ ├── storage.mli │ ├── symlink.ml │ ├── symlink.mli │ ├── track.ml │ ├── track.mli │ ├── voodoo.ml │ └── voodoo.mli ├── logging.ml ├── logging.mli ├── ocaml_docs_ci.ml ├── ocaml_docs_ci.mli ├── pipelines │ ├── api_impl.ml │ ├── docs.ml │ └── dune └── solver │ ├── dune │ ├── epoch_lock.ml │ ├── epoch_lock.mli │ ├── git_context.ml │ ├── git_context.mli │ ├── main.ml │ ├── main.mli │ ├── opam_repository.ml │ ├── opam_repository.mli │ ├── process.ml │ ├── service.ml │ ├── service.mli │ ├── solver.ml │ └── solver.mli └── test ├── cli ├── dune ├── run └── run.md ├── lib ├── dune ├── test_compile.ml ├── test_lib.ml └── test_retry.ml └── monitor ├── dune └── test_monitor.ml /.dockerignore: -------------------------------------------------------------------------------- 1 | **/_build 2 | **/_opam 3 | **/*.swp 4 | **/.git 5 | **/var 6 | **/*.orig 7 | **/*.merlin 8 | **/*.cap 9 | docker-compose.yml 10 | Dockerfile 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | *.install 4 | var 5 | .vscode 6 | _opam 7 | cap 8 | config.json 9 | key.ml 10 | opam-repository/ 11 | run.sh 12 | /capnp-secrets 13 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.26.0 2 | ocaml-version = 4.14.0 3 | profile = conventional 4 | break-infix = fit-or-vertical 5 | parse-docstrings = true 6 | module-item-spacing = compact 7 | 8 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:debian-12-ocaml-4.14 AS build 2 | RUN sudo ln -f /usr/bin/opam-2.3 /usr/bin/opam && opam init --reinit -ni 3 | RUN sudo apt-get update && sudo apt-get install -y capnproto graphviz libcapnp-dev libev-dev libffi-dev libgmp-dev libsqlite3-dev pkg-config 4 | RUN cd ~/opam-repository && git fetch -q origin master && git reset --hard 278df338effcd8a80241fbf6902ef949a850372c && opam update 5 | 6 | WORKDIR /src 7 | # See https://github.com/ocurrent/ocaml-docs-ci/pull/177#issuecomment-2445338172 8 | RUN sudo chown opam:opam $(pwd) 9 | 10 | # We want to cache the installation of dependencies prior to pulling in changes from the source dir 11 | COPY --chown=opam ./ocaml-docs-ci.opam /src/ 12 | RUN opam install -y --deps-only . 13 | 14 | COPY --chown=opam . . 15 | RUN opam exec -- dune build ./_build/install/default/bin/ocaml-docs-ci ./_build/install/default/bin/ocaml-docs-ci-solver 16 | RUN cp ./_build/install/default/bin/ocaml-docs-ci ./_build/install/default/bin/ocaml-docs-ci-solver . 17 | 18 | FROM debian:12 19 | RUN apt-get update && apt-get install rsync libev4 openssh-client curl gnupg2 dumb-init git graphviz libsqlite3-dev ca-certificates netbase gzip bzip2 xz-utils unzip tar -y --no-install-recommends 20 | RUN git config --global user.name "docs" && git config --global user.email "ci" 21 | RUN curl -fsSL https://download.docker.com/linux/debian/gpg | apt-key add - 22 | RUN echo 'deb https://download.docker.com/linux/debian bookworm stable' >> /etc/apt/sources.list 23 | RUN apt-get update && apt-get install docker-ce docker-buildx-plugin -y --no-install-recommends 24 | WORKDIR /var/lib/ocurrent 25 | ENTRYPOINT ["dumb-init", "/usr/local/bin/ocaml-docs-ci"] 26 | ENV OCAMLRUNPARAM=a=2 27 | COPY --from=build /src/ocaml-docs-ci /src/ocaml-docs-ci-solver /usr/local/bin/ 28 | # Create migration directory 29 | RUN mkdir -p /migrations 30 | COPY --from=build /src/migrations /migrations 31 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2020-2024 Tarides 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .DEFAULT_GOAL := all 2 | 3 | .PHONY: all 4 | all: 5 | opam exec -- dune build --root . @install 6 | 7 | .PHONY: deps 8 | deps: ## Install development dependencies 9 | opam pin add -yn current_docker.dev "./vendor/ocurrent" && \ 10 | opam pin add -yn current_github.dev "./vendor/ocurrent" && \ 11 | opam pin add -yn current_git.dev "./vendor/ocurrent" && \ 12 | opam pin add -yn current.dev "./vendor/ocurrent" && \ 13 | opam pin add -yn current_rpc.dev "./vendor/ocurrent" && \ 14 | opam pin add -yn current_slack.dev "./vendor/ocurrent" && \ 15 | opam pin add -yn current_web.dev "./vendor/ocurrent" 16 | opam install -y dune-release ocamlformat utop ocaml-lsp-server obuilder-spec 17 | opam install --deps-only --with-test --with-doc -y . 18 | 19 | .PHONY: create_switch 20 | create_switch: 21 | opam switch create . 4.12.0 --no-install 22 | 23 | .PHONY: switch 24 | switch: create_switch deps ## Create an opam switch and install development dependencies 25 | 26 | .PHONY: lock 27 | lock: ## Generate a lock file 28 | opam lock -y . 29 | 30 | .PHONY: build 31 | build: ## Build the project, including non installable libraries and executables 32 | opam exec -- dune build --root . 33 | 34 | .PHONY: install 35 | install: all ## Install the packages on the system 36 | opam exec -- dune install --root . 37 | 38 | .PHONY: start 39 | start: all ## Run the produced executable 40 | opam exec -- dune exec --root . src/ocaml_docs_ci.exe 41 | 42 | .PHONY: test 43 | test: ## Run the unit tests 44 | opam exec -- dune build --root . @test/runtest -f 45 | 46 | .PHONY: clean 47 | clean: ## Clean build artifacts and other generated files 48 | opam exec -- dune clean --root . 49 | 50 | .PHONY: doc 51 | doc: ## Generate odoc documentation 52 | opam exec -- dune build --root . @doc 53 | 54 | .PHONY: fmt 55 | fmt: ## Format the codebase with ocamlformat 56 | opam exec -- dune build --root . --auto-promote @fmt 57 | 58 | .PHONY: utop 59 | utop: ## Run a REPL and link with the project's libraries 60 | opam exec -- dune utop --root . src -- -implicit-bindings 61 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Docs CI 2 | 3 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Focaml.ci.dev%2Fbadge%2Focurrent%2Focaml-docs-ci%2Fmain&logo=ocaml)](https://ocaml.ci.dev/github/ocurrent/ocaml-docs-ci) 4 | 5 | OCaml Docs CI (aka ocaml-docs-ci or just docs-ci) is an OCurrent pipeline used to build the documentation for ocaml.org website. 6 | It uses the metadata from opam-repository to work out how to build documentation for individual packages using [voodoo](https://github.com/ocaml-doc/voodoo), the OCaml package documentation generator, and generates a HTML output suitable for ocaml.org server. 7 | 8 | ## Installation 9 | 10 | Get the code with: 11 | 12 | ```shell 13 | git clone --recursive https://github.com/ocurrent/ocaml-docs-ci.git 14 | cd ocaml-docs-ci 15 | ``` 16 | 17 | Then you need an opam 2.1 switch using OCaml 4.14. Recommend using this command to setup a local switch just for `docs-ci`. 18 | 19 | ```shell 20 | # Create a local switch with packages and test dependencies installed 21 | opam switch create . 4.14.1 --deps-only --with-test -y 22 | 23 | # Run the build 24 | dune build 25 | 26 | # Run the tests 27 | dune build @runtest 28 | ``` 29 | 30 | ## Architecture 31 | 32 | At a high level `docs-ci` purpose is to compile the documentation of every package in the `opamverse`. To do this it generates 33 | a dependency universe. For each package (along with the version), the documentation is generated for it plus all of its 34 | dependencies. This documentation is then collected into a `documentation set` and provided to the ocaml.org service. 35 | The [voodoo](https://github.com/ocaml-doc/voodoo) tool defines the on disk format for the `documentation set`. 36 | 37 | For further details on how `docs-ci` works read the [pipeline diagram](doc/pipeline-diagram.md). 38 | 39 | ## Deployment 40 | 41 | `ocaml-docs-ci` is deployed as into two environments, with [ocurrent-deployer](https://deploy.ci.ocaml.org/?repo=ocurrent/ocaml-docs-ci&). The application is deployed as a series of Docker containers from a git branch. 42 | 43 | Environments: 44 | 45 | | Environment | www | pipeline | git branch | data | voodoo branch | 46 | | ----------- | ------------------------- | --------------------------------- | ---------- | ---------------------------------- | ------------- | 47 | | Production | https://ocaml.org | https://docs.ci.ocaml.org | live | http://docs-data.ocaml.org | main | 48 | | Staging | https://staging.ocaml.org | https://staging.docs.ci.ocaml.org | staging | http://staging.docs-data.ocaml.org | staging | 49 | 50 | OAuth integration provided by GitHub OAuth Apps hosted under the OCurrent organisation. 51 | See https://github.com/organizations/ocurrent/settings/applications 52 | 53 | The infrastructure for `docs-ci` is managed via Ansible, contact @tmcgilchrist or @mtelvers if you need access or have questions. 54 | 55 | To deploy a new version of `docs-ci`: 56 | 57 | 1. Create a PR and wait for the GH Checks to run (ocaml-ci compiles the code and ocurrent-deployer checks it can build the Dockerfiles for the project) 58 | 1. Test the changes on `staging` environment by git cherry picking the commits to that branch and pushing it 59 | 1. Check [deploy.ci.ocaml.org](https://deploy.ci.ocaml.org/?repo=ocurrent/ocaml-docs-ci&) for `docs-ci` 60 | 61 | Follow a similar process for `live` exercising extra caution as it could impact the live ocaml.org service. 62 | 63 | The git history on `live` and `staging` **MUST** be kept in sync with the default branch. 64 | Those branches should be the same as `main` plus or minus some commits from a PR. 65 | 66 | ## Remote API 67 | 68 | `docs-ci` has a cli tool (`ocaml-docs-ci-client`) for interacting with the pipeline over CapnP. It provides commands to: 69 | 70 | * diff-pipelines - to show the changes between two pipeline runs 71 | * health-check - to provide information about a specific pipeline run 72 | * status - build status of a package 73 | * status-by-pipeline - build status of a package in the two most recent pipeline runs 74 | * steps - build steps of a package 75 | 76 | The output is via json, which is intended to be combined with `jq` to display and query for pieces of information. 77 | 78 | ## Local Development 79 | 80 | `ocaml-docs-ci` is runable as: 81 | 82 | ``` 83 | dune exec -- ocaml-docs-ci \ 84 | --ocluster-submission cap/XXX.cap \ 85 | --ssh-host ci.mirage.io \ 86 | --ssh-user docs \ 87 | --ssh-privkey cap/id_rsa \ 88 | --ssh-pubkey cap/id_rsa.pub \ 89 | --ssh-folder /data/ocaml-docs-ci \ 90 | --ssh-endpoint https://ci.mirage.io/staging \ 91 | --jobs 6 \ 92 | --filter mirage \ 93 | --limit 6 94 | ``` 95 | 96 | A [docker-compose.yml](docker-compose.yml) is provided to setup an entire `docs-ci` environment including: 97 | 98 | - ocluster scheduler 99 | - ocluster Linux x86 worker 100 | - nginx webserver for generated docs 101 | - ocaml-docs-ci built from the local git checkout 102 | 103 | Run this command to create an environment: 104 | 105 | ```shell 106 | $ docker-compose -f docker-compose.yml up 107 | ``` 108 | 109 | You should then be able to watch the pipeline in action at `http://localhost:8080`. 110 | 111 | ### Migrations 112 | 113 | Migrations are managed using [omigrate](https://github.com/tmattio/omigrate). If you are using an opam switch for ocaml-docs-ci then omigrate should be installed and you can create a new migration by doing this from the project root: 114 | 115 | ``` shell 116 | $ omigrate create --dir migrations 117 | ``` 118 | 119 | This will create timestamped files in the migrations directory that you can then populate with the sql necessary to introduce and remove the migration (in the up and down files respectively). 120 | 121 | Migrations will not run unless the --migration-path flag is present when invoking ocaml-docs-ci-service. 122 | 123 | ### Epoch management 124 | Epochs are used in ocaml-docs-ci to organise sets of artifacts all produced by the same odoc/voodoo version. 125 | There is a cli tool for managing epochs described in [epoch.md](./src/cli/epoch.md). 126 | -------------------------------------------------------------------------------- /doc/docs-ci-client-cli-tool.md: -------------------------------------------------------------------------------- 1 | A cli tool `ocaml-docs-ci-client` is available to interact with the production and staging instances of `docs.ci.ocaml.org` 2 | 3 | ### Installation 4 | 5 | #### The cli tool 6 | 7 | 1. Clone the `ocaml-docs-ci` repository and [follow the directions](https://github.com/ocurrent/ocaml-docs-ci#installation) to build it locally. Once it has built you should get sensible output from: 8 | 9 | ``` 10 | dune exec -- ocaml-docs-ci-client --help 11 | ``` 12 | 13 | 2. You can install the cli tool by doing `dune install ocaml-docs-ci-client` 14 | 15 | #### Cap files 16 | 17 | The client cli tool communicates with a [capnp](https://github.com/mirage/capnp-rpc) API on `docs.ci.ocaml.org` and requires a capability file for each environment (these are like credentials). To obtain capability files for staging and production please contact the CI / Ops team via slack. You should save these cap files so that you can clearly identify them by the environment that they will connect to. 18 | 19 | #### jq 20 | 21 | `jq` is an incredibly useful tool for working with JSON data (which is what the cli tool outputs). You should install it following the instructions [here.](https://jqlang.github.io/jq/download/) If you are unfamiliar with `jq` please take a look at its [short tutorial](https://jqlang.github.io/jq/tutorial/) to get you started. 22 | 23 | ### Usage 24 | 25 | The cli tool has subcommands `status`, `steps`, `health-check`, `status-by-pipeline` and `diff-pipelines` 26 | 27 | -- 28 | 29 | **`status`** will give you the statuses of all known versions of a package. For example: 30 | 31 | ``` 32 | ❯ ocaml-docs-ci-client status --ci-cap= --package "fmt" 33 | 34 | 35 | package: fmt 36 | Version/Status: 37 | 0.9.0/passed 38 | 0.8.9/failed 39 | 0.8.8/failed 40 | 0.8.6/failed 41 | ``` 42 | 43 | **`steps`** returns returns an array of json objects for each known version of a package. The json objects contain the version, status and an array of steps (corresponding to jobs that were run in docs-ci). For example - in the case of `fmt` 44 | 45 | ``` 46 | ❯ ocaml-docs-ci-client steps --ci-cap= -p "fmt" | jq . 47 | [ 48 | { 49 | "version": "0.9.0", 50 | "status": "passed", 51 | "steps": [ 52 | { 53 | "typ": "prep fmt.0.9.0-7327e140e1aeb42b7944e88e03dcc002", 54 | "job_id": "2023-06-28/051739-voodoo-prep-a0cc8c", 55 | "status": "passed" 56 | }, 57 | ... 58 | ] 59 | } 60 | ] 61 | ``` 62 | 63 | Now we can use `jq` to just get the versions and their statuses like so: 64 | 65 | ``` 66 | 67 | ❯ ocaml-docs-ci-client steps --ci-cap= --package "fmt" | jq '.[] | {version: .version, status: .status}' 68 | { 69 | "version": "0.8.6", 70 | "status": "failed" 71 | } 72 | { 73 | "version": "0.8.8", 74 | "status": "failed" 75 | } 76 | { 77 | "version": "0.8.9", 78 | "status": "failed" 79 | } 80 | { 81 | "version": "0.9.0", 82 | "status": "passed" 83 | } 84 | ``` 85 | 86 | And further, to get the steps that failed: 87 | 88 | ``` 89 | ❯ ocaml-docs-ci-client steps --ci-cap= -p "fmt" | jq . | jq '.[].steps[] | select(.status | test("failed"))' 90 | { 91 | "typ": "prep fmt.0.9.0-7327e140e1aeb42b7944e88e03dcc002", 92 | "job_id": "2023-06-28/051739-voodoo-prep-a0cc8c", 93 | "status": "failed" 94 | } 95 | ``` 96 | 97 | And a bit of `sed` gets us to the urls of the jobs of the failing steps. Assuming here that we are working with staging, we would do: 98 | 99 | ``` 100 | ❯ ocaml-docs-ci-client steps --ci-cap= -p "fmt" | jq '.[].steps[] | select(.status | test("failed"))' | jq '.job_id' | sed 's@"@@g' | sed 's@(^.*$\)@http://staging.docs.ci.ocaml.org/job/\1@' 101 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104410-voodoo-prep-bebea7 102 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104410-voodoo-prep-33ed0a 103 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104410-voodoo-prep-e90e25 104 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104410-voodoo-prep-1b4eef 105 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104411-voodoo-prep-e9df46 106 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104411-voodoo-prep-e9df46 107 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104411-voodoo-prep-e9df46 108 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104410-voodoo-prep-175795 109 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104410-voodoo-prep-1b4eef 110 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104410-voodoo-prep-63df71 111 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104410-voodoo-prep-0dc3a5 112 | http://staging.docs.ci.ocaml.org/job/2023-06-27/104410-voodoo-prep-2cd771 113 | ``` 114 | 115 | **`health-check`** returns a json object containing information about the last two consecutive pipelines. In particular it provides the number of packages in each of `failed`, `running` and `passed` states so that the most recent run can be readily compared to the previous one. 116 | 117 | ``` 118 | ❯ dune exec -- ocaml-docs-ci-client health-check --ci-cap="/Users/navin/src/tarides/ocaml-docs-ci/capnp-secrets/local-docs-ci.cap" | jq . 119 | { 120 | "latest": { 121 | "epoch_html": "ae8bf595b8594945ee40c58377e03730", 122 | "epoch_linked": "5daeecab2ad7a2d07a12742d4cc0ab6f", 123 | "voodoo_do": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 124 | "voodoo_prep": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 125 | "voodoo_gen": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 126 | "voodoo_repo": "https://github.com/ocaml-doc/voodoo.git", 127 | "voodoo_branch": "main", 128 | "failed_packages": 15, 129 | "running_packages": 0, 130 | "passed_packages": 0 131 | }, 132 | "latest-but-one": { 133 | "epoch_html": "ae8bf595b8594945ee40c58377e03730", 134 | "epoch_linked": "5daeecab2ad7a2d07a12742d4cc0ab6f", 135 | "voodoo_do": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 136 | "voodoo_prep": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 137 | "voodoo_gen": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 138 | "voodoo_repo": "https://github.com/ocaml-doc/voodoo.git", 139 | "voodoo_branch": "main", 140 | "failed_packages": 0, 141 | "running_packages": 15, 142 | "passed_packages": 0 143 | } 144 | } 145 | ``` 146 | 147 | **`diff-pipelines`** returns a json object that contains a list of packages that fail in the latest pipeline, that did not fail in the latest-but-one pipeline.hat fail in the latest pipeline, that did not fail in the latest-but-one pipeline. (At the time of writing this document we did not have two pipelines recorded in production so cannot provide meaningful example here. 148 | 149 | **`status-by-pipeline`** takes a package as an argument and returns a json object that contains the status of that package in the latest and latest-but-one pipelines. 150 | 151 | ``` 152 | ❯ dune exec -- ocaml-docs-ci-client status-by-pipeline --ci-cap="/Users/navin/src/tarides/ocaml-docs-ci/capnp-secrets/production-docs-ci.cap" --package "fmt" 153 | {"note":"Only one pipeline has been recorded.","latest_pipeline":[{"version":"0.7.0","status":"pending"},{"version":"0.7.1","status":"pending"},{"version":"0.8.0","status":"pending"},{"version":"0.8.1","status":"pending"},{"version":"0.8.10","status":"pending"},{"version":"0.8.2","status":"pending"},{"version":"0.8.3","status":"pending"},{"version":"0.8.4","status":"pending"},{"version":"0.8.5","status":"pending"},{"version":"0.8.6","status":"pending"},{"version":"0.8.7","status":"pending"},{"version":"0.8.8","status":"pending"},{"version":"0.8.9","status":"pending"},{"version":"0.9.0","status":"pending"}],"latest_but_one_pipeline":[{"version":"0.7.0","status":"pending"},{"version":"0.7.1","status":"pending"},{"version":"0.8.0","status":"pending"},{"version":"0.8.1","status":"pending"},{"version":"0.8.10","status":"pending"},{"version":"0.8.2","status":"pending"},{"version":"0.8.3","status":"pending"},{"version":"0.8.4","status":"pending"},{"version":"0.8.5","status":"pending"},{"version":"0.8.6","status":"pending"},{"version":"0.8.7","status":"pending"},{"version":"0.8.8","status":"pending"},{"version":"0.8.9","status":"pending"},{"version":"0.9.0","status":"pending"}]} 154 | ``` 155 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: "3.8" 2 | services: 3 | 4 | scheduler: 5 | image: ocurrent/ocluster-scheduler:live 6 | command: 7 | - --secrets-dir=/capnp-secrets 8 | - --capnp-secret-key-file=/capnp-secrets/key.pem 9 | - --capnp-listen-address=tcp:0.0.0.0:9000 10 | - --capnp-public-address=tcp:scheduler:9000 11 | - --pools=linux-x86_64 12 | - --state-dir=/var/lib/ocluster-scheduler 13 | - --default-clients=ocaml-docs-ci 14 | init: true 15 | ports: 16 | - "9000:9000" 17 | volumes: 18 | - 'scheduler-data:/var/lib/ocluster-scheduler' 19 | - 'capnp-secrets:/capnp-secrets' 20 | 21 | worker: 22 | # image: ocurrent/ocluster-worker:live 23 | build: 24 | dockerfile: docker/worker/Dockerfile 25 | context: . 26 | command: 27 | - --connect=/capnp-secrets/pool-linux-x86_64.cap 28 | - --name=ocluster-worker 29 | - --allow-push=ocurrentbuilder/staging,ocurrent/opam-staging 30 | - --capacity=1 31 | - --state-dir=/var/lib/ocluster 32 | - --obuilder-store=rsync:/var/cache/obuilder 33 | - --rsync-mode=hardlink 34 | - --obuilder-healthcheck=0 35 | - --verbose 36 | init: true 37 | privileged: true # required for the Docker in Docker container to work 38 | restart: on-failure # (wait for the scheduler to write the pool cap) 39 | volumes: 40 | - 'worker-data:/var/lib/ocluster' 41 | - '/var/run/docker.sock:/var/run/docker.sock' 42 | - 'capnp-secrets:/capnp-secrets:ro' 43 | environment: 44 | - DOCKER_BUILDKIT=1 45 | - DOCKER_CLI_EXPERIMENTAL=enabled 46 | 47 | init: 48 | build: 49 | dockerfile: docker/init/Dockerfile 50 | context: . 51 | environment: 52 | - KEYFILE=/ssh/id_ed25519 53 | - KEYTYPE=ed25519 54 | volumes: 55 | - 'ssh-credentials:/ssh/' 56 | 57 | storage-server: 58 | build: 59 | dockerfile: docker/storage/Dockerfile 60 | context: . 61 | depends_on: 62 | - "init" 63 | ports: 64 | - "2222:22" 65 | volumes: 66 | - 'ssh-credentials:/root/.ssh/' 67 | - 'docs-data:/data' 68 | 69 | http-raw-live-website: 70 | restart: on-failure 71 | image: nginx 72 | command: > 73 | bash -c "rm -rf /usr/share/nginx/html 74 | && ln -s /data/html-live/html-raw /usr/share/nginx/html 75 | && nginx -g 'daemon off;'" 76 | ports: 77 | - "8002:8000" 78 | volumes: 79 | - 'docs-data:/data/' 80 | 81 | http-raw-current-website: 82 | restart: on-failure 83 | image: nginx 84 | command: > 85 | bash -c "rm -rf /usr/share/nginx/html 86 | && ln -s /data/html-current/html-raw /usr/share/nginx/html 87 | && nginx -g 'daemon off;'" 88 | ports: 89 | - "8003:8000" 90 | volumes: 91 | - 'docs-data:/data/' 92 | 93 | ocaml-docs-ci: 94 | # Use published docker container 95 | # image: ocurrent/docs-ci:live 96 | # Build from local sources 97 | build: 98 | dockerfile: Dockerfile 99 | context: . 100 | depends_on: 101 | - "storage-server" 102 | - "scheduler" 103 | - "worker" 104 | command: 105 | - --confirm=above-average 106 | - --ocluster-submission=/capnp-secrets/submit-ocaml-docs-ci.cap 107 | - --ssh-host=172.17.0.1 # ocluster jobs are spawned by the host's docker, so they don't have 108 | # access to this docker-compose's network. therefore we have to get 109 | # to the storage server through the host network. 110 | - --ssh-port=2222 111 | - --ssh-user=root 112 | - --ssh-privkey=/ssh/id_ed25519 113 | - --ssh-pubkey=/ssh/id_ed25519.pub 114 | - --ssh-folder=/data 115 | # - --voodoo-repo="" # Voodoo repository to use 116 | # - --voodoo-branch="" # Git branch from the voodoo repository 117 | - --jobs=6 118 | - --limit=1 # Only build the most recent version of each package 119 | - --filter=capnp-rpc # NOTE Only build capnp-rpc documentation. 120 | - --capnp-listen-address=tcp:0.0.0.0:9080 121 | - --capnp-public-address=tcp:localhost:9080 122 | - --migration-path=/migrations 123 | init: true 124 | restart: on-failure # (wait for the scheduler to write the submission cap) 125 | ports: 126 | - 9080:9080 127 | - 8080:8080 # HTTP UI 128 | volumes: 129 | - 'ocaml-docs-ci-data:/var/lib/ocurrent' 130 | - "capnp-secrets:/capnp-secrets" 131 | - 'ssh-credentials:/ssh/' 132 | environment: 133 | - OCAMLRUNPARAM=b 134 | - CI_PROFILE=dev 135 | x-develop: 136 | watch: 137 | - action: rebuild 138 | path: ./src 139 | 140 | volumes: 141 | ocaml-docs-ci-data: 142 | worker-data: 143 | scheduler-data: 144 | capnp-secrets: 145 | docs-data: 146 | ssh-credentials: 147 | -------------------------------------------------------------------------------- /docker/README.md: -------------------------------------------------------------------------------- 1 | # Helper dockerfiles 2 | 3 | They must be built using the root of the project as context: `docker build -f docker/storage/Dockerfile .`. 4 | 5 | ## storage 6 | 7 | The server in charge of storing the data: 8 | - ssh: endpoint exposed to the workers 9 | - rsync: prep / compile artifacts transfer 10 | - git: html artifacts storage 11 | 12 | ## init 13 | 14 | The initialization program: it generates keys for the storage server 15 | 16 | ## html-data-website 17 | 18 | Expose docs-data volume over http using nginx. 19 | 20 | ## docs-ci 21 | 22 | OCurrent pipeline for building ocaml docs for ocaml.org package index. 23 | Uses the top level Dockerfile at the root of this project. 24 | 25 | ## worker 26 | 27 | ocluster worker to run in a Linux x86_64 pool to test local builds. 28 | The worker uses Docker in Docker to run builds as the production cluster would on Linux. -------------------------------------------------------------------------------- /docker/init/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM alpine:3.18 2 | RUN apk add --no-cache \ 3 | openssh-client \ 4 | ca-certificates \ 5 | bash 6 | ADD ./docker/init/init.sh / 7 | CMD /init.sh 8 | -------------------------------------------------------------------------------- /docker/init/init.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | KEYFILE=${KEYFILE:-/ssh/id_ed25519} 4 | KEYTYPE=${KEYTYPE:-ed25519} 5 | 6 | if [ ! -f $KEYFILE ]; then 7 | echo "Creating a new keypair in $KEYFILE" 8 | ssh-keygen -q -t $KEYTYPE -f $KEYFILE -N '' <<> /etc/ssh/sshd_config 28 | RUN echo 'MaxStartups 200' >> /etc/ssh/sshd_config 29 | RUN sed 's@session\s*required\s*pam_loginuid.so@session optional pam_loginuid.so@g' -i /etc/pam.d/sshd 30 | RUN echo "export VISIBLE=now" >> /etc/profile 31 | RUN git config --global user.email "docker@ci" 32 | RUN git config --global user.name "CI" 33 | COPY ./docker/storage/entrypoint.sh /entrypoint.sh 34 | RUN chmod 744 /entrypoint.sh 35 | 36 | ## TODO Fixup --version git sha information. Not present in current build. Maybe use dune install ... 37 | COPY --from=build /src/epoch /usr/local/bin/ 38 | 39 | EXPOSE 22 40 | EXPOSE 873 41 | 42 | CMD ["rsync_server"] 43 | ENTRYPOINT ["/entrypoint.sh"] 44 | -------------------------------------------------------------------------------- /docker/storage/entrypoint.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | ALLOW=${ALLOW:-192.168.0.0/16 172.16.0.0/12 127.0.0.1/32} 5 | VOLUME=${VOLUME:-/data} 6 | 7 | 8 | setup_sshd(){ 9 | if [ -e "/root/.ssh/authorized_keys" ]; then 10 | chmod 400 /root/.ssh/authorized_keys 11 | chown root:root /root/.ssh/authorized_keys 12 | else 13 | mkdir -p /root/.ssh 14 | chown root:root /root/.ssh 15 | fi 16 | chmod 750 /root/.ssh 17 | } 18 | 19 | setup_rsyncd(){ 20 | touch /etc/rsyncd.secrets 21 | rm -f /var/run/rsyncd.pid 22 | chmod 0400 /etc/rsyncd.secrets 23 | [ -f /etc/rsyncd.conf ] || cat > /etc/rsyncd.conf <" "Tim McGilchrist ") 15 | 16 | (package 17 | (name ocaml-docs-ci) 18 | (synopsis "OCurrent pipeline for building documentation") 19 | (description "OCurrent pipeline for building HTML documentation for the ocaml.org website.") 20 | (depends 21 | (ocaml (>= 4.14.1)) 22 | (opam-format (>= 2.1.4)) 23 | (current (>= 0.6.6)) 24 | current_web 25 | current_git 26 | current_github 27 | current_ocluster 28 | current_docker 29 | current_rpc 30 | (cstruct (>= 6.1.0)) 31 | (opam-0install (>= 0.4.3)) 32 | (capnp-rpc-unix (>= 1.2)) 33 | (capnp-rpc-lwt (>= 1.2.3)) 34 | (lwt (>= 5.6.1)) 35 | (fmt (>= 0.8.9)) 36 | (cmdliner (>= 1.1.0)) 37 | (dockerfile (>= 8.2.1)) 38 | (astring (>= 0.8.5)) 39 | (digestif (>= 1.1.4)) 40 | (logs (>= 0.7.0)) 41 | (opam-file-format (>= 2.1.6)) 42 | (ppx_deriving (>= 5.2.1)) 43 | (ppx_deriving_yojson (>= 3.7.0)) 44 | (git-unix (>= 3.13.0)) 45 | conf-libev 46 | dune-build-info 47 | (ocaml-version (= 3.6.5)) 48 | (obuilder-spec (>= 0.5.1)) 49 | (ocolor (>= 1.3.0)) 50 | (memtrace (>= 0.1.1)) ; required for memory profiling 51 | (alcotest (and (>= 1.7.0) :with-test)) 52 | (alcotest-lwt (and (>= 1.7.0) :with-test)) 53 | (mirage-crypto-rng (>= 0.8.7)) 54 | (prometheus-app (>= 1.2)) 55 | (omigrate (>= 0.3.2)))) 56 | 57 | (package 58 | (name ocaml-docs-ci-client) 59 | (synopsis "Command-line client for ocaml-docs-ci") 60 | (depends 61 | (ocaml (>= 4.14.1)) 62 | (logs (>= 0.7.0)) 63 | (fmt (>= 0.8.9)) 64 | (current_rpc (>= 0.6.6)) 65 | (capnp-rpc-unix (>= 1.2)) 66 | dockerfile 67 | (mdx :with-test) 68 | ocaml-docs-ci 69 | (progress (>= 0.2.2)) 70 | mtime 71 | (timedesc (>= 0.9.0)))) 72 | -------------------------------------------------------------------------------- /dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.6) 2 | 3 | (env 4 | (dev 5 | (flags (:standard -warn-error -A)))) 6 | -------------------------------------------------------------------------------- /migrations/20230726075248_initial.down.sql: -------------------------------------------------------------------------------- 1 | DROP TABLE docs_ci_package_index; 2 | DROP TABLE docs_ci_pipeline_index; -------------------------------------------------------------------------------- /migrations/20230726075248_initial.up.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE IF NOT EXISTS docs_ci_package_index ( 2 | name TEXT NOT NULL, 3 | version TEXT NOT NULL, 4 | step_list TEXT NOT NULL, 5 | status INT8 NOT NULL DEFAULT 0, 6 | pipeline_id INTEGER REFERENCES docs_ci_pipeline_index(id) 7 | ); 8 | 9 | CREATE TABLE IF NOT EXISTS docs_ci_pipeline_index ( 10 | id INTEGER PRIMARY KEY, 11 | epoch_linked TEXT, 12 | epoch_html TEXT, 13 | voodoo_do TEXT, 14 | voodoo_gen TEXT, 15 | voodoo_prep TEXT 16 | ); -------------------------------------------------------------------------------- /migrations/20230815051930_create_package_index.down.sql: -------------------------------------------------------------------------------- 1 | DROP INDEX IF EXISTS idx_packages_pipeline; -------------------------------------------------------------------------------- /migrations/20230815051930_create_package_index.up.sql: -------------------------------------------------------------------------------- 1 | CREATE UNIQUE INDEX IF NOT EXISTS idx_packages_pipeline 2 | ON docs_ci_package_index (name, version, pipeline_id); -------------------------------------------------------------------------------- /migrations/20230921005634_add_attributes_to_pipeline.down.sql: -------------------------------------------------------------------------------- 1 | ALTER TABLE docs_ci_pipeline_index 2 | DROP COLUMN voodoo_branch; 3 | 4 | ALTER TABLE docs_ci_pipeline_index 5 | DROP COLUMN voodoo_repo; 6 | 7 | ALTER TABLE docs_ci_pipeline_index 8 | DROP COLUMN odoc_commit; 9 | -------------------------------------------------------------------------------- /migrations/20230921005634_add_attributes_to_pipeline.up.sql: -------------------------------------------------------------------------------- 1 | ALTER TABLE docs_ci_pipeline_index 2 | ADD COLUMN voodoo_branch TEXT; 3 | 4 | ALTER TABLE docs_ci_pipeline_index 5 | ADD COLUMN voodoo_repo TEXT; 6 | 7 | ALTER TABLE docs_ci_pipeline_index 8 | ADD COLUMN odoc_commit TEXT; -------------------------------------------------------------------------------- /migrations/20240123102438_remove_odoc_commit.down.sql: -------------------------------------------------------------------------------- 1 | ALTER TABLE docs_ci_pipeline_index 2 | ADD COLUMN odoc_commit TEXT; -------------------------------------------------------------------------------- /migrations/20240123102438_remove_odoc_commit.up.sql: -------------------------------------------------------------------------------- 1 | ALTER TABLE docs_ci_pipeline_index 2 | DROP COLUMN odoc_commit; -------------------------------------------------------------------------------- /ocaml-docs-ci-client.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Command-line client for ocaml-docs-ci" 4 | maintainer: [ 5 | "Navin Keswani " 6 | "Tim McGilchrist " 7 | ] 8 | authors: ["lucas@tarides.com"] 9 | license: "MIT" 10 | homepage: "https://github.com/ocurrent/ocaml-docs-ci" 11 | bug-reports: "https://github.com/ocurrent/ocaml-docs-ci/issues" 12 | depends: [ 13 | "dune" {>= "3.6"} 14 | "ocaml" {>= "4.14.1"} 15 | "logs" {>= "0.7.0"} 16 | "fmt" {>= "0.8.9"} 17 | "current_rpc" {>= "0.6.6"} 18 | "capnp-rpc-unix" {>= "1.2"} 19 | "dockerfile" 20 | "mdx" {with-test} 21 | "ocaml-docs-ci" 22 | "progress" {>= "0.2.2"} 23 | "mtime" 24 | "timedesc" {>= "0.9.0"} 25 | "odoc" {with-doc} 26 | ] 27 | build: [ 28 | ["dune" "subst"] {dev} 29 | [ 30 | "dune" 31 | "build" 32 | "-p" 33 | name 34 | "-j" 35 | jobs 36 | "@install" 37 | "@runtest" {with-test} 38 | "@doc" {with-doc} 39 | ] 40 | ] 41 | dev-repo: "git+https://github.com/ocurrent/ocaml-docs-ci.git" 42 | -------------------------------------------------------------------------------- /ocaml-docs-ci.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "OCurrent pipeline for building documentation" 4 | description: 5 | "OCurrent pipeline for building HTML documentation for the ocaml.org website." 6 | maintainer: [ 7 | "Navin Keswani " 8 | "Tim McGilchrist " 9 | ] 10 | authors: ["lucas@tarides.com"] 11 | license: "MIT" 12 | homepage: "https://github.com/ocurrent/ocaml-docs-ci" 13 | bug-reports: "https://github.com/ocurrent/ocaml-docs-ci/issues" 14 | depends: [ 15 | "dune" {>= "3.6"} 16 | "ocaml" {>= "4.14.1"} 17 | "opam-format" {>= "2.1.4"} 18 | "current" {>= "0.6.6"} 19 | "current_web" 20 | "current_git" 21 | "current_github" 22 | "current_ocluster" 23 | "current_docker" 24 | "current_rpc" 25 | "cstruct" {>= "6.1.0"} 26 | "opam-0install" {>= "0.4.3"} 27 | "capnp-rpc-unix" {>= "1.2"} 28 | "capnp-rpc-lwt" {>= "1.2.3"} 29 | "lwt" {>= "5.6.1"} 30 | "fmt" {>= "0.8.9"} 31 | "cmdliner" {>= "1.1.0"} 32 | "dockerfile" {>= "8.2.1"} 33 | "astring" {>= "0.8.5"} 34 | "digestif" {>= "1.1.4"} 35 | "logs" {>= "0.7.0"} 36 | "opam-file-format" {>= "2.1.6"} 37 | "ppx_deriving" {>= "5.2.1"} 38 | "ppx_deriving_yojson" {>= "3.7.0"} 39 | "git-unix" {>= "3.13.0"} 40 | "conf-libev" 41 | "dune-build-info" 42 | "ocaml-version" {= "3.6.5"} 43 | "obuilder-spec" {>= "0.5.1"} 44 | "ocolor" {>= "1.3.0"} 45 | "memtrace" {>= "0.1.1"} 46 | "alcotest" {>= "1.7.0" & with-test} 47 | "alcotest-lwt" {>= "1.7.0" & with-test} 48 | "mirage-crypto-rng" {>= "0.8.7"} 49 | "prometheus-app" {>= "1.2"} 50 | "omigrate" {>= "0.3.2"} 51 | "odoc" {with-doc} 52 | ] 53 | build: [ 54 | ["dune" "subst"] {dev} 55 | [ 56 | "dune" 57 | "build" 58 | "-p" 59 | name 60 | "-j" 61 | jobs 62 | "@install" 63 | "@runtest" {with-test} 64 | "@doc" {with-doc} 65 | ] 66 | ] 67 | dev-repo: "git+https://github.com/ocurrent/ocaml-docs-ci.git" 68 | available: [ arch != "x86_32" ] 69 | -------------------------------------------------------------------------------- /ocaml-docs-ci.opam.template: -------------------------------------------------------------------------------- 1 | available: [ arch != "x86_32" ] 2 | -------------------------------------------------------------------------------- /src/api/pipeline/client.ml: -------------------------------------------------------------------------------- 1 | open Capnp_rpc_lwt 2 | 3 | module Build_status = struct 4 | include Raw.Reader.BuildStatus 5 | 6 | let pp f = function 7 | | NotStarted -> Fmt.string f "not started" 8 | | Failed -> Fmt.pf f "@{failed@}" 9 | | Passed -> Fmt.pf f "@{passed@}" 10 | | Pending -> Fmt.pf f "@{pending@}" 11 | | Undefined x -> Fmt.pf f "unknown:%d" x 12 | 13 | let color = function 14 | | NotStarted -> `None 15 | | Failed -> `Fg `Red 16 | | Passed -> `Fg `Green 17 | | Pending -> `Fg `Yellow 18 | | Undefined _ -> `None 19 | 20 | let to_yojson = function 21 | | NotStarted -> `String "not started" 22 | | Failed -> `String "failed" 23 | | Passed -> `String "passed" 24 | | Pending -> `String "pending" 25 | | Undefined _ -> `String "unknown" 26 | end 27 | 28 | module State = struct 29 | type t = 30 | | Aborted 31 | | Failed of string 32 | | NotStarted 33 | | Active 34 | | Passed 35 | | Undefined of int 36 | 37 | let pp f = function 38 | | NotStarted -> Fmt.string f "not started" 39 | | Aborted -> Fmt.string f "aborted" 40 | | Failed m -> Fmt.pf f "failed: %s" m 41 | | Passed -> Fmt.string f "passed" 42 | | Active -> Fmt.string f "active" 43 | | Undefined x -> Fmt.pf f "unknown:%d" x 44 | 45 | let from_build_status = function 46 | | Build_status.Failed -> Failed "" 47 | | NotStarted -> NotStarted 48 | | Pending -> Active 49 | | Passed -> Passed 50 | | Undefined x -> Undefined x 51 | end 52 | 53 | module Package = struct 54 | type t = Raw.Client.Package.t Capability.t 55 | type package_version = { version : OpamPackage.Version.t } 56 | type package_info = Raw.Reader.PackageInfo.t 57 | 58 | let package_info_to_yojson pi = 59 | `Assoc [ ("package", `String (Raw.Reader.PackageInfo.name_get pi)) ] 60 | 61 | type package_info_list = package_info list [@@deriving to_yojson] 62 | 63 | type package_status = { 64 | version : OpamPackage.Version.t; 65 | status : Build_status.t; 66 | } 67 | 68 | let package_status_to_yojson { version; status } = 69 | let version = `String (version |> OpamPackage.Version.to_string) in 70 | let status = Build_status.to_yojson status in 71 | `Assoc [ ("version", version); ("status", status) ] 72 | 73 | type package_status_list = package_status list [@@deriving to_yojson] 74 | 75 | type step = { typ : string; job_id : string option; status : Build_status.t } 76 | [@@deriving to_yojson] 77 | 78 | type package_steps = { 79 | version : string; 80 | status : Build_status.t; 81 | steps : step list; 82 | } 83 | [@@deriving to_yojson] 84 | 85 | type package_steps_list = package_steps list [@@deriving to_yojson] 86 | 87 | let versions t = 88 | let open Raw.Client.Package.Versions in 89 | let request = Capability.Request.create_no_args () in 90 | Capability.call_for_value t method_id request 91 | |> Lwt_result.map (fun x -> 92 | x 93 | |> Results.versions_get_list 94 | |> List.map (fun x -> 95 | { 96 | version = 97 | Raw.Reader.PackageBuildStatus.version_get x 98 | |> OpamPackage.Version.of_string; 99 | status = Raw.Reader.PackageBuildStatus.status_get x; 100 | })) 101 | 102 | let steps t = 103 | let open Raw.Client.Package.Steps in 104 | let request, _ = Capability.Request.create Params.init_pointer in 105 | Capability.call_for_value t method_id request 106 | |> Lwt_result.map @@ fun package_steps -> 107 | let open Raw.Reader.PackageSteps in 108 | Results.steps_get_list package_steps 109 | |> List.map @@ fun package_slot -> 110 | let package_version = version_get package_slot in 111 | let status = status_get package_slot in 112 | let steps = 113 | steps_get_list package_slot 114 | |> List.map (fun x -> 115 | let open Raw.Reader.StepInfo in 116 | let status = status_get x in 117 | let typ = type_get x in 118 | let job_id_t = job_id_get x in 119 | let job_id = 120 | match JobId.get job_id_t with 121 | | JobId.None | JobId.Undefined _ -> None 122 | | JobId.Id s -> Some s 123 | in 124 | { typ; job_id; status }) 125 | in 126 | (package_version, status, steps) 127 | 128 | let by_pipeline t pipeline_id = 129 | let open Raw.Client.Package.ByPipeline in 130 | let request, params = Capability.Request.create Params.init_pointer in 131 | Params.pipeline_id_set params pipeline_id; 132 | Capability.call_for_value t method_id request 133 | |> Lwt_result.map (fun x -> 134 | x 135 | |> Results.versions_get_list 136 | |> List.map (fun x -> 137 | { 138 | version = 139 | Raw.Reader.PackageBuildStatus.version_get x 140 | |> OpamPackage.Version.of_string; 141 | status = Raw.Reader.PackageBuildStatus.status_get x; 142 | })) 143 | end 144 | 145 | module Pipeline = struct 146 | type t = Raw.Client.Pipeline.t Capability.t 147 | type health = Raw.Reader.PipelineHealth.t 148 | 149 | let health_to_yojson h = 150 | let open Raw.Reader.PipelineHealth in 151 | let epoch_html = epoch_html_get h in 152 | let epoch_linked = epoch_linked_get h in 153 | let voodoo_do = voodoo_do_commit_get h in 154 | let voodoo_prep = voodoo_prep_commit_get h in 155 | let voodoo_gen = voodoo_gen_commit_get h in 156 | let voodoo_branch = voodoo_branch_get h in 157 | let voodoo_repo = voodoo_repo_get h in 158 | let failed_packages = failing_packages_get h |> Int64.to_int in 159 | let running_packages = running_packages_get h |> Int64.to_int in 160 | let passed_packages = passing_packages_get h |> Int64.to_int in 161 | `Assoc 162 | [ 163 | ("epoch_html", `String epoch_html); 164 | ("epoch_linked", `String epoch_linked); 165 | ("voodoo_do", `String voodoo_do); 166 | ("voodoo_prep", `String voodoo_prep); 167 | ("voodoo_gen", `String voodoo_gen); 168 | ("voodoo_repo", `String voodoo_repo); 169 | ("voodoo_branch", `String voodoo_branch); 170 | ("failed_packages", `Int failed_packages); 171 | ("running_packages", `Int running_packages); 172 | ("passed_packages", `Int passed_packages); 173 | ] 174 | 175 | let package t name = 176 | let open Raw.Client.Pipeline.Package in 177 | let request, params = Capability.Request.create Params.init_pointer in 178 | Params.package_name_set params name; 179 | Capability.call_for_caps t method_id request Results.package_get_pipelined 180 | 181 | let packages t = 182 | let open Raw.Client.Pipeline.Packages in 183 | let request = Capability.Request.create_no_args () in 184 | Capability.call_for_value t method_id request 185 | |> Lwt_result.map Results.packages_get_list 186 | 187 | let health t pipeline_id = 188 | let open Raw.Client.Pipeline.Health in 189 | let request, params = Capability.Request.create Params.init_pointer in 190 | Params.pipeline_id_set params pipeline_id; 191 | Capability.call_for_value t method_id request 192 | |> Lwt_result.map Results.health_get 193 | 194 | let diff t pipeline_id_one pipeline_id_two = 195 | let open Raw.Client.Pipeline.Diff in 196 | let request, params = Capability.Request.create Params.init_pointer in 197 | Params.pipeline_id_one_set params pipeline_id_one; 198 | Params.pipeline_id_two_set params pipeline_id_two; 199 | Capability.call_for_value t method_id request 200 | |> Lwt_result.map Results.failing_packages_get_list 201 | 202 | let pipeline_ids t = 203 | let open Raw.Client.Pipeline.PipelineIds in 204 | let request, _params = Capability.Request.create Params.init_pointer in 205 | Capability.call_for_value t method_id request 206 | |> Lwt_result.map (fun x -> 207 | (Results.latest_get x, Results.latest_but_one_get x)) 208 | end 209 | -------------------------------------------------------------------------------- /src/api/pipeline/client.mli: -------------------------------------------------------------------------------- 1 | open Capnp_rpc_lwt 2 | 3 | module Build_status : sig 4 | type t = Raw.Reader.BuildStatus.t 5 | 6 | val pp : t Fmt.t 7 | val color : t -> Fmt.style 8 | end 9 | 10 | module State : sig 11 | type t = 12 | | Aborted 13 | | Failed of string 14 | | NotStarted 15 | | Active 16 | | Passed 17 | | Undefined of int 18 | 19 | val pp : t Fmt.t 20 | val from_build_status : Build_status.t -> t 21 | end 22 | 23 | module Package : sig 24 | type t = Raw.Client.Package.t Capability.t 25 | type package_version = { version : OpamPackage.Version.t } 26 | type package_info = Raw.Reader.PackageInfo.t 27 | type package_info_list = package_info list [@@deriving to_yojson] 28 | 29 | type package_status = { 30 | version : OpamPackage.Version.t; 31 | status : Build_status.t; 32 | } 33 | 34 | val package_status_to_yojson : package_status -> Yojson.Safe.t 35 | 36 | type package_status_list = package_status list [@@deriving to_yojson] 37 | type step = { typ : string; job_id : string option; status : Build_status.t } 38 | 39 | type package_steps = { 40 | version : string; 41 | status : Build_status.t; 42 | steps : step list; 43 | } 44 | 45 | type package_steps_list = package_steps list [@@deriving to_yojson] 46 | 47 | val package_steps_to_yojson : package_steps -> Yojson.Safe.t 48 | val step_to_yojson : step -> Yojson.Safe.t 49 | 50 | val versions : 51 | t -> (package_status list, [> `Capnp of Capnp_rpc.Error.t ]) Lwt_result.t 52 | 53 | val steps : 54 | t -> 55 | ( (string * Build_status.t * step list) list, 56 | [> `Capnp of Capnp_rpc.Error.t ] ) 57 | Lwt_result.t 58 | 59 | val by_pipeline : 60 | t -> 61 | int64 -> 62 | (package_status list, [> `Capnp of Capnp_rpc.Error.t ]) Lwt_result.t 63 | end 64 | 65 | module Pipeline : sig 66 | type t = Raw.Client.Pipeline.t Capability.t 67 | (** The top level object for ocaml-docs-ci. *) 68 | 69 | type health = Raw.Reader.PipelineHealth.t 70 | (** General information and health of the pipeline. Includes information about 71 | voodoo, the epochs, and the number of failing, running and passing 72 | packages *) 73 | 74 | val health_to_yojson : 75 | health -> [> `Assoc of (string * [> `Int of int | `String of string ]) list ] 76 | 77 | val package : t -> string -> Raw.Reader.Package.t Capability.t 78 | 79 | val packages : 80 | t -> 81 | ( Raw.Reader.PackageInfo.t list, 82 | [> `Capnp of Capnp_rpc.Error.t ] ) 83 | Lwt_result.t 84 | 85 | val health : 86 | t -> 87 | int64 -> 88 | (Raw.Reader.PipelineHealth.t, [> `Capnp of Capnp_rpc.Error.t ]) Lwt_result.t 89 | 90 | val diff : 91 | t -> 92 | int64 -> 93 | int64 -> 94 | ( Raw.Reader.PackageInfo.t list, 95 | [> `Capnp of Capnp_rpc.Error.t ] ) 96 | Lwt_result.t 97 | 98 | val pipeline_ids : 99 | t -> (int64 * int64, [> `Capnp of Capnp_rpc.Error.t ]) Lwt_result.t 100 | end 101 | -------------------------------------------------------------------------------- /src/api/pipeline/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ocaml-docs-ci.pipeline_api) 3 | (name pipeline_api) 4 | (libraries 5 | capnp-rpc-lwt 6 | opam-format 7 | current_rpc 8 | ocolor 9 | ppx_deriving_yojson.runtime) 10 | (flags 11 | (:standard -w -53-55)) 12 | (preprocess 13 | (pps ppx_deriving.std ppx_deriving_yojson))) 14 | 15 | (rule 16 | (targets schema.ml schema.mli) 17 | (deps schema.capnp) 18 | (action 19 | (run capnp compile -o %{bin:capnpc-ocaml} %{deps}))) 20 | -------------------------------------------------------------------------------- /src/api/pipeline/raw.ml: -------------------------------------------------------------------------------- 1 | include Schema.MakeRPC (Capnp_rpc_lwt) 2 | -------------------------------------------------------------------------------- /src/api/pipeline/schema.capnp: -------------------------------------------------------------------------------- 1 | @0xbf46af72b205a04b; 2 | 3 | struct JobStatus { 4 | id @0 :Text; 5 | description @1 :Text; 6 | canCancel @2 :Bool; 7 | canRebuild @3 :Bool; 8 | } 9 | 10 | interface Job { 11 | status @0 () -> JobStatus; 12 | cancel @1 () -> (); 13 | rebuild @2 () -> (job :Job); 14 | 15 | log @3 (start :Int64) -> (log :Data, next :Int64); 16 | # Return a chunk of log data starting at byte offset "start" and the 17 | # value to use for "start" in the next call to continue reading. 18 | # Returns 0 bytes of data to indicate end-of-file. 19 | # If the log is incomplete and there is no data currently available, 20 | # it waits until something changes before returning. 21 | # If "start" is negative then it is relative to the end of the log. 22 | } 23 | 24 | interface Engine { 25 | activeJobs @0 () -> (ids :List(Text)); 26 | job @1 (id :Text) -> (job :Job); 27 | } 28 | 29 | enum BuildStatus { 30 | notStarted @0; 31 | passed @1; 32 | failed @2; 33 | pending @3; 34 | } 35 | 36 | struct JobInfo { 37 | variant @0 :Text; # TODO This should be a structured type of information. 38 | state :union { 39 | notStarted @1 :Void; 40 | 41 | passed @2 :Void; 42 | 43 | failed @3 :Text; 44 | # The text is the error message. 45 | 46 | active @4 :Void; 47 | # The job is still running. 48 | 49 | aborted @5 :Void; 50 | # This means we couldn't find any record of the job. It probably means 51 | # that the server crashed while building, and when it came back up we 52 | # no longer wanted to test that commit anyway. 53 | } 54 | 55 | queuedAt :union { 56 | ts @6 :Float64; 57 | # timestamp as seconds since epoch 58 | none @7 :Void; 59 | } 60 | 61 | startedAt :union { 62 | ts @8 :Float64; 63 | # timestamp as seconds since epoch 64 | none @9 :Void; 65 | } 66 | 67 | finishedAt :union { 68 | ts @10 :Float64; 69 | # timestamp as seconds since epoch 70 | none @11 :Void; 71 | } 72 | } 73 | 74 | enum StepType { 75 | prep @0; 76 | depCompilePrep @1; 77 | depCompileCompile @2; 78 | compile @3; 79 | buildHtml @4; 80 | } 81 | 82 | struct Step { 83 | type @0 :StepType; 84 | # TODO This needs to link to a Job somehow? Use the job_id 85 | jobId @1 :Text; 86 | } 87 | 88 | struct StepInfo { 89 | type @0 :Text; # see if we can use StepType here. 90 | # The job_id links a step to the job that reifies it. 91 | jobId :union { 92 | id @1 :Text; 93 | none @2 :Void; 94 | } 95 | status @3 :BuildStatus; 96 | stepPackage :union { # the (optional) package that the step refers to 97 | name @4 :Text; 98 | none @5 :Void; 99 | } 100 | } 101 | 102 | struct PackageInfo { 103 | name @0 :Text; 104 | } 105 | 106 | struct PackageBuildStatus { 107 | version @0 :Text; 108 | status @1 :BuildStatus; 109 | } 110 | 111 | struct PackageSteps { 112 | version @0 :Text; 113 | status @1 :BuildStatus; 114 | steps @2 :List(StepInfo); 115 | } 116 | 117 | struct PipelineHealth { 118 | voodooDoCommit @0 :Text; 119 | voodooGenCommit @1 :Text; 120 | voodooPrepCommit @2 :Text; 121 | epochHtml @3 :Text; 122 | epochLinked @4 :Text; 123 | failingPackages @5 :Int64; 124 | passingPackages @6 :Int64; 125 | runningPackages @7 :Int64; 126 | voodooBranch @8 :Text; 127 | voodooRepo @9 :Text; 128 | odocCommit @10 :Text; 129 | } 130 | 131 | interface Package { 132 | steps @0 () -> (steps :List(PackageSteps)); 133 | 134 | versions @1 () -> (versions :List(PackageBuildStatus)); 135 | 136 | byPipeline @2 (pipeline_id :Int64) -> (versions :List(PackageBuildStatus)); 137 | } 138 | 139 | interface Pipeline { 140 | package @0 (package_name :Text) -> (package : Package); 141 | 142 | packages @1 () -> (packages :List(PackageInfo)); 143 | 144 | health @2 (pipeline_id :Int64) -> (health : PipelineHealth); 145 | 146 | diff @3 (pipeline_id_one :Int64, pipeline_id_two :Int64) -> (failingPackages :List(PackageInfo)); 147 | 148 | pipelineIds @4 () -> (latest :Int64, latest_but_one :Int64); 149 | } -------------------------------------------------------------------------------- /src/api/solver/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name solver_api) 3 | (package ocaml-docs-ci) 4 | (libraries capnp-rpc-lwt current_rpc ppx_deriving_yojson.runtime) 5 | (flags 6 | (:standard -w -53-55)) 7 | (preprocess 8 | (pps ppx_deriving.std ppx_deriving_yojson))) 9 | 10 | (rule 11 | (targets schema.ml schema.mli) 12 | (deps schema.capnp) 13 | (action 14 | (run capnp compile -o %{bin:capnpc-ocaml} %{deps}))) 15 | -------------------------------------------------------------------------------- /src/api/solver/raw.ml: -------------------------------------------------------------------------------- 1 | include Schema.MakeRPC (Capnp_rpc_lwt) 2 | -------------------------------------------------------------------------------- /src/api/solver/schema.capnp: -------------------------------------------------------------------------------- 1 | @0xb253d50afc6d7304; 2 | 3 | interface Log { 4 | write @0 (msg :Text); 5 | } 6 | 7 | interface Solver { 8 | solve @0 (request :Text, log :Log) -> (response :Text); 9 | } -------------------------------------------------------------------------------- /src/api/solver/solver.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Capnp_rpc_lwt 3 | 4 | module Log = struct 5 | module X = Raw.Client.Log 6 | 7 | type t = X.t Capability.t 8 | 9 | let pp_timestamp f x = 10 | let open Unix in 11 | let tm = gmtime x in 12 | Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) 13 | tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec 14 | 15 | let write t msg = 16 | let open X.Write in 17 | let message_size = 150 + String.length msg in 18 | let request, params = 19 | Capability.Request.create ~message_size Params.init_pointer 20 | in 21 | Params.msg_set params msg; 22 | Capability.call_for_unit_exn t method_id request 23 | 24 | let info t fmt = 25 | let now = Unix.gettimeofday () in 26 | let k msg = 27 | let thread = write t msg in 28 | Lwt.on_failure thread (fun ex -> 29 | Format.eprintf "Log.info(%S) failed: %a@." msg Fmt.exn ex) 30 | in 31 | Fmt.kstr k ("%a [INFO] @[" ^^ fmt ^^ "@]@.") pp_timestamp now 32 | end 33 | 34 | module X = Raw.Client.Solver 35 | 36 | type t = X.t Capability.t 37 | 38 | let solve t ~log reqs = 39 | let open X.Solve in 40 | let request, params = Capability.Request.create Params.init_pointer in 41 | Params.request_set params 42 | (Worker.Solve_request.to_yojson reqs |> Yojson.Safe.to_string); 43 | Params.log_set params (Some log); 44 | Capability.call_for_value_exn t method_id request >|= Results.response_get 45 | >|= fun json -> 46 | match Worker.Solve_response.of_yojson (Yojson.Safe.from_string json) with 47 | | Ok x -> x 48 | | Error ex -> failwith ex 49 | -------------------------------------------------------------------------------- /src/api/solver/worker.ml: -------------------------------------------------------------------------------- 1 | (** Communication between ocaml-ci and the workers. *) 2 | 3 | (** Variables describing a build environment. *) 4 | module Vars = struct 5 | type t = { 6 | arch : string; 7 | os : string; 8 | os_family : string; 9 | os_distribution : string; 10 | os_version : string; 11 | } 12 | [@@deriving yojson] 13 | end 14 | 15 | (** A set of packages for a single build. *) 16 | module Selection = struct 17 | type t = { 18 | id : string; (** The platform ID from the request. *) 19 | packages : (string * string list) list; 20 | (** The selected packages ("name.version") and their universes. *) 21 | commit : string; (** A commit in opam-repository to use. *) 22 | } 23 | [@@deriving yojson, ord] 24 | end 25 | 26 | (** A request to select sets of packages for the builds. *) 27 | module Solve_request = struct 28 | type rel = [ `Eq | `Geq | `Gt | `Leq | `Lt | `Neq ] [@@deriving yojson] 29 | 30 | type t = { 31 | opam_repository_commit : string; (** Commit in opam repository to use. *) 32 | pkgs : string list; (** Name of packages to solve. *) 33 | constraints : (string * rel * string) list; (** Version locks *) 34 | platforms : (string * Vars.t) list; (** Possible build platforms, by ID. *) 35 | } 36 | [@@deriving yojson] 37 | end 38 | 39 | (** The response from the solver. *) 40 | module Solve_response = struct 41 | type ('a, 'b) result = ('a, 'b) Stdlib.result = Ok of 'a | Error of 'b 42 | [@@deriving yojson] 43 | 44 | type t = (Selection.t list, [ `Msg of string ]) result [@@deriving yojson] 45 | end 46 | -------------------------------------------------------------------------------- /src/cli/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (public_names ocaml-docs-ci-client epoch) 3 | (package ocaml-docs-ci-client) 4 | (names main epoch) 5 | (libraries 6 | ocaml-docs-ci.pipeline_api 7 | current_rpc 8 | capnp-rpc-unix 9 | logs.cli 10 | logs.fmt 11 | logs.threaded 12 | fmt.cli 13 | fmt.tty 14 | dune-build-info 15 | progress 16 | mtime 17 | mtime.clock.os 18 | timedesc)) 19 | 20 | (mdx 21 | (files ocaml-docs-ci-client.md) 22 | (deps %{bin:ocaml-docs-ci-client}) 23 | (package ocaml-docs-ci-client)) 24 | -------------------------------------------------------------------------------- /src/cli/epoch.md: -------------------------------------------------------------------------------- 1 | # Epoch management tool 2 | 3 | `epoch` - command line tool for managing epochs and storage in ocaml-docs-ci 4 | 5 | _What is an Epoch?_ An Epoch is a collection of package documentation artifacts that are compatiable with each other. They either contain: 6 | 7 | * compiled html for use in ocaml.org aka `html-epoch` 8 | * intermediate OCaml artifacts used to generate docs `linked-epoch` 9 | 10 | A typical directory structure is: 11 | 12 | ```shell skip 13 | $ tree -L 2 14 | . 15 | ├── compile 16 | │   ├── p 17 | │   └── u 18 | ├── content.current 19 | ├── content.live 20 | ├── epoch-097e46a4d589b9e34ed2903beecd1a04 21 | │   └── html-raw 22 | ├── epoch-410108220dc0168ea4d9bd697dfa8e34 23 | │   └── linked 24 | ├── epoch-5daeecab2ad7a2d07a12742d4cc0ab6f 25 | │   └── linked 26 | ├── epoch-ae8bf595b8594945ee40c58377e03730 27 | │   └── html-raw 28 | ├── html-current -> /data/epoch-3d6c8218acb41c692c8219169dcb77df 29 | ├── html-current.log 30 | ├── html-live -> /data/epoch-097e46a4d589b9e34ed2903beecd1a04 31 | ├── html-live.log 32 | ├── linked 33 | ├── linked-current -> /data/epoch-19384d079d5e686e2887866602764c38 34 | ├── linked-current.log 35 | ├── linked-live -> /data/epoch-410108220dc0168ea4d9bd697dfa8e34 36 | ├── linked-live.log 37 | ├── live -> html-live 38 | └── prep 39 | └── universes 40 | 41 | ``` 42 | The primary use of epoch is to trim the directories that exist in `prep` and `compile` that are no longer linked from an active `epoch-*`. These directories can accumulate many Gb of data, causing ocaml-docs-ci pipelines to fail with not enough disk space. 43 | 44 | CLI tool can be installed as `epoch` in the current opam switch. 45 | 46 | ```shell skip 47 | $ dune install epoch 48 | ``` 49 | 50 | It is distributed in the `infra_storage-server` docker image and can be run as: 51 | ```shell skip 52 | DATA=$(docker volume inspect infra_docs-data -f '{{.Mountpoint}}') 53 | $ epoch --base-dir $DATA --dry-run 54 | 55 | # Will print out the directories it has found to be deleted. 56 | 57 | $ epoch --base-dir $DATA 58 | 59 | # Will delete the directories it has found. 60 | ``` 61 | -------------------------------------------------------------------------------- /src/cli/epoch.ml: -------------------------------------------------------------------------------- 1 | let ( / ) = Filename.concat 2 | 3 | module SS = Set.Make (String) 4 | 5 | let remove ~root f files num = 6 | let _ = 7 | SS.fold 8 | (fun del (i, l) -> 9 | f 1; 10 | let pcent = Int.div (100 * i) num in 11 | let nl = if pcent > l then pcent else l in 12 | Unix.sleepf 0.025; 13 | let _ = Sys.command ("rm -rf " ^ (root / del)) in 14 | (i + 1, nl)) 15 | files (0, 0) 16 | in 17 | () 18 | 19 | let print files = 20 | let total = 21 | SS.fold 22 | (fun del i -> 23 | let () = if i < 10 then print_endline @@ Fmt.str "%s" del in 24 | i + 1) 25 | files 0 26 | in 27 | if total >= 10 then print_endline @@ Fmt.str "... plus %i more\n" (total - 10) 28 | 29 | let bar ~total = 30 | let open Progress in 31 | let open Progress.Line in 32 | let frames = [ "⠋"; "⠙"; "⠹"; "⠸"; "⠼"; "⠴"; "⠦"; "⠧"; "⠇"; "⠏" ] in 33 | list 34 | [ 35 | spinner ~frames ~color:(Color.ansi `green) (); 36 | bar ~color:(Color.ansi `blue) ~style:`UTF8 total; 37 | count_to total; 38 | ] 39 | 40 | let main base_dir dry_run silent = 41 | Fmt.set_style_renderer Fmt.stderr `Ansi_tty; 42 | 43 | let path = base_dir in 44 | 45 | let epochs = 46 | Sys.readdir path 47 | |> Array.to_list 48 | |> List.filter (fun file -> String.starts_with ~prefix:"epoch-" file) 49 | |> List.fold_left 50 | (fun acc epoch -> 51 | let full_path = path / epoch in 52 | List.map (fun sf -> full_path / sf) [ "html-raw/u"; "linked/u" ] 53 | @ acc) 54 | [] 55 | |> List.filter Sys.file_exists 56 | in 57 | 58 | let epoch_files = 59 | List.fold_left 60 | (fun s epoch -> Array.fold_right SS.add (Sys.readdir epoch) s) 61 | SS.empty epochs 62 | in 63 | 64 | List.iter 65 | (fun universe -> 66 | let universes = path / universe in 67 | let univ_files = 68 | Array.fold_right SS.add (Sys.readdir universes) SS.empty 69 | in 70 | let debris = SS.diff univ_files epoch_files in 71 | let total = SS.elements debris |> List.length in 72 | let () = print_endline @@ Fmt.str "Files to be deleted in %s" universe in 73 | let () = print debris in 74 | let num = SS.cardinal debris in 75 | if not dry_run then ( 76 | print_endline (Fmt.str "Deleting %i files in %s" num universe); 77 | 78 | match silent with 79 | | false -> 80 | Progress.with_reporter (bar ~total) (fun f -> 81 | remove ~root:universes f debris num) 82 | | true -> remove ~root:universes (fun _ -> ()) debris num)) 83 | [ "prep/universes"; "compile/u" ] 84 | 85 | (* Command-line parsing *) 86 | 87 | open Cmdliner 88 | 89 | let base_dir = 90 | Arg.( 91 | required 92 | @@ opt (some dir) None 93 | @@ info ~docv:"BASE_DIR" 94 | ~doc: 95 | "Base directory containing epochs. eg \ 96 | /var/lib/docker/volumes/infra_docs-data/_data" 97 | [ "base-dir" ]) 98 | 99 | let dry_run = 100 | Arg.( 101 | value 102 | @@ flag 103 | @@ info ~docv:"DRY_RUN" 104 | ~doc: 105 | "If set, only list the files to be deleted but do not deleted them" 106 | [ "dry-run" ]) 107 | 108 | let version = 109 | match Build_info.V1.version () with 110 | | None -> "n/a" 111 | | Some v -> Build_info.V1.Version.to_string v 112 | 113 | let silent = 114 | Arg.( 115 | value 116 | @@ flag 117 | @@ info ~docv:"SILENT" 118 | ~doc:"Run epoch tool silently emitting no progress bars." [ "s" ]) 119 | 120 | let cmd = 121 | let doc = "Epoch pruning" in 122 | let info = Cmd.info "epoch" ~doc ~version in 123 | Cmd.v info Term.(const main $ base_dir $ dry_run $ silent) 124 | 125 | let () = exit @@ Cmd.eval cmd 126 | -------------------------------------------------------------------------------- /src/cli/logging.ml: -------------------------------------------------------------------------------- 1 | let reporter = 2 | let report src level ~over k msgf = 3 | let k _ = 4 | over (); 5 | k () 6 | in 7 | let src = Logs.Src.name src in 8 | msgf @@ fun ?header ?tags:_ fmt -> 9 | Fmt.kpf k Fmt.stdout 10 | ("%a %a @[" ^^ fmt ^^ "@]@.") 11 | Fmt.(styled `Magenta string) 12 | (Printf.sprintf "%14s" src) 13 | Logs_fmt.pp_header (level, header) 14 | in 15 | { Logs.report } 16 | 17 | let init style_renderer level = 18 | Fmt_tty.setup_std_outputs ?style_renderer (); 19 | Logs.set_level level; 20 | Logs.set_reporter reporter 21 | -------------------------------------------------------------------------------- /src/cli/ocaml-docs-ci-client.md: -------------------------------------------------------------------------------- 1 | # Ocaml-docs-ci-client CLI 2 | 3 | ocaml-docs-ci-client - command line tool for interacting with ocaml-docs-ci. 4 | 5 | Running the default command displays basic usage. 6 | ```sh 7 | $ ocaml-docs-ci-client 8 | ocaml-docs-ci-client: required COMMAND name is missing, must be one of 'diff-pipelines', 'health-check', 'status', 'status-by-pipeline' or 'steps'. 9 | Usage: ocaml-docs-ci-client COMMAND … 10 | Try 'ocaml-docs-ci-client --help' for more information. 11 | [124] 12 | ``` 13 | 14 | Runnning the help command brings up the manpage. 15 | 16 | ```sh 17 | $ ocaml-docs-ci-client --help=plain 18 | NAME 19 | ocaml-docs-ci-client - Cli client for ocaml-docs-ci. 20 | 21 | SYNOPSIS 22 | ocaml-docs-ci-client COMMAND … 23 | 24 | DESCRIPTION 25 | Command line client for ocaml-docs-ci. 26 | 27 | COMMANDS 28 | diff-pipelines [--ci-cap=CAP] [--dry-run] [OPTION]… 29 | Packages that have started failing in the latest pipeline. 30 | 31 | health-check [--ci-cap=CAP] [--dry-run] [OPTION]… 32 | Information about a pipeline. 33 | 34 | status [--ci-cap=CAP] [--dry-run] [--package=package] [OPTION]… 35 | Build status of a package. 36 | 37 | status-by-pipeline [--ci-cap=CAP] [--dry-run] [--package=package] 38 | [OPTION]… 39 | Build status of a package in the two most recent pipeline runs. 40 | 41 | steps [--ci-cap=CAP] [--dry-run] [--package=package] [OPTION]… 42 | Build steps of a package. 43 | 44 | COMMON OPTIONS 45 | --help[=FMT] (default=auto) 46 | Show this help in format FMT. The value FMT must be one of auto, 47 | pager, groff or plain. With auto, the format is pager or plain 48 | whenever the TERM env var is dumb or undefined. 49 | 50 | EXIT STATUS 51 | ocaml-docs-ci-client exits with: 52 | 53 | 0 on success. 54 | 55 | 123 on indiscriminate errors reported on standard error. 56 | 57 | 124 on command line parsing errors. 58 | 59 | 125 on unexpected internal errors (bugs). 60 | 61 | ``` 62 | 63 | Running the status command queries the current status of a package, showing all versions, or a specific package version. 64 | 65 | 66 | ```sh 67 | $ ocaml-docs-ci-client status --dry-run --ci-cap="capnp://sha-256:lsLPZ6Q4jYcTxiitvBg02B3xfds7KwwJ4FIptUe2qew@localhost:9080/BuaVTt00ZvXq83VUGrCD2I_qw-e9POjLoGmgHfxMtGI" --package="fmt" 68 | ... 69 | $ ocaml-docs-ci-client status --dry-run --ci-cap="capnp://sha-256:lsLPZ6Q4jYcTxiitvBg02B3xfds7KwwJ4FIptUe2qew@localhost:9080/BuaVTt00ZvXq83VUGrCD2I_qw-e9POjLoGmgHfxMtGI" --package="fmt" --version="0.9.0" 70 | ... 71 | ``` 72 | 73 | You can query the specific steps for a package version as: 74 | 75 | ```sh 76 | $ ocaml-docs-ci-client steps --dry-run --ci-cap="capnp://sha-256:lsLPZ6Q4jYcTxiitvBg02B3xfds7KwwJ4FIptUe2qew@localhost:9080/BuaVTt00ZvXq83VUGrCD2I_qw-e9POjLoGmgHfxMtGI" --package="fmt" --version="0.9.0" 77 | ... 78 | ``` 79 | 80 | Health check shows meta-data about the last 2 pipeline runs. It prints out the voodoo commit SHAs, epochs, and the number of failing packages, passing packages and running packages for the latest and latest-but-one pipelines. 81 | ```sh skip 82 | $ ocaml-docs-ci-client health-check --dry-run --ci-cap="capnp://sha-256:lsLPZ6Q4jYcTxiitvBg02B3xfds7KwwJ4FIptUe2qew@localhost:9080/BuaVTt00ZvXq83VUGrCD2I_qw-e9POjLoGmgHfxMtGI" 83 | ... 84 | ``` 85 | 86 | ```sh skip 87 | $ ocaml-docs-ci-client health-check --ci-cap="capnp://sha-256:lsLPZ6Q4jYcTxiitvBg02B3xfds7KwwJ4FIptUe2qew@localhost:9080/BuaVTt00ZvXq83VUGrCD2I_qw-e9POjLoGmgHfxMtGI" | jq . 88 | { 89 | "latest": { 90 | "epoch_html": "3d6c8218acb41c692c8219169dcb77df", 91 | "epoch_linked": "19384d079d5e686e2887866602764c38", 92 | "voodoo_do": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 93 | "voodoo_prep": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 94 | "voodoo_gen": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 95 | "voodoo_repo": "https://github.com/ocaml-doc/voodoo.git", 96 | "voodoo_branch": "main", 97 | "failed_packages": 25255, 98 | "running_packages": 30, 99 | "passed_packages": 0 100 | }, 101 | "latest-but-one": { 102 | "epoch_html": "097e46a4d589b9e34ed2903beecd1a04", 103 | "epoch_linked": "410108220dc0168ea4d9bd697dfa8e34", 104 | "voodoo_do": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 105 | "voodoo_prep": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 106 | "voodoo_gen": "67ccabec49b5f4d24147839291fcae7c19d3e8c9", 107 | "voodoo_repo": "https://github.com/ocaml-doc/voodoo.git", 108 | "voodoo_branch": "main", 109 | "failed_packages": 1205, 110 | "running_packages": 126, 111 | "passed_packages": 23954 112 | } 113 | } 114 | ``` 115 | 116 | Diff pipelines shows the changes that have happened between two pipeline runs (epochs), showing new packages added or package documentation that has failed to build. 117 | This is useful to understand the health of the current pipeline and whether it can be promoted to live (and used by ocaml.org). 118 | 119 | ```sh 120 | $ ocaml-docs-ci-client diff-pipelines --dry-run --ci-cap="capnp://sha-256:lsLPZ6Q4jYcTxiitvBg02B3xfds7KwwJ4FIptUe2qew@localhost:9080/BuaVTt00ZvXq83VUGrCD2I_qw-e9POjLoGmgHfxMtGI" 121 | ... 122 | ``` 123 | 124 | We can then query the difference between specific packages in the last two pipeline runs: 125 | 126 | ```sh 127 | $ ocaml-docs-ci-client status-by-pipeline --dry-run --ci-cap="capnp://sha-256:lsLPZ6Q4jYcTxiitvBg02B3xfds7KwwJ4FIptUe2qew@localhost:9080/BuaVTt00ZvXq83VUGrCD2I_qw-e9POjLoGmgHfxMtGI" 128 | ... 129 | ``` 130 | 131 | For example on live pipeline it might show this for the `lwt` package: 132 | ```sh skip 133 | 134 | $ ocaml-docs-ci-client status-by-pipeline --ci-cap="capnp://sha-256:lsLPZ6Q4jYcTxiitvBg02B3xfds7KwwJ4FIptUe2qew@localhost:9080/BuaVTt00ZvXq83VUGrCD2I_qw-e9POjLoGmgHfxMtGI" -p lwt | jq . 135 | { 136 | "note": "Status of package lwt", 137 | "latest_pipeline": [ 138 | { 139 | "version": "5.6.1", 140 | "status": "failed" 141 | }, 142 | { 143 | "version": "5.7.0", 144 | "status": "failed" 145 | } 146 | ], 147 | "latest_but_one_pipeline": [ 148 | 149 | { 150 | "version": "5.6.1", 151 | "status": "passed" 152 | }, 153 | { 154 | "version": "5.7.0", 155 | "status": "passed" 156 | } 157 | ] 158 | } 159 | ``` 160 | 161 | ## Unimplemented 162 | 163 | Show the build status of a single job: 164 | ```sh skip 165 | $ ocaml-docs-ci-client status --ci-cap --job 166 | ``` 167 | 168 | Display logs for an individual job (with a URL) 169 | ```sh skip 170 | $ ocaml-docs-ci-client logs --ci-cap --job 171 | ``` 172 | 173 | Rebuild a specific job 174 | ```sh skip 175 | $ ocaml-docs-ci rebuild --ci-cap --job 176 | ``` 177 | 178 | ## Reference 179 | 180 | https://github.com/ocaml/infrastructure/wiki/Using-the-opam-ci-tool 181 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (public_name ocaml-docs-ci) 3 | (package ocaml-docs-ci) 4 | (name ocaml_docs_ci) 5 | (libraries 6 | current 7 | current.cache 8 | current_git 9 | current_github 10 | current_web 11 | current_docker 12 | astring 13 | dockerfile 14 | cmdliner 15 | fmt.tty 16 | logs.fmt 17 | logs.cli 18 | lwt 19 | lwt.unix 20 | memtrace 21 | obuilder-spec 22 | opam-file-format 23 | docs_ci_pipelines 24 | docs_ci_lib 25 | dune-build-info 26 | mirage-crypto-rng.unix 27 | prometheus-app.unix) 28 | (preprocess 29 | (pps ppx_deriving_yojson))) 30 | -------------------------------------------------------------------------------- /src/lib/compile.mli: -------------------------------------------------------------------------------- 1 | (** Compilation step 2 | 3 | The documentation compilation is done as an ocluster. It takes for input one 4 | prep/ folder and its compiled dependencies. It uses `voodoo-do` to perform 5 | the compilation, link and html generation steps, outputting the results in 6 | the compile/ and html/ folders. *) 7 | 8 | type hashes = { compile_hash : string; linked_hash : string } 9 | 10 | type t 11 | (** A compiled package *) 12 | 13 | val hashes : t -> hashes 14 | (** Hash of the compiled artifacts *) 15 | 16 | val blessing : t -> Package.Blessing.t 17 | (** A blessed package is compiled in the compile/packages/... hierarchy, whereas 18 | a non-blessed package is compiled in the compile/universes/... hierarchy *) 19 | 20 | val package : t -> Package.t 21 | (** The compiled package *) 22 | 23 | val extract_hashes : 24 | (Storage.id_hash option * Storage.id_hash option) * string list -> 25 | string -> 26 | (Storage.id_hash option * Storage.id_hash option) * string list 27 | (** Function used to parse log lines *) 28 | 29 | val v : 30 | generation:Epoch.t Current.t -> 31 | config:Config.t -> 32 | name:string -> 33 | voodoo:Voodoo.Do.t Current.t -> 34 | blessing:Package.Blessing.t Current.t -> 35 | deps:t list Current.t -> 36 | Prep.t Current.t -> 37 | t Current.t 38 | (** [v ~voodoo ~cache ~blessed ~deps prep] is the ocurrent component in charge 39 | of building [prep], using the previously-compiled [deps]. [blessed] contains 40 | the information to figure out if [prep] is a blessed package or not. [cache] 41 | contains the artifacts cache metadata to track eventual changes. [voodoo] is 42 | the voodoo-do tool tracker. 43 | 44 | Notably, if compilation artifacts already exists, then the job is a no-op. *) 45 | -------------------------------------------------------------------------------- /src/lib/config.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | 3 | module Ssh = struct 4 | type t = { 5 | host : string; 6 | user : string; 7 | port : int; 8 | private_key : string; 9 | private_key_file : string; 10 | public_key : string; 11 | folder : string; 12 | } 13 | 14 | let named f = Cmdliner.Term.(app (const f)) 15 | 16 | let ssh_host = 17 | Arg.required 18 | @@ Arg.opt Arg.(some string) None 19 | @@ Arg.info ~doc:"SSH storage server host" ~docv:"HOST" [ "ssh-host" ] 20 | |> named (fun x -> `SSH_host x) 21 | 22 | let ssh_user = 23 | Arg.required 24 | @@ Arg.opt Arg.(some string) None 25 | @@ Arg.info ~doc:"SSH storage server user" ~docv:"USER" [ "ssh-user" ] 26 | |> named (fun x -> `SSH_user x) 27 | 28 | let ssh_port = 29 | Arg.required 30 | @@ Arg.opt Arg.(some int) (Some 22) 31 | @@ Arg.info ~doc:"SSH storage server port" ~docv:"PORT" [ "ssh-port" ] 32 | |> named (fun x -> `SSH_port x) 33 | 34 | let ssh_privkey = 35 | Arg.required 36 | @@ Arg.opt Arg.(some string) None 37 | @@ Arg.info ~doc:"SSH private key file" ~docv:"FILE" [ "ssh-privkey" ] 38 | |> named (fun x -> `SSH_privkey x) 39 | 40 | let ssh_pubkey = 41 | Arg.required 42 | @@ Arg.opt Arg.(some string) None 43 | @@ Arg.info ~doc:"SSH public key file" ~docv:"FILE" [ "ssh-pubkey" ] 44 | |> named (fun x -> `SSH_pubkey x) 45 | 46 | let ssh_folder = 47 | Arg.required 48 | @@ Arg.opt Arg.(some string) None 49 | @@ Arg.info ~doc:"SSH storage folder" ~docv:"FILE" [ "ssh-folder" ] 50 | |> named (fun x -> `SSH_folder x) 51 | 52 | let load_file path = 53 | try 54 | let ch = open_in path in 55 | let len = in_channel_length ch in 56 | let data = really_input_string ch len in 57 | close_in ch; 58 | data 59 | with ex -> 60 | if Sys.file_exists path then 61 | failwith @@ Fmt.str "Error loading %S: %a" path Fmt.exn ex 62 | else failwith @@ Fmt.str "File %S does not exist" path 63 | 64 | let v (`SSH_host host) (`SSH_user user) (`SSH_port port) (`SSH_pubkey pubkey) 65 | (`SSH_privkey privkey) (`SSH_folder folder) = 66 | { 67 | host; 68 | user; 69 | port; 70 | private_key = load_file privkey; 71 | private_key_file = 72 | Fpath.( 73 | (Bos.OS.Dir.current () |> Result.get_ok) 74 | // (of_string privkey |> Result.get_ok) 75 | |> to_string); 76 | public_key = load_file pubkey; 77 | folder; 78 | } 79 | 80 | let cmdliner = 81 | Term.( 82 | const v 83 | $ ssh_host 84 | $ ssh_user 85 | $ ssh_port 86 | $ ssh_pubkey 87 | $ ssh_privkey 88 | $ ssh_folder) 89 | 90 | let config t = 91 | Fmt.str 92 | {|Host %s 93 | IdentityFile ~/.ssh/id_rsa 94 | Port %d 95 | User %s 96 | StrictHostKeyChecking=no 97 | GlobalKnownHostsFile=/dev/null 98 | UserKnownHostsFile=/dev/null 99 | ConnectTimeout=10 100 | |} 101 | t.host t.port t.user 102 | 103 | let secrets = 104 | Obuilder_spec.Secret. 105 | [ 106 | v ~target:"/home/opam/.ssh/id_rsa" "ssh_privkey"; 107 | v ~target:"/home/opam/.ssh/id_rsa.pub" "ssh_pubkey"; 108 | v ~target:"/home/opam/.ssh/config" "ssh_config"; 109 | ] 110 | 111 | let secrets_values t = 112 | [ 113 | ("ssh_privkey", t.private_key); 114 | ("ssh_pubkey", t.public_key); 115 | ("ssh_config", config t); 116 | ] 117 | 118 | let storage_folder t = t.folder 119 | let host t = t.host 120 | let user t = t.user 121 | let priv_key_file t = Fpath.v t.private_key_file 122 | let port t = t.port 123 | 124 | let digest t = 125 | Fmt.str "%s-%s-%d-%s" t.host t.user t.port t.folder 126 | |> Digest.string 127 | |> Digest.to_hex 128 | end 129 | 130 | type t = { 131 | voodoo_branch : string; 132 | voodoo_repo : string; 133 | jobs : int; 134 | track_packages : string list; 135 | take_n_last_versions : int option; 136 | ocluster_connection_prep : Current_ocluster.Connection.t; 137 | ocluster_connection_do : Current_ocluster.Connection.t; 138 | ocluster_connection_gen : Current_ocluster.Connection.t; 139 | ssh : Ssh.t; 140 | } 141 | 142 | let voodoo_branch = 143 | Arg.value 144 | @@ Arg.opt Arg.(string) "main" 145 | @@ Arg.info ~doc:"Voodoo branch to watch" ~docv:"VOODOO_BRANCH" 146 | [ "voodoo-branch" ] 147 | 148 | let voodoo_repo = 149 | Arg.value 150 | @@ Arg.opt Arg.string "https://github.com/ocaml-doc/voodoo.git" 151 | @@ Arg.info ~doc:"Voodoo repository to watch" ~docv:"VOODOO_REPO" 152 | [ "voodoo-repo" ] 153 | 154 | let cap_file = 155 | Arg.required 156 | @@ Arg.opt Arg.(some string) None 157 | @@ Arg.info ~doc:"Ocluster capability file" ~docv:"FILE" 158 | [ "ocluster-submission" ] 159 | 160 | let jobs = 161 | Arg.required 162 | @@ Arg.opt Arg.(some int) (Some 8) 163 | @@ Arg.info ~doc:"Number of parallel jobs on the host machine (for solver)" 164 | ~docv:"JOBS" [ "jobs"; "j" ] 165 | 166 | let track_packages = 167 | Arg.value 168 | @@ Arg.opt Arg.(list string) [] 169 | @@ Arg.info ~doc:"Filter the name of packages to track. " ~docv:"PKGS" 170 | [ "filter" ] 171 | 172 | let take_n_last_versions = 173 | Arg.value 174 | @@ Arg.opt Arg.(some int) None 175 | @@ Arg.info ~doc:"Limit the number of versions" ~docv:"LIMIT" [ "limit" ] 176 | 177 | let v voodoo_branch voodoo_repo cap_file jobs track_packages 178 | take_n_last_versions ssh = 179 | let vat = Capnp_rpc_unix.client_only_vat () in 180 | let cap = Capnp_rpc_unix.Cap_file.load vat cap_file |> Result.get_ok in 181 | 182 | let ocluster_connection_prep = 183 | Current_ocluster.Connection.create ~max_pipeline:100 cap 184 | in 185 | let ocluster_connection_do = 186 | Current_ocluster.Connection.create ~max_pipeline:100 cap 187 | in 188 | let ocluster_connection_gen = 189 | Current_ocluster.Connection.create ~max_pipeline:100 cap 190 | in 191 | 192 | { 193 | voodoo_branch; 194 | voodoo_repo; 195 | jobs; 196 | track_packages; 197 | take_n_last_versions; 198 | ocluster_connection_prep; 199 | ocluster_connection_do; 200 | ocluster_connection_gen; 201 | ssh; 202 | } 203 | 204 | let cmdliner = 205 | Term.( 206 | const v 207 | $ voodoo_branch 208 | $ voodoo_repo 209 | $ cap_file 210 | $ jobs 211 | $ track_packages 212 | $ take_n_last_versions 213 | $ Ssh.cmdliner) 214 | 215 | let pool _ = "linux-x86_64" 216 | let jobs t = t.jobs 217 | let voodoo_branch t = t.voodoo_branch 218 | let voodoo_repo t = t.voodoo_repo 219 | let track_packages t = t.track_packages 220 | let take_n_last_versions t = t.take_n_last_versions 221 | let ocluster_connection_do t = t.ocluster_connection_do 222 | let ocluster_connection_prep t = t.ocluster_connection_prep 223 | let ocluster_connection_gen t = t.ocluster_connection_gen 224 | let ssh t = t.ssh 225 | -------------------------------------------------------------------------------- /src/lib/config.mli: -------------------------------------------------------------------------------- 1 | module Ssh : sig 2 | type t 3 | 4 | val secrets : Obuilder_spec.Secret.t list 5 | val secrets_values : t -> (string * string) list 6 | val host : t -> string 7 | val user : t -> string 8 | val priv_key_file : t -> Fpath.t 9 | val port : t -> int 10 | val storage_folder : t -> string 11 | 12 | val digest : t -> string 13 | (** Updated when the storage location changes *) 14 | end 15 | 16 | type t 17 | 18 | val cmdliner : t Cmdliner.Term.t 19 | val ssh : t -> Ssh.t 20 | 21 | val pool : t -> string 22 | (** The ocluster pool to use *) 23 | 24 | val voodoo_repo : t -> string 25 | val voodoo_branch : t -> string 26 | 27 | val ocluster_connection_prep : t -> Current_ocluster.Connection.t 28 | (** Connection to the cluster for Prep *) 29 | 30 | val ocluster_connection_do : t -> Current_ocluster.Connection.t 31 | (** Connection to the cluster for Do *) 32 | 33 | val ocluster_connection_gen : t -> Current_ocluster.Connection.t 34 | (** Connection to the cluster for Gen *) 35 | 36 | val jobs : t -> int 37 | (** Number of jobs that can be spawned for the steps that are locally executed. *) 38 | 39 | val track_packages : t -> string list 40 | (** List of packages to track (or all packages if the list is empty) *) 41 | 42 | val take_n_last_versions : t -> int option 43 | (** Number of versions to take (None for all) *) 44 | -------------------------------------------------------------------------------- /src/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name docs_ci_lib) 3 | (package ocaml-docs-ci) 4 | (libraries 5 | current 6 | current.cache 7 | current_github 8 | current_git 9 | current_web 10 | current_docker 11 | astring 12 | dockerfile 13 | cmdliner 14 | digestif 15 | fmt.tty 16 | logs.fmt 17 | git-unix 18 | lwt 19 | lwt.unix 20 | obuilder-spec 21 | opam-file-format 22 | capnp-rpc-lwt 23 | capnp-rpc-unix 24 | current_ocluster 25 | opam-0install 26 | solver_api 27 | ocaml-version 28 | omigrate 29 | omigrate.sqlite3) 30 | (preprocess 31 | (pps ppx_deriving_yojson ppx_deriving.std))) 32 | -------------------------------------------------------------------------------- /src/lib/epoch.ml: -------------------------------------------------------------------------------- 1 | type t = { voodoo : Voodoo.t } 2 | 3 | let version = "v1" 4 | let v voodoo = { voodoo } 5 | 6 | type stage = [ `Linked | `Html ] 7 | 8 | let digest stage t = 9 | let key = 10 | match stage with 11 | | `Html -> 12 | Fmt.str "%s:%s:%s:%s" version 13 | Voodoo.Do.(v t.voodoo |> digest) 14 | Voodoo.Prep.(v t.voodoo |> digest) 15 | Voodoo.Gen.(v t.voodoo |> digest) 16 | | `Linked -> 17 | Fmt.str "%s:%s:%s" version 18 | Voodoo.Do.(v t.voodoo |> digest) 19 | Voodoo.Prep.(v t.voodoo |> digest) 20 | in 21 | key |> Digest.string |> Digest.to_hex 22 | 23 | let pp f t = 24 | Fmt.pf f "docs-ci: %s\nvoodoo do: %a\nvoodoo prep: %a\nvoodoo gen: %a" version 25 | Current_git.Commit_id.pp 26 | Voodoo.Do.(v t.voodoo |> commit) 27 | Current_git.Commit_id.pp 28 | Voodoo.Prep.(v t.voodoo |> commit) 29 | Current_git.Commit_id.pp 30 | Voodoo.Gen.(v t.voodoo |> commit) 31 | -------------------------------------------------------------------------------- /src/lib/epoch.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val v : Voodoo.t -> t 4 | 5 | type stage = [ `Linked | `Html ] 6 | 7 | val digest : stage -> t -> string 8 | val pp : t Fmt.t 9 | -------------------------------------------------------------------------------- /src/lib/html.ml: -------------------------------------------------------------------------------- 1 | type hashes = { html_raw_hash : string } [@@deriving yojson] 2 | type t = { package : Package.t; blessing : Package.Blessing.t; hashes : hashes } 3 | 4 | let hashes t = t.hashes 5 | let blessing t = t.blessing 6 | let package t = t.package 7 | 8 | let spec ~ssh ~generation ~base ~voodoo ~blessed compiled = 9 | let open Obuilder_spec in 10 | let package = Compile.package compiled in 11 | let linked_folder = Storage.folder (Linked (generation, blessed)) package in 12 | let raw_folder = Storage.folder (HtmlRaw (generation, blessed)) package in 13 | let opam = package |> Package.opam in 14 | let name = opam |> OpamPackage.name_to_string in 15 | let version = opam |> OpamPackage.version_to_string in 16 | let tools = Voodoo.Gen.spec ~base voodoo |> Spec.finish in 17 | base 18 | |> Spec.children ~name:"tools" tools 19 | |> Spec.add 20 | [ 21 | workdir "/home/opam/docs/"; 22 | run "sudo chown opam:opam . "; 23 | (* Import odoc and voodoo-do *) 24 | copy ~from:(`Build "tools") 25 | [ "/home/opam/odoc"; "/home/opam/voodoo-gen" ] 26 | ~dst:"/home/opam/"; 27 | run 28 | "mv ~/odoc $(opam config var bin)/odoc && cp ~/voodoo-gen $(opam \ 29 | config var bin)/voodoo-gen"; 30 | (* obtain the linked folder *) 31 | run ~network:Misc.network ~secrets:Config.Ssh.secrets "%s" 32 | @@ Misc.Cmd.list 33 | [ 34 | Fmt.str "rsync -aR %s:%s/./%s ." (Config.Ssh.host ssh) 35 | (Config.Ssh.storage_folder ssh) 36 | (Fpath.to_string linked_folder); 37 | "find . -name '*.tar' -exec tar -xvf {} \\;"; 38 | "find . -type d -empty -delete"; 39 | ]; 40 | (* Run voodoo-gen *) 41 | workdir 42 | (Fpath.to_string (Storage.Base.generation_folder `Linked generation)); 43 | run 44 | "OCAMLRUNPARAM=b opam exec -- /home/opam/voodoo-gen -o %s -n %s \ 45 | --pkg-version %s" 46 | (Fpath.to_string (Storage.Base.folder (HtmlRaw generation))) 47 | name version; 48 | (* Extract compile output - cache needs to be invalidated if we want to be able to read the logs *) 49 | run ~network:Misc.network ~secrets:Config.Ssh.secrets "%s" 50 | @@ Misc.Cmd.list 51 | [ 52 | Fmt.str "echo '%f'" (Random.float 1.); 53 | Fmt.str "mkdir -p %a" Fpath.pp raw_folder; 54 | (* Extract raw and html output *) 55 | Fmt.str "rsync -aR ./%s %s:%s/." 56 | (Fpath.to_string raw_folder) 57 | (Config.Ssh.host ssh) 58 | (Config.Ssh.storage_folder ssh); 59 | (* Print hashes *) 60 | Fmt.str "set '%s' raw; %s" 61 | (Fpath.to_string raw_folder) 62 | (Storage.hash_command ~prefix:"RAW"); 63 | ]; 64 | ] 65 | 66 | let or_default a = function None -> a | b -> b 67 | 68 | module Gen = struct 69 | type t = Epoch.t 70 | 71 | let id = "voodoo-gen" 72 | 73 | module Value = struct 74 | type t = hashes [@@deriving yojson] 75 | 76 | let marshal t = t |> to_yojson |> Yojson.Safe.to_string 77 | let unmarshal t = t |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok 78 | end 79 | 80 | module Key = struct 81 | type t = { 82 | config : Config.t; 83 | compile : Compile.t; 84 | voodoo : Voodoo.Gen.t; 85 | base : Spec.t; 86 | } 87 | 88 | let key { config = _; compile; voodoo; base = _ } = 89 | Fmt.str "v6-%s-%s-%s" 90 | (Compile.package compile |> Package.digest) 91 | (Compile.hashes compile).linked_hash (Voodoo.Gen.digest voodoo) 92 | 93 | let digest t = key t |> Digest.string |> Digest.to_hex 94 | end 95 | 96 | let pp f Key.{ compile; _ } = 97 | Fmt.pf f "Voodoo gen %a" Package.pp (Compile.package compile) 98 | 99 | let auto_cancel = true 100 | 101 | let build generation job (Key.{ compile; voodoo; config; base } as key) = 102 | let open Lwt.Syntax in 103 | let ( let** ) = Lwt_result.bind in 104 | let blessed = Compile.blessing compile in 105 | Current.Job.log job "Cache digest: %s" (Key.key key); 106 | let spec = 107 | spec ~ssh:(Config.ssh config) ~generation ~voodoo ~base ~blessed compile 108 | in 109 | let action = Misc.to_ocluster_submission spec in 110 | let cache_hint = "docs-universe-gen" in 111 | let build_pool = 112 | Current_ocluster.Connection.pool ~job ~pool:(Config.pool config) ~action 113 | ~cache_hint 114 | ~secrets:(Config.Ssh.secrets_values (Config.ssh config)) 115 | (Config.ocluster_connection_gen config) 116 | in 117 | let* build_job = 118 | Current.Job.start_with ~pool:build_pool ~level:Mostly_harmless job 119 | in 120 | Current.Job.log job "Using cache hint %S" cache_hint; 121 | (* TODO Log job spec here! *) 122 | Current.Job.write job 123 | (Fmt.str 124 | "@.To reproduce locally:@.@.cat > prep.spec \ 125 | <<'END-OF-SPEC'@.\o033[34m%s\o033[0m@.END-OF-SPEC@.@.ocluster-client \ 126 | submit-obuilder --local-file prep.spec \\@.--pool linux-x86_64 \ 127 | --connect ocluster-submission.cap --cache-hint %s \\@.--secret \ 128 | ssh_privkey:id_rsa --secret ssh_pubkey:id_rsa.pub--secret \ 129 | ssh_config:ssh_config@.@." 130 | (Spec.to_spec spec) cache_hint); 131 | Capnp_rpc_lwt.Capability.with_ref build_job @@ fun build_job -> 132 | let** _ = Current_ocluster.Connection.run_job ~job build_job in 133 | let extract_hashes v_html_raw line = 134 | (* some early stopping could be done here *) 135 | let html_raw = 136 | Storage.parse_hash ~prefix:"RAW" line |> or_default v_html_raw 137 | in 138 | html_raw 139 | in 140 | let** html_raw = Misc.fold_logs build_job extract_hashes None in 141 | try 142 | let html_raw = Option.get html_raw in 143 | Lwt.return_ok { html_raw_hash = html_raw.hash } 144 | with Invalid_argument _ -> 145 | Lwt.return_error (`Msg "Gen: failed to parse output") 146 | end 147 | 148 | module GenCache = Current_cache.Make (Gen) 149 | 150 | let v ~generation ~config ~name ~voodoo compile = 151 | let open Current.Syntax in 152 | Current.component "html %s" name 153 | |> let> compile 154 | and> voodoo 155 | and> generation 156 | and> base = Misc.default_base_image in 157 | let blessing = Compile.blessing compile in 158 | let package = Compile.package compile in 159 | let output = 160 | GenCache.get generation Gen.Key.{ compile; voodoo; config; base } 161 | in 162 | Current.Primitive.map_result 163 | (Result.map (fun hashes -> { package; blessing; hashes })) 164 | output 165 | -------------------------------------------------------------------------------- /src/lib/html.mli: -------------------------------------------------------------------------------- 1 | (** Compilation step 2 | 3 | The documentation compilation is done as an ocluster. It takes for input one 4 | prep/ folder and its compiled dependencies. It uses `voodoo-do` to perform 5 | the compilation, link and html generation steps, outputting the results in 6 | the compile/ and html/ folders. *) 7 | 8 | type hashes = { html_raw_hash : string } 9 | 10 | type t 11 | (** A compiled package *) 12 | 13 | val hashes : t -> hashes 14 | (** Hash of the compiled artifacts *) 15 | 16 | val blessing : t -> Package.Blessing.t 17 | (** A blessed package is compiled in the compile/p/... hierarchy, whereas a 18 | non-blessed package is compiled in the compile/u/... hierarchy *) 19 | 20 | val package : t -> Package.t 21 | (** The compiled package *) 22 | 23 | val v : 24 | generation:Epoch.t Current.t -> 25 | config:Config.t -> 26 | name:string -> 27 | voodoo:Voodoo.Gen.t Current.t -> 28 | Compile.t Current.t -> 29 | t Current.t 30 | -------------------------------------------------------------------------------- /src/lib/init.ml: -------------------------------------------------------------------------------- 1 | open Config 2 | 3 | let override = false 4 | 5 | let ssh_run_prefix ssh = 6 | let remote = Ssh.user ssh ^ "@" ^ Ssh.host ssh in 7 | Bos.Cmd.( 8 | v "ssh" 9 | % "-o" 10 | % "StrictHostKeyChecking=no" 11 | % "-p" 12 | % (Ssh.port ssh |> string_of_int) 13 | % "-i" 14 | % p (Ssh.priv_key_file ssh) 15 | % remote) 16 | 17 | let setup ssh = 18 | Log.app (fun f -> f "Checking storage server status.."); 19 | let ensure_program program = Fmt.str "%s --version" program in 20 | let ensure_dir dir = 21 | let path = Fpath.(v (Ssh.storage_folder ssh) / dir) in 22 | Fmt.str "mkdir -p %a" Fpath.pp path 23 | in 24 | let run cmd = 25 | let cmd = Bos.Cmd.(ssh_run_prefix ssh % cmd) in 26 | Bos.OS.Cmd.run cmd 27 | in 28 | 29 | if override then Ok () 30 | else 31 | let ( let* ) = Result.bind in 32 | let ( let+ ) a b = Result.map b a in 33 | let* () = ensure_program "rsync" |> run in 34 | let* () = ensure_dir "prep" |> run in 35 | let* () = ensure_dir "compile" |> run in 36 | let+ () = ensure_dir "linked" |> run in 37 | Log.app (fun f -> f "..OK!") 38 | -------------------------------------------------------------------------------- /src/lib/init.mli: -------------------------------------------------------------------------------- 1 | val setup : Config.Ssh.t -> (unit, Rresult.R.msg) result 2 | -------------------------------------------------------------------------------- /src/lib/jobs.ml: -------------------------------------------------------------------------------- 1 | type t = { install : Package.t; prep : Package.t list } 2 | (** A job is one package to install, from which a set of prep folders can be 3 | derived. *) 4 | 5 | let pp f (t : t) = Fmt.pf f "%a" Package.pp t.install 6 | let compare (a : t) (b : t) = Package.compare a.install b.install 7 | 8 | module StringSet = Set.Make (String) 9 | 10 | let worthiness t = t |> Package.universe |> Package.Universe.deps |> List.length 11 | 12 | (** The goal is to find the minimal number of jobs that builds all the target 13 | packages. This is actually the Set Cover problem. NP-hard :( let's go 14 | greedy. https://en.wikipedia.org/wiki/Set_cover_problem 15 | 16 | package.version.universe -> 1 2 3 4 5 task -> 1 [ o x o x o x x x ] 2 17 | [ o o x o x o o o ] 3 [ o o o x x x x x ] 4 [ o x x x o x x x ] 18 | 19 | 1) Sort by decreasing universe size, and create a new job as long as there 20 | is some useful package. 2) For each job, sort by increasing universe size 21 | and set `prep` as the never previously encountered packages in the universe. *) 22 | let schedule ~(targets : Package.Set.t) jobs : t list = 23 | Printf.printf "Schedule %d\n" (List.length jobs); 24 | let targets_digests = 25 | targets |> Package.Set.to_seq |> Seq.map Package.digest |> StringSet.of_seq 26 | in 27 | let jobs = 28 | jobs 29 | |> List.rev_map (fun pkg -> 30 | let install_set = 31 | pkg 32 | |> Package.all_deps 33 | |> List.rev_map Package.digest 34 | |> StringSet.of_list 35 | in 36 | (pkg, install_set)) 37 | |> List.sort (fun (_, s1) (_, s2) -> 38 | StringSet.cardinal s2 - StringSet.cardinal s1) 39 | (* Sort in decreasing order in universe size *) 40 | in 41 | let remaining_targets = ref targets_digests in 42 | let check_and_add_target (pkg, install_set) = 43 | let useful_packages = StringSet.inter !remaining_targets install_set in 44 | match StringSet.cardinal useful_packages with 45 | | 0 -> None 46 | | _ -> 47 | remaining_targets := StringSet.diff !remaining_targets useful_packages; 48 | Some (pkg, install_set) 49 | in 50 | let to_install = List.filter_map check_and_add_target jobs in 51 | let remaining_targets = ref targets_digests in 52 | let create_job (pkg, install_set) = 53 | let useful_packages = StringSet.inter !remaining_targets install_set in 54 | remaining_targets := StringSet.diff !remaining_targets useful_packages; 55 | { 56 | install = pkg; 57 | prep = 58 | Package.all_deps pkg 59 | |> List.filter (fun elt -> 60 | StringSet.mem (Package.digest elt) useful_packages); 61 | } 62 | in 63 | to_install 64 | |> List.sort (fun (_, s1) (_, s2) -> 65 | StringSet.cardinal s1 - StringSet.cardinal s2) 66 | (* Sort in increasing order in universe size *) 67 | |> List.rev_map create_job 68 | -------------------------------------------------------------------------------- /src/lib/live.ml: -------------------------------------------------------------------------------- 1 | module Ssh = Config.Ssh 2 | 3 | let set_current ~ssh name kind generation = 4 | let open Current.Syntax in 5 | Current.component "Set current folder" 6 | |> let> generation in 7 | let new_generation_folder = 8 | Storage.Base.generation_folder kind generation 9 | in 10 | let storage_folder = 11 | Fpath.(of_string (Ssh.storage_folder ssh) |> Result.get_ok) 12 | in 13 | let target = Fpath.(storage_folder // new_generation_folder) in 14 | let name = Fpath.(storage_folder / (name ^ "-current")) in 15 | Symlink.remote_symbolic_link ~level:Harmless ~ssh ~target ~name () 16 | 17 | let set_live ~ssh name kind generation = 18 | let open Current.Syntax in 19 | Current.component "Set live folder" 20 | |> let> generation in 21 | let new_generation_folder = 22 | Storage.Base.generation_folder kind generation 23 | in 24 | let storage_folder = 25 | Fpath.(of_string (Ssh.storage_folder ssh) |> Result.get_ok) 26 | in 27 | let target = Fpath.(storage_folder // new_generation_folder) in 28 | let name = Fpath.(storage_folder / (name ^ "-live")) in 29 | Symlink.remote_symbolic_link ~level:Dangerous ~ssh ~target ~name () 30 | 31 | let set_to ~ssh name kind generation = 32 | Current.all 33 | [ 34 | set_current ~ssh name kind generation; set_live ~ssh name kind generation; 35 | ] 36 | -------------------------------------------------------------------------------- /src/lib/live.mli: -------------------------------------------------------------------------------- 1 | val set_to : 2 | ssh:Config.Ssh.t -> 3 | string -> 4 | [ `Html | `Linked ] -> 5 | Epoch.t Current.t -> 6 | unit Current.t 7 | -------------------------------------------------------------------------------- /src/lib/log.ml: -------------------------------------------------------------------------------- 1 | let logs = Logs.Src.create "ocaml-docs-ci" 2 | 3 | module Log = (val Logs.src_log logs : Logs.LOG) 4 | include Log 5 | -------------------------------------------------------------------------------- /src/lib/misc.ml: -------------------------------------------------------------------------------- 1 | (* module Metrics = struct *) 2 | (* open Prometheus *) 3 | 4 | (* let namespace = "docs_ci" *) 5 | (* let subsystem = "docker" *) 6 | 7 | (* let docker_peek_events = *) 8 | (* let help = "Incoming docker peek events" in *) 9 | (* Gauge.v ~help ~namespace ~subsystem "peek_events" *) 10 | (* end *) 11 | 12 | module Docker = Current_docker.Default 13 | 14 | module Platform : sig 15 | val v : packages:Package.t list -> Ocaml_version.t option 16 | val to_string : Ocaml_version.t -> string 17 | end = struct 18 | let v ~packages = 19 | let ( let* ) = Option.bind in 20 | let ocaml_version name = 21 | packages 22 | |> List.find_opt (fun pkg -> 23 | pkg |> Package.opam |> OpamPackage.name_to_string = name) 24 | |> Option.map (fun pkg -> 25 | pkg |> Package.opam |> OpamPackage.version_to_string) 26 | in 27 | let is_base = 28 | List.exists 29 | (fun p -> 30 | Package.opam p |> OpamPackage.name_to_string = "ocaml-base-compiler") 31 | packages 32 | in 33 | let* version = 34 | if is_base then ocaml_version "ocaml-base-compiler" 35 | else ocaml_version "ocaml-variants" 36 | in 37 | Ocaml_version.of_string version |> Result.to_option 38 | 39 | let to_string v = Ocaml_version.to_string v 40 | end 41 | 42 | let tag ocaml_version = 43 | let minor = 44 | if Ocaml_version.major ocaml_version >= 5 then 45 | Fmt.str "%d" (Ocaml_version.minor ocaml_version) 46 | else Fmt.str "%02d" (Ocaml_version.minor ocaml_version) 47 | in 48 | Fmt.str "debian-12-ocaml-%d.%s%s" 49 | (Ocaml_version.major ocaml_version) 50 | minor 51 | (match Ocaml_version.extra ocaml_version with 52 | | None -> "" 53 | | Some x -> "-" ^ x |> String.map (function '+' -> '-' | x -> x)) 54 | 55 | let cache_hint package = 56 | let packages = Package.all_deps package in 57 | Platform.v ~packages 58 | |> Option.value ~default:Ocaml_version.Releases.latest 59 | |> Platform.to_string 60 | 61 | let weekly = Current_cache.Schedule.v ~valid_for:(Duration.of_day 7) () 62 | 63 | (** Select base image to use *) 64 | let get_base_image packages = 65 | let open Current.Syntax in 66 | let version = 67 | Platform.v ~packages |> Option.value ~default:Ocaml_version.Releases.latest 68 | in 69 | (* let* image = Docker.pull ~label:(tag version) ~schedule:weekly ~arch:"amd64" "ocaml/opam" in *) 70 | let+ tag = 71 | Docker.peek ~schedule:weekly ~arch:"amd64" ("ocaml/opam:" ^ tag version) 72 | in 73 | (* TODO Include comment on which image this is? 74 | Resolves to something like: 75 | `ocaml/opam@sha256:04a0b3ee7288fb3aa7e608c2ccbbbaa289c1810f57265365dd849fc5cc46d9ed` 76 | 77 | debian-12-ocaml-%d.%s%s 78 | *) 79 | Spec.make tag 80 | 81 | let default_base_image = 82 | let open Current.Syntax in 83 | let version = Ocaml_version.Releases.latest in 84 | let+ tag = 85 | Docker.peek ~schedule:weekly ~arch:"amd64" ("ocaml/opam:" ^ tag version) 86 | in 87 | Spec.make tag 88 | 89 | let spec_of_job job = 90 | let install = job.Jobs.install in 91 | let all_deps = Package.all_deps install in 92 | try get_base_image all_deps 93 | with e -> 94 | Format.eprintf "Error with job: %a" (Fmt.list Package.pp) all_deps; 95 | raise e 96 | 97 | let network = [ "host" ] 98 | let docs_cache_folder = "/home/opam/docs-cache/" 99 | let cache = [ Obuilder_spec.Cache.v ~target:docs_cache_folder "ci-docs" ] 100 | 101 | (** Obuilder operation to locally pull the selected folders. The [digests] 102 | option is used to invalidate the operation if the expected value changes. *) 103 | let rsync_pull ~ssh ?(digest = "") folders = 104 | let sources = 105 | List.map 106 | (fun folder -> 107 | Fmt.str "%s:%s/./%a" (Config.Ssh.host ssh) 108 | (Config.Ssh.storage_folder ssh) 109 | Fpath.pp folder) 110 | folders 111 | |> String.concat " " 112 | in 113 | let cache_sources = 114 | List.map (Fmt.str "%s./%a" docs_cache_folder Fpath.pp) folders 115 | |> String.concat " " 116 | in 117 | match folders with 118 | | [] -> Obuilder_spec.comment "no sources to pull" 119 | | _ -> 120 | Obuilder_spec.run ~secrets:Config.Ssh.secrets ~cache ~network 121 | "rsync --delete -avzR %s %s && rsync -aR %s ./ && echo 'pulled: %s'" 122 | sources docs_cache_folder cache_sources digest 123 | 124 | module LatchedBuilder (B : Current_cache.S.BUILDER) = struct 125 | module Adaptor = struct 126 | type t = B.t 127 | 128 | let id = B.id 129 | 130 | module Key = Current.String 131 | module Value = B.Key 132 | module Outcome = B.Value 133 | 134 | let run op job _ key = B.build op job key 135 | let pp f (_, key) = B.pp f key 136 | let auto_cancel = B.auto_cancel 137 | let latched = true 138 | end 139 | 140 | include Current_cache.Generic (Adaptor) 141 | 142 | let get ~opkey ?schedule ctx key = run ?schedule ctx opkey key 143 | end 144 | 145 | let profile = 146 | match Sys.getenv_opt "CI_PROFILE" with 147 | | Some "production" -> `Production 148 | | Some "dev" | None -> `Dev 149 | | Some "docker" -> `Docker 150 | | Some x -> Fmt.failwith "Unknown $PROFILE setting %S" x 151 | 152 | let to_obuilder_job build_spec = 153 | Fmt.to_to_string Obuilder_spec.pp (build_spec |> Spec.finish) 154 | 155 | let to_docker_job build_spec = 156 | let spec_str = 157 | Obuilder_spec.Docker.dockerfile_of_spec ~buildkit:true ~os:`Unix 158 | (build_spec |> Spec.finish) 159 | in 160 | `Contents spec_str 161 | 162 | let to_ocluster_submission spec = 163 | match profile with 164 | | `Production | `Dev -> 165 | to_obuilder_job spec |> Cluster_api.Submission.obuilder_build 166 | | `Docker -> to_docker_job spec |> Cluster_api.Submission.docker_build 167 | 168 | let fold_logs build_job fn = 169 | (* TODO: what if we encounter an infinitely long line ? *) 170 | let open Lwt.Syntax in 171 | let rec aux start next_lines acc = 172 | match next_lines with 173 | | ([] | [ _ ]) as e -> ( 174 | let prev_line = match e with [] -> "" | e :: _ -> e in 175 | let* logs = Cluster_api.Job.log build_job start in 176 | match (logs, prev_line) with 177 | | Error (`Capnp e), _ -> 178 | Lwt.return @@ Fmt.error_msg "%a" Capnp_rpc.Error.pp e 179 | | Ok ("", _), "" -> Lwt_result.return acc 180 | | Ok ("", _), last_line -> aux start [ last_line; "" ] acc 181 | | Ok (data, next), prev_line -> 182 | let lines = String.split_on_char '\n' data in 183 | let fst = List.hd lines in 184 | let rest = List.tl lines in 185 | aux next ((prev_line ^ fst) :: rest) acc) 186 | | line :: next -> aux start next (fn acc line) 187 | in 188 | aux 0L [] 189 | 190 | let tar_cmd folder = 191 | let f = Fpath.to_string folder in 192 | Fmt.str 193 | "shopt -s nullglob && ((tar -cvf %s.tar %s/* && rm -R %s/* && mv %s.tar \ 194 | %s/content.tar) || (echo 'Empty directory'))" 195 | f f f f f 196 | 197 | module Cmd = struct 198 | let tar = tar_cmd 199 | 200 | let list = 201 | let open Fmt in 202 | to_to_string (list ~sep:(const string " && ") (fun f -> pf f "(%s)")) 203 | end 204 | -------------------------------------------------------------------------------- /src/lib/mld.mli: -------------------------------------------------------------------------------- 1 | (* MLD/CU compilation rules *) 2 | 3 | type name = string 4 | 5 | val name_of_string : string -> name 6 | 7 | type mld = Mld (** An mld file *) 8 | type cu = CU (** An odoc compilation unit *) 9 | type 'a kind = Mld : mld kind | CU : cu kind 10 | 11 | type 'a t = { 12 | file : Fpath.t; 13 | target : Fpath.t option; 14 | name : name; 15 | kind : 'a kind; 16 | } 17 | (** The type for an odoc compilation. *) 18 | 19 | type ('a, 'b) command 20 | 21 | val v : ?children:mld t list -> ?parent:'a t -> 'b t -> bool -> ('a, 'b) command 22 | (** [v ~children ~parent t skip] is the command to compile t, potentially having 23 | a [parent] and multiple [children] pages. *) 24 | 25 | val compile_command : ?odoc:string -> _ command -> string 26 | (** The odoc compile command *) 27 | 28 | val pp_compile_command : ?odoc:string -> unit -> _ command Fmt.t 29 | (** The odoc compile command formatter *) 30 | 31 | val pp_link_command : ?odoc:string -> unit -> _ command Fmt.t 32 | (** The odoc link command formatter *) 33 | 34 | val pp_html_command : ?odoc:string -> ?output:Fpath.t -> unit -> _ t Fmt.t 35 | (** The odoc html command formatter *) 36 | 37 | (* Index pages generation *) 38 | 39 | module Gen : sig 40 | type 'a odoc = 'a t 41 | type odoc_dyn = Mld of mld t | CU of cu t 42 | 43 | val digest : odoc_dyn -> string 44 | 45 | type t 46 | (** The index pages generator *) 47 | 48 | val v : (Package.t * bool * odoc_dyn) list -> t 49 | 50 | type gen_page = { 51 | content : string; 52 | odoc : mld odoc; 53 | compilation : (mld, mld) command; 54 | } 55 | (** A page to generate is described by its content, its mld compilation unit 56 | and its associated compilation command. *) 57 | 58 | val universes : t -> gen_page 59 | val packages : t -> gen_page 60 | val pp_makefile : ?odoc:string -> output:Fpath.t -> t Fmt.t 61 | val pp_gen_files_commands : t Fmt.t 62 | val pp_compile_commands : t Fmt.t 63 | val pp_link_commands : t Fmt.t 64 | end 65 | -------------------------------------------------------------------------------- /src/lib/monitor.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** The type for the ci monitor. *) 3 | 4 | type state = 5 | | Done 6 | | Running 7 | | Failed (** The state of a package in the pipeline *) 8 | 9 | (* type step_type = 10 | | Prep 11 | | DepCompilePrep of OpamPackage.t 12 | | DepCompileCompile of OpamPackage.t 13 | | Compile 14 | | BuildHtml *) 15 | 16 | type step_status = Err of string | Active | Blocked | OK 17 | 18 | type step = { typ : string; job_id : string option; status : step_status } 19 | [@@deriving show, eq] 20 | 21 | type steps_list = step list 22 | 23 | val steps_list_to_yojson : steps_list -> Yojson.Safe.t 24 | val step_to_yojson : step -> Yojson.Safe.t 25 | 26 | val make : unit -> t 27 | (** Create a monitor. *) 28 | 29 | type pipeline_tree = 30 | | Item : 'a Current.t -> pipeline_tree 31 | | Seq of (string * pipeline_tree) list 32 | | And of (string * pipeline_tree) list 33 | | Or of (string * pipeline_tree) list 34 | (** The pipeline dependency tree to produces artifacts for a given 35 | package. *) 36 | 37 | val get_blessing : t -> Package.Blessing.Set.t Current.t OpamPackage.Map.t 38 | (** Temporarily access the blessing set for fetching package information to 39 | return over capnp. *) 40 | 41 | val register : 42 | t -> 43 | (OpamPackage.t * string) list -> 44 | (Package.t * _ Current.t) list OpamPackage.Map.t -> 45 | Package.Blessing.Set.t Current.t OpamPackage.Map.t -> 46 | pipeline_tree Package.Map.t -> 47 | unit 48 | (** Register Current.t values for each package in the CI system. *) 49 | 50 | val routes : t -> Current.Engine.t -> Current_web.Resource.t Routes.route list 51 | (** Routes for the renderer *) 52 | 53 | val map_versions : 54 | t -> (OpamPackage.Version.t * state) list OpamPackage.Name.Map.t 55 | (** Map of package name to versions *) 56 | 57 | val lookup_known_packages : t -> string list 58 | (** Get a list of the names of known projects *) 59 | 60 | val lookup_status : 61 | t -> name:string -> (OpamPackage.Name.t * OpamPackage.Version.t * state) list 62 | (** Get a list of version and status tuples for a project *) 63 | 64 | type package_steps = { 65 | package : OpamPackage.t; 66 | status : state; 67 | steps : step list; 68 | } 69 | [@@deriving eq] 70 | 71 | val pp_package_steps : Format.formatter -> package_steps -> unit 72 | val lookup_steps : t -> name:string -> (package_steps list, string) result 73 | val pipeline_state : pipeline_tree -> state 74 | -------------------------------------------------------------------------------- /src/lib/o.ml: -------------------------------------------------------------------------------- 1 | (** Overrides *) 2 | 3 | module OpamPackage = struct 4 | include OpamPackage 5 | 6 | let to_yojson t = `String (OpamPackage.to_string t) 7 | 8 | let of_yojson = function 9 | | `String str -> ( 10 | match OpamPackage.of_string_opt str with 11 | | Some x -> Ok x 12 | | None -> Error "failed to parse version") 13 | | _ -> Error "failed to parse version" 14 | 15 | let pp f t = Fmt.pf f "%s" (to_string t) 16 | end 17 | -------------------------------------------------------------------------------- /src/lib/opam_repository.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | module Log = Solver_api.Solver.Log 3 | 4 | (** Find the oldest commit that touches all the paths. Should find the most 5 | recent commit backwards `from` that have touched the paths. Process all the 6 | paths and check using `OpamFile.OPAM.effectively_equal` to see whether 7 | Resolve for a packages revdeps. 8 | 9 | Don't want to scope on opam_repository *) 10 | let oldest_commit_with ~from pkgs = 11 | let paths = 12 | pkgs 13 | |> List.map (fun pkg -> 14 | let name = OpamPackage.name_to_string pkg in 15 | let version = OpamPackage.version_to_string pkg in 16 | Printf.sprintf "packages/%s/%s.%s" name name version) 17 | in 18 | let clone_path = Current_git.Commit.repo from in 19 | (* Equivalent to: git -C path log -n 1 --format=format:%H from -- paths *) 20 | let cmd = 21 | "git" 22 | :: "-C" 23 | :: Fpath.to_string clone_path 24 | :: "log" 25 | :: "-n" 26 | :: "1" 27 | :: "--format=format:%H" 28 | :: Current_git.Commit.hash from 29 | :: "--" 30 | :: paths 31 | in 32 | let cmd = ("", Array.of_list cmd) in 33 | Process.pread cmd >|= String.trim 34 | -------------------------------------------------------------------------------- /src/lib/opam_repository.mli: -------------------------------------------------------------------------------- 1 | val oldest_commit_with : 2 | from:Current_git.Commit.t -> OpamPackage.t list -> string Lwt.t 3 | (** Use "git-log" to find the oldest commit with these package versions. This 4 | avoids invalidating the Docker build cache on every update to 5 | opam-repository. 6 | 7 | @param from The commit at which to begin the search. *) 8 | -------------------------------------------------------------------------------- /src/lib/package.ml: -------------------------------------------------------------------------------- 1 | module rec Universe : sig 2 | type t [@@deriving yojson] 3 | 4 | val hash : t -> string 5 | val deps : t -> Package.t list 6 | val pp : t Fmt.t 7 | val v : Package.t list -> t 8 | val compare : t -> t -> int 9 | end = struct 10 | type t = { hash : string; deps : Package.t list } [@@deriving yojson] 11 | 12 | let hash t = t.hash 13 | let deps t = t.deps 14 | 15 | let v deps = 16 | let str = 17 | deps 18 | |> List.map Package.opam 19 | |> List.sort OpamPackage.compare 20 | |> List.fold_left 21 | (fun acc p -> Format.asprintf "%s\n%s" acc (OpamPackage.to_string p)) 22 | "" 23 | in 24 | let hash = Digest.to_hex (Digest.string str) in 25 | { hash; deps } 26 | 27 | let pp f { hash; _ } = Fmt.pf f "%s" hash 28 | let compare { hash; _ } { hash = hash2; _ } = String.compare hash hash2 29 | end 30 | 31 | and Package : sig 32 | type t [@@deriving yojson] 33 | 34 | val opam : t -> OpamPackage.t 35 | val commit : t -> string 36 | val universe : t -> Universe.t 37 | val digest : t -> string 38 | val id : t -> string 39 | val pp : t Fmt.t 40 | val compare : t -> t -> int 41 | val v : OpamPackage.t -> t list -> string -> t 42 | 43 | val make : 44 | blacklist:string list -> 45 | commit:string -> 46 | root:OpamPackage.t -> 47 | (OpamPackage.t * OpamPackage.t list) list -> 48 | t 49 | end = struct 50 | type t = { opam : O.OpamPackage.t; universe : Universe.t; commit : string } 51 | [@@deriving yojson] 52 | 53 | let universe t = t.universe 54 | let opam t = t.opam 55 | let commit t = t.commit 56 | let id t = OpamPackage.to_string t.opam ^ "-" ^ Universe.hash t.universe 57 | let digest = id 58 | let v opam deps commit = { opam; universe = Universe.v deps; commit } 59 | 60 | let pp f { universe; opam; _ } = 61 | Fmt.pf f "%s; %a" (OpamPackage.to_string opam) Universe.pp universe 62 | 63 | let compare t t2 = 64 | match OpamPackage.compare t.opam t2.opam with 65 | | 0 -> Universe.compare t.universe t2.universe 66 | | v -> v 67 | 68 | let remove_blacklisted_packages ~blacklist deps = 69 | let module StringSet = Set.Make (String) in 70 | let blacklist = StringSet.of_list blacklist in 71 | let filter pkg = 72 | not (StringSet.mem (OpamPackage.name_to_string pkg) blacklist) 73 | in 74 | deps 75 | |> List.filter (fun (pkg, _) -> filter pkg) 76 | |> List.map (fun (pkg, deps) -> (pkg, List.filter filter deps)) 77 | 78 | let make ~blacklist ~commit ~root deps = 79 | let deps = remove_blacklisted_packages ~blacklist deps in 80 | let memo = ref OpamPackage.Map.empty in 81 | let package_deps = OpamPackage.Map.of_list deps in 82 | let rec obtain package = 83 | match OpamPackage.Map.find_opt package !memo with 84 | | Some package -> package 85 | | None -> 86 | memo := OpamPackage.Map.add package None !memo; 87 | let deps_pkg = 88 | OpamPackage.Map.find_opt package package_deps 89 | |> Option.value ~default:[] 90 | |> List.filter_map obtain 91 | in 92 | let pkg = Some (Package.v package deps_pkg commit) in 93 | memo := OpamPackage.Map.add package pkg !memo; 94 | pkg 95 | in 96 | obtain root |> Option.get 97 | end 98 | 99 | include Package 100 | 101 | let all_deps pkg = pkg :: (pkg |> universe |> Universe.deps) 102 | 103 | module PackageMap = Map.Make (Package) 104 | module PackageSet = Set.Make (Package) 105 | 106 | module Blessing = struct 107 | type t = Blessed | Universe 108 | 109 | let is_blessed t = t = Blessed 110 | let of_bool t = if t then Blessed else Universe 111 | let to_string = function Blessed -> "blessed" | Universe -> "universe" 112 | 113 | module Set = struct 114 | type b = t 115 | 116 | module StringSet = Set.Make (String) 117 | 118 | type t = { 119 | opam : OpamPackage.t; 120 | universe : string; 121 | blessed : Package.t option; 122 | } 123 | 124 | let universe_size u = Universe.deps u |> List.length 125 | 126 | let empty (opam : OpamPackage.t) : t = 127 | { opam; universe = ""; blessed = None } 128 | 129 | module Universe_info = struct 130 | type t = { universe : Universe.t; deps_count : int; revdeps_count : int } 131 | 132 | (* To compare two possibilities, we want first to maximize the number of dependencies 133 | in the universe (to favorize optional dependencies) and then maximize the number of revdeps: 134 | this is for stability purposes, as any blessing change will force downstream recomputations. *) 135 | let compare a b = 136 | match Int.compare a.deps_count b.deps_count with 137 | | 0 -> Int.compare a.revdeps_count b.revdeps_count 138 | | v -> v 139 | 140 | let make ~counts package = 141 | let universe = Package.universe package in 142 | let deps_count = universe_size universe in 143 | { universe; deps_count; revdeps_count = PackageMap.find package counts } 144 | end 145 | 146 | let v ~counts (packages : Package.t list) : t = 147 | assert (packages <> []); 148 | let first_package = List.hd packages in 149 | let opam = first_package |> Package.opam in 150 | let first_universe = Universe_info.make ~counts first_package in 151 | let best_package, best_universe = 152 | List.fold_left 153 | (fun (best_package, best_universe) new_package -> 154 | assert (Package.opam new_package = opam); 155 | let new_universe = Universe_info.make ~counts new_package in 156 | if Universe_info.compare new_universe best_universe > 0 then 157 | (new_package, new_universe) 158 | else (best_package, best_universe)) 159 | (first_package, first_universe) 160 | (List.tl packages) 161 | in 162 | { 163 | opam; 164 | universe = Universe.hash best_universe.universe; 165 | blessed = Some best_package; 166 | } 167 | 168 | let get { opam; universe; _ } pkg = 169 | assert (Package.opam pkg = opam); 170 | of_bool (Universe.hash (Package.universe pkg) = universe) 171 | 172 | let blessed t = t.blessed 173 | end 174 | end 175 | 176 | module Map = PackageMap 177 | module Set = PackageSet 178 | -------------------------------------------------------------------------------- /src/lib/package.mli: -------------------------------------------------------------------------------- 1 | module rec Universe : sig 2 | type t 3 | (** A dependency universe *) 4 | 5 | val v : Package.t list -> t 6 | (** [v packages] Build the dependency universe made of [packages] *) 7 | 8 | val deps : t -> Package.t list 9 | (** Retrieve the list of dependencies *) 10 | 11 | val hash : t -> string 12 | (** Get the universe hash *) 13 | end 14 | 15 | and Package : sig 16 | type t 17 | (** A package in the ocaml-docs-ci sense: it's composed of the package name, 18 | version, and its dependency universe. *) 19 | end 20 | 21 | type t = Package.t 22 | 23 | val make : 24 | blacklist:string list -> 25 | commit:string -> 26 | root:OpamPackage.t -> 27 | (OpamPackage.t * OpamPackage.t list) list -> 28 | t 29 | (** Using the solver results, obtain the package instance corresponding to the 30 | [root] package. *) 31 | 32 | val all_deps : t -> t list 33 | (** [all_deps t] is all the dependencies of t, and it includes itself. *) 34 | 35 | val pp : t Fmt.t 36 | val compare : t -> t -> int 37 | val opam : t -> OpamPackage.t 38 | val universe : t -> Universe.t 39 | val digest : t -> string 40 | val commit : t -> string 41 | val id : t -> string 42 | 43 | module Map : Map.S with type key = t 44 | module Set : Set.S with type elt = t 45 | 46 | module Blessing : sig 47 | type t = Blessed | Universe 48 | 49 | val is_blessed : t -> bool 50 | val to_string : t -> string 51 | 52 | module Set : sig 53 | type b = t 54 | 55 | type t 56 | (** The structure containing which packages are blessed or not. A blessed 57 | package is a package aimed to be built for the main documentation pages. *) 58 | 59 | val empty : OpamPackage.t -> t 60 | (** Construct [t] with an [OpamPackage.t] *) 61 | 62 | val v : counts:int Map.t -> Package.t list -> t 63 | (** Compute which packages are blessed. *) 64 | 65 | val get : t -> Package.t -> b 66 | 67 | val blessed : t -> Package.t option 68 | (** Obtain which package is blessed, or raise if the set is empty *) 69 | end 70 | end 71 | -------------------------------------------------------------------------------- /src/lib/platform.ml: -------------------------------------------------------------------------------- 1 | type ocaml_version = V4_10 | V4_11 2 | 3 | let pp_ocaml f = function V4_10 -> Fmt.pf f "4.10" | V4_11 -> Fmt.pf f "4.11" 4 | 5 | let pp_exact_ocaml f = function 6 | | V4_10 -> Fmt.pf f "4.10.2" 7 | | V4_11 -> Fmt.pf f "4.11.2" 8 | 9 | type os = Debian | Ubuntu | Fedora 10 | 11 | let os_version = function Ubuntu -> "23.04" | Fedora -> "38" | Debian -> "12" 12 | 13 | let os_family = function 14 | | Ubuntu -> "ubuntu" 15 | | Fedora -> "fedora" 16 | | Debian -> "debian" 17 | 18 | let pp_os f t = Fmt.pf f "%s-%s" (os_family t) (os_version t) 19 | 20 | type arch = Arm64 | Amd64 21 | 22 | let arch_to_string = function Arm64 -> "arm64" | Amd64 -> "x86_64" 23 | 24 | type system = { ocaml : ocaml_version; os : os } 25 | 26 | let pp_system f { ocaml; os } = Fmt.pf f "%a-ocaml-%a" pp_os os pp_ocaml ocaml 27 | let spec t = Spec.make @@ Fmt.str "ocaml/opam:%a" pp_system t 28 | 29 | type t = { system : system; arch : arch } 30 | 31 | let platform_id t = 32 | match t.arch with 33 | | Arm64 -> "arm64-" ^ Fmt.str "%a" pp_system t.system 34 | | Amd64 -> "x86_64-" ^ Fmt.str "%a" pp_system t.system 35 | 36 | let pp_platform f t = 37 | Fmt.pf f "%s / %a / %a" (arch_to_string t.arch) pp_os t.system.os pp_ocaml 38 | t.system.ocaml 39 | 40 | let ocluster_pool { arch; _ } = 41 | match arch with Arm64 -> "linux-arm64" | Amd64 -> "linux-x86_64" 42 | 43 | (* Base configuration.. *) 44 | 45 | let system = { ocaml = V4_11; os = Debian } 46 | let platform_amd64 = { system; arch = Amd64 } 47 | let platform_arm64 = { system; arch = Arm64 } 48 | -------------------------------------------------------------------------------- /src/lib/prep.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** The type for a prepped package (build objects in a universe/package folder) *) 3 | 4 | val hash : t -> string 5 | val package : t -> Package.t 6 | val base : t -> Spec.t 7 | 8 | type prep_result = Success | Failed 9 | 10 | val result : t -> prep_result 11 | 12 | type prep 13 | 14 | val extract : job:Jobs.t -> prep Current.t -> t Current.t Package.Map.t 15 | 16 | val v : 17 | config:Config.t -> 18 | voodoo:Voodoo.Prep.t Current.t -> 19 | spec:Spec.t Current.t -> 20 | Jobs.t -> 21 | prep Current.t 22 | (** Install a package universe, extract useful files and push obtained universes 23 | on git. *) 24 | 25 | val pp : t Fmt.t 26 | val compare : t -> t -> int 27 | -------------------------------------------------------------------------------- /src/lib/process.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let pp_args = 4 | let sep = Fmt.(const string) " " in 5 | Fmt.(array ~sep (quote string)) 6 | 7 | let pp_cmd f = function 8 | | "", args -> pp_args f args 9 | | bin, args -> Fmt.pf f "(%S, %a)" bin pp_args args 10 | 11 | let pp_signal f x = 12 | let open Sys in 13 | if x = sigkill then Fmt.string f "kill" 14 | else if x = sigterm then Fmt.string f "term" 15 | else Fmt.int f x 16 | 17 | let pp_status f = function 18 | | Unix.WEXITED x -> Fmt.pf f "exited with status %d" x 19 | | Unix.WSIGNALED x -> Fmt.pf f "failed with signal %d" x 20 | | Unix.WSTOPPED x -> Fmt.pf f "stopped with signal %d" x 21 | 22 | let check_status cmd = function 23 | | Unix.WEXITED 0 -> () 24 | | status -> Fmt.failwith "%a %a" pp_cmd cmd pp_status status 25 | 26 | let exec cmd = 27 | let proc = Lwt_process.open_process_none cmd in 28 | proc#status >|= check_status cmd 29 | 30 | let pread cmd = 31 | let proc = Lwt_process.open_process_in cmd in 32 | Lwt_io.read proc#stdout >>= fun output -> 33 | proc#status >|= check_status cmd >|= fun () -> output 34 | -------------------------------------------------------------------------------- /src/lib/record.ml: -------------------------------------------------------------------------------- 1 | module Git = Current_git 2 | 3 | module Record = struct 4 | type t = No_context 5 | 6 | module Value = struct 7 | type t = int 8 | 9 | let marshal t = `Int t |> Yojson.Safe.to_string 10 | 11 | let unmarshal t = 12 | let json = Yojson.Safe.from_string t in 13 | json |> Yojson.Safe.Util.to_int 14 | end 15 | 16 | module Key = struct 17 | type t = { voodoo : Voodoo.t; config : Config.t } 18 | 19 | let key { voodoo; config = _ } = 20 | let t = Epoch.v voodoo in 21 | Fmt.str "%a" Epoch.pp t 22 | 23 | let digest t = key t |> Digest.string |> Digest.to_hex 24 | end 25 | 26 | let id = "record-pipeline" 27 | 28 | let build No_context (job : Current.Job.t) Key.{ config; voodoo } = 29 | let open Lwt.Syntax in 30 | let* () = Current.Job.start ~level:Harmless job in 31 | 32 | let generation = Epoch.v voodoo in 33 | let voodoo_do_commit = Voodoo.Do.v voodoo |> Voodoo.Do.digest in 34 | let voodoo_gen_commit = 35 | Voodoo.Gen.v voodoo |> Voodoo.Gen.commit |> Git.Commit_id.hash 36 | in 37 | let voodoo_repo = Config.voodoo_repo config in 38 | let voodoo_branch = Config.voodoo_branch config in 39 | let voodoo_prep_commit = Voodoo.Prep.v voodoo |> Voodoo.Prep.digest in 40 | let epoch_linked = (Epoch.digest `Linked) generation in 41 | let epoch_html = (Epoch.digest `Html) generation in 42 | 43 | let result = 44 | Index.record_new_pipeline ~voodoo_do_commit ~voodoo_gen_commit 45 | ~voodoo_prep_commit ~voodoo_repo ~voodoo_branch ~epoch_html 46 | ~epoch_linked 47 | in 48 | match result with 49 | | Ok pipeline_id -> Lwt.return_ok (pipeline_id |> Int64.to_int) 50 | | Error msg -> Lwt.return_error (`Msg msg) 51 | 52 | let pp f Key.{ config = _; voodoo } = 53 | let generation = Epoch.v voodoo in 54 | Epoch.pp f generation 55 | 56 | let auto_cancel = true 57 | end 58 | 59 | module RecordCache = Current_cache.Make (Record) 60 | 61 | let v config voodoo = 62 | let open Current.Syntax in 63 | Current.component "record" 64 | |> let> voodoo in 65 | let output = RecordCache.get No_context Record.Key.{ config; voodoo } in 66 | Current.Primitive.map_result 67 | (Result.map (fun pipeline_id -> pipeline_id)) 68 | output 69 | -------------------------------------------------------------------------------- /src/lib/remote_cache.ml: -------------------------------------------------------------------------------- 1 | let id = "remote-cache" 2 | let state_dir = Current.state_dir id 3 | let sync_pool = Current.Pool.create ~label:"ssh" 1 4 | 5 | let sync ~job t = 6 | let open Lwt.Syntax in 7 | let remote_folder = 8 | Fmt.str "%s@@%s:%s/" (Config.Ssh.user t) (Config.Ssh.host t) 9 | (Config.Ssh.storage_folder t) 10 | in 11 | let switch = Current.Switch.create ~label:"ssh" () in 12 | Lwt.finalize 13 | (fun () -> 14 | Current.Job.log job "Synchronizing remote cache."; 15 | let* () = Current.Job.use_pool ~switch job sync_pool in 16 | let+ _ = 17 | Current.Process.exec ~cancellable:true ~job 18 | ( "", 19 | [| 20 | "rsync"; 21 | "-avzR"; 22 | "--delete"; 23 | "-e"; 24 | Fmt.str "ssh -o StrictHostKeyChecking=no -p %d -i %a" 25 | (Config.Ssh.port t) Fpath.pp 26 | (Config.Ssh.priv_key_file t); 27 | remote_folder ^ "/cache/./"; 28 | Fpath.to_string state_dir; 29 | |] ) 30 | in 31 | ()) 32 | (fun () -> Current.Switch.turn_off switch) 33 | 34 | type t = Config.Ssh.t 35 | type cache_key = string 36 | type digest = string 37 | type build_result = Ok of digest | Failed 38 | type cache_entry = (digest * build_result) option 39 | 40 | let digest = function 41 | | None -> "none" 42 | | Some (k, Failed) -> "failed-" ^ k 43 | | Some (k, Ok digest) -> "ok-" ^ k ^ "-" ^ digest 44 | 45 | let pp f = function 46 | | None -> Fmt.pf f "none" 47 | | Some (_, Failed) -> Fmt.pf f "failed" 48 | | Some (_, Ok digest) -> Fmt.pf f "ok -> %s" digest 49 | 50 | let folder_digest_exn = function 51 | | Some (_, Ok digest) -> digest 52 | | _ -> raise Not_found 53 | 54 | let key_file path = Fpath.(state_dir // add_ext ".key" path) 55 | let digest_file path = Fpath.(state_dir // add_ext ".sha256" path) 56 | 57 | let get _ path = 58 | Bos.OS.File.read (key_file path) 59 | |> Result.to_option 60 | |> Option.map (fun key -> 61 | ( key, 62 | match Bos.OS.File.read (digest_file path) with 63 | | Ok v -> Ok (String.trim v) 64 | | Error _ -> Failed )) 65 | 66 | let cmd_write_key key paths = 67 | let pp_write_key f folder = 68 | Fmt.pf f "mkdir -p cache/%a && echo '%s' > cache/%a.key" Fpath.pp 69 | (Fpath.parent folder) key Fpath.pp folder 70 | in 71 | Fmt.(str "%a" (list ~sep:(any " && ") pp_write_key) paths) 72 | 73 | let cmd_compute_sha256 paths = 74 | let pp_compute_digest f folder = 75 | Fmt.pf f 76 | "(mkdir -p cache/%a && (find %a/ -type f -exec sha256sum {} \\;) | sort \ 77 | -k 2 | sha256sum > cache/%a.sha256)" 78 | Fpath.pp (Fpath.parent folder) Fpath.pp folder Fpath.pp folder 79 | in 80 | Fmt.(str "%a" (list ~sep:(any " && ") pp_compute_digest) paths) 81 | 82 | let cmd_sync_folder t = 83 | Fmt.str "rsync -avz cache %s:%s/" (Config.Ssh.host t) 84 | (Config.Ssh.storage_folder t) 85 | 86 | module Op = struct 87 | type t = No_context 88 | 89 | let pp f _ = Fmt.pf f "remote cache" 90 | 91 | module Key = struct 92 | type t = Config.Ssh.t 93 | 94 | let digest = Config.Ssh.digest 95 | end 96 | 97 | module Value = Current.Unit 98 | 99 | let auto_cancel = true 100 | let id = id 101 | 102 | let build No_context job ssh = 103 | let open Lwt.Syntax in 104 | let* () = Current.Job.start ~level:Mostly_harmless job in 105 | let+ () = sync ~job ssh in 106 | Result.Ok () 107 | end 108 | 109 | module Cache = Current_cache.Make (Op) 110 | 111 | let v ssh = 112 | let open Current.Syntax in 113 | let+ _ = 114 | Current.primitive 115 | ~info:(Current.component "remote cache pull") 116 | (Cache.get No_context) (Current.return ssh) 117 | in 118 | ssh 119 | -------------------------------------------------------------------------------- /src/lib/retry.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Lwt.Syntax 3 | 4 | let base_sleep_time = 30 5 | 6 | let sleep_duration n' = 7 | (* backoff is based on n *. 30. *. (Float.pow 1.5 n) 8 | This gives the sequence 0s -> 45s -> 135s -> 300s -> 600s -> 1100s 9 | *) 10 | let n = Int.to_float n' in 11 | let randomised_sleep_time = base_sleep_time + Random.int 20 in 12 | let backoff = n *. Int.to_float base_sleep_time *. Float.pow 1.5 n in 13 | Int.to_float randomised_sleep_time +. backoff 14 | 15 | let rec retry_loop ?(sleep_duration = sleep_duration) ?job ?(log_string = "") 16 | ?(number_of_attempts = 0) ?(max_number_of_attempts = 2) 17 | fn_returning_results_and_retriable_errors = 18 | let log_line = 19 | Fmt.str "RETRYING: %s Number of retries: %d" log_string number_of_attempts 20 | in 21 | let log_retry = 22 | match job with 23 | | Some job -> Current.Job.log job "%s (retriable error condition)" log_line 24 | | None -> Log.info (fun f -> f "%s (retriable error condition)" log_line) 25 | in 26 | let* x = fn_returning_results_and_retriable_errors () in 27 | match x with 28 | | Error e -> 29 | (* Error signals no recovery *) 30 | Lwt.return_error e 31 | | Ok (results, []) -> Lwt.return_ok results 32 | | Ok (_, _errors) when number_of_attempts >= max_number_of_attempts -> 33 | Lwt.return_error (`Msg "maximum attempts reached") 34 | | Ok (_, _errors) -> 35 | (* retry *) 36 | Lwt_unix.sleep (sleep_duration @@ number_of_attempts) >>= fun () -> 37 | log_retry; 38 | retry_loop ~sleep_duration ~log_string 39 | ~number_of_attempts:(number_of_attempts + 1) ~max_number_of_attempts 40 | fn_returning_results_and_retriable_errors 41 | -------------------------------------------------------------------------------- /src/lib/retry.mli: -------------------------------------------------------------------------------- 1 | val retry_loop : 2 | ?sleep_duration:(int -> float) -> 3 | ?job:Current.Job.t -> 4 | ?log_string:string -> 5 | ?number_of_attempts:int -> 6 | ?max_number_of_attempts:int -> 7 | (unit -> ('a * 'c list, ([> `Msg of string ] as 'e)) Lwt_result.t) -> 8 | ('a, 'e) Lwt_result.t 9 | (** Retry the given function - the function is expected to return 'e to indicate 10 | retriable errors. 11 | 12 | Retries occur max_number_of_attempts times defaulting to 2. *) 13 | -------------------------------------------------------------------------------- /src/lib/solver.ml: -------------------------------------------------------------------------------- 1 | module Git = Current_git 2 | 3 | module Metrics = struct 4 | open Prometheus 5 | 6 | let namespace = "docs_ci" 7 | let subsystem = "solver" 8 | 9 | let solver_status_total = 10 | let help = "Number of solves by status" in 11 | Gauge.v_label ~label_name:"status" ~help ~namespace ~subsystem 12 | "status_total" 13 | end 14 | 15 | (* -------------------------- *) 16 | 17 | let job_log job logs = 18 | let module X = Solver_api.Raw.Service.Log in 19 | X.local 20 | @@ object 21 | inherit X.service 22 | 23 | method write_impl params release_param_caps = 24 | let open X.Write in 25 | release_param_caps (); 26 | let msg = Params.msg_get params in 27 | logs := msg :: !logs; 28 | Current.Job.write job msg; 29 | Capnp_rpc_lwt.Service.(return (Response.create_empty ())) 30 | end 31 | 32 | let perform_constrained_solve ~solver ~pool ~job ~(platform : Platform.t) ~opam 33 | constraints = 34 | let open Lwt.Syntax in 35 | let packages = List.map (fun (p, _, _) -> p) constraints in 36 | let request = 37 | { 38 | Solver_api.Worker.Solve_request.opam_repository_commit = 39 | opam |> Current_git.Commit.id |> Current_git.Commit_id.hash; 40 | pkgs = packages; 41 | constraints; 42 | platforms = 43 | [ 44 | ( "base", 45 | Solver_api.Worker.Vars. 46 | { 47 | arch = platform.arch |> Platform.arch_to_string; 48 | os = "linux"; 49 | os_family = Platform.os_family platform.system.os; 50 | os_distribution = "linux"; 51 | os_version = Platform.os_version platform.system.os; 52 | } ); 53 | ]; 54 | } 55 | in 56 | let switch = Current.Switch.create ~label:"solver switch" () in 57 | Lwt.catch 58 | (fun () -> 59 | let* () = Current.Job.use_pool ~switch job pool in 60 | let logs = ref [] in 61 | let* res = 62 | Capnp_rpc_lwt.Capability.with_ref (job_log job logs) @@ fun log -> 63 | Solver_api.Solver.solve solver request ~log 64 | in 65 | let+ () = Current.Switch.turn_off switch in 66 | match res with 67 | | Ok [] -> 68 | Fmt.error_msg "no platform:\n%s" (String.concat "\n" (List.rev !logs)) 69 | | Ok [ x ] -> 70 | let solution = 71 | List.map 72 | (fun (a, b) -> 73 | (OpamPackage.of_string a, List.map OpamPackage.of_string b)) 74 | x.packages 75 | in 76 | Ok (solution, x.commit) 77 | | Ok _ -> Fmt.error_msg "??" 78 | | Error (`Msg msg) -> Fmt.error_msg "Error from solver: %s" msg) 79 | (fun exn -> 80 | let* () = Current.Switch.turn_off switch in 81 | raise exn) 82 | 83 | let perform_solve ~solver ~pool ~job ~(platform : Platform.t) ~opam track = 84 | let package = Track.pkg track in 85 | let constraints = 86 | [ 87 | ( OpamPackage.name_to_string package, 88 | `Eq, 89 | OpamPackage.version_to_string package ); 90 | ] 91 | in 92 | let latest = Ocaml_version.Releases.latest |> Ocaml_version.to_string in 93 | perform_constrained_solve ~solver ~pool ~job ~platform ~opam 94 | (("ocaml-base-compiler", `Geq, Ocaml_version.(Releases.v4_04_1 |> to_string)) 95 | :: ("ocaml", `Leq, latest) 96 | :: constraints) 97 | 98 | let solver_version = "v2" 99 | 100 | module Cache = struct 101 | let fname id track = 102 | let digest = Track.digest track in 103 | let name = Track.pkg track |> OpamPackage.name_to_string in 104 | let name_version = Track.pkg track |> OpamPackage.version_to_string in 105 | Fpath.(Current.state_dir id / name / name_version / digest) 106 | 107 | let id = "solver-cache-" ^ solver_version 108 | 109 | type cache_value = (Package.t, string) result 110 | 111 | let fname = fname id 112 | 113 | let mem track = 114 | let fname = fname track in 115 | match Bos.OS.Path.exists fname with 116 | | Ok true -> true 117 | | Ok false | Error _ -> false 118 | 119 | let write ((track, value) : Track.t * cache_value) = 120 | let fname = fname track in 121 | let _ = Bos.OS.Dir.create (fst (Fpath.split_base fname)) |> Result.get_ok in 122 | let file = open_out (Fpath.to_string fname) in 123 | Marshal.to_channel file value []; 124 | close_out file 125 | 126 | let read track : cache_value option = 127 | let fname = fname track in 128 | try 129 | let file = open_in (Fpath.to_string fname) in 130 | let result = Marshal.from_channel file in 131 | close_in file; 132 | Some result 133 | with Failure _ | Sys_error _ -> None 134 | end 135 | 136 | type key = Track.t 137 | type t = { successes : Track.t list; failures : Track.t list } 138 | 139 | let keys t = t.successes 140 | let get key = Cache.read key |> Option.get (* is in cache ? *) |> Result.get_ok 141 | 142 | let failures t = 143 | t.failures 144 | |> List.map (fun k -> 145 | (Track.pkg k, Cache.read k |> Option.get |> Result.get_error)) 146 | 147 | (* is solved ? *) 148 | 149 | (* ------------------------- *) 150 | module Solver = struct 151 | type outcome = t 152 | type t = Solver_api.Solver.t * unit Current.Pool.t 153 | 154 | let id = "incremental-solver-" ^ solver_version 155 | let pp f _ = Fmt.pf f "incremental solver %s" solver_version 156 | let auto_cancel = false 157 | let latched = true 158 | 159 | (* A single instance of the solver is expected. *) 160 | module Key = Current.Unit 161 | 162 | module Value = struct 163 | type t = { 164 | packages : Track.t list; 165 | blacklist : string list; 166 | platform : Platform.t; 167 | opam_commit : Git.Commit.t; 168 | } 169 | 170 | (* TODO: what happens when the platform changes? *) 171 | let digest { packages; blacklist; opam_commit; platform = _ } = 172 | (Git.Commit.hash opam_commit :: blacklist) 173 | @ List.map 174 | (fun t -> 175 | (Track.pkg t |> OpamPackage.to_string) ^ "-" ^ Track.digest t) 176 | packages 177 | |> Digestif.SHA256.digestv_string 178 | |> Digestif.SHA256.to_hex 179 | end 180 | 181 | module Outcome = struct 182 | type nonrec t = outcome 183 | 184 | let marshal t = Marshal.to_string t [] 185 | let unmarshal t = Marshal.from_string t 0 186 | end 187 | 188 | let run (solver, pool) job () 189 | Value.{ packages; blacklist; platform; opam_commit } = 190 | let open Lwt.Syntax in 191 | let* () = Current.Job.start ~level:Harmless job in 192 | Current.Job.log job "Using opam-repository sha %a" Git.Commit.pp opam_commit; 193 | let to_do = List.filter (fun x -> not (Cache.mem x)) packages in 194 | let* solved = 195 | Lwt_list.map_p 196 | (fun pkg -> 197 | let+ res = 198 | perform_solve ~solver ~pool ~job ~opam:opam_commit ~platform pkg 199 | in 200 | let root = Track.pkg pkg in 201 | let result = 202 | match res with 203 | | Ok (packages, commit) -> 204 | Ok (Package.make ~blacklist ~commit ~root packages) 205 | | Error (`Msg msg) -> 206 | Current.Job.log job "Solving failed for %s: %s" 207 | (OpamPackage.to_string root) 208 | msg; 209 | Error msg 210 | in 211 | Cache.write (pkg, result); 212 | Result.is_ok result) 213 | to_do 214 | in 215 | let solved_packages = List.length packages 216 | and new_packages = List.length solved 217 | and success_packages = List.length (solved |> List.filter (fun x -> x)) in 218 | Prometheus.Gauge.set 219 | (Metrics.solver_status_total "solved") 220 | (float_of_int solved_packages); 221 | Prometheus.Gauge.set 222 | (Metrics.solver_status_total "new") 223 | (float_of_int new_packages); 224 | Prometheus.Gauge.set 225 | (Metrics.solver_status_total "success") 226 | (float_of_int success_packages); 227 | Current.Job.log job "Solved: %d / New: %d / Success: %d" solved_packages 228 | new_packages success_packages; 229 | 230 | let successes, failures = 231 | List.partition 232 | (fun x -> match Cache.read x with Some (Ok _) -> true | _ -> false) 233 | packages 234 | in 235 | Lwt.return_ok { successes; failures } 236 | end 237 | 238 | module SolverCache = Current_cache.Generic (Solver) 239 | 240 | let solver_pool = ref None 241 | 242 | let solver_pool config = 243 | match !solver_pool with 244 | | None -> 245 | let jobs = Config.jobs config in 246 | let s = Solver_pool.spawn_local ~jobs () in 247 | let pool = Current.Pool.create ~label:"solver" jobs in 248 | solver_pool := Some (s, pool); 249 | (s, pool) 250 | | Some s -> s 251 | 252 | let incremental ~config ~(blacklist : string list) 253 | ~(opam : Git.Commit.t Current.t) (packages : Track.t list Current.t) : 254 | t Current.t = 255 | let open Current.Syntax in 256 | let solver_pool = solver_pool config in 257 | Current.component "incremental solver" 258 | |> let> opam and> packages in 259 | SolverCache.run solver_pool () 260 | { 261 | packages; 262 | blacklist; 263 | platform = Platform.platform_amd64; 264 | opam_commit = opam; 265 | } 266 | -------------------------------------------------------------------------------- /src/lib/solver.mli: -------------------------------------------------------------------------------- 1 | module Git = Current_git 2 | 3 | type t 4 | type key 5 | 6 | val keys : t -> key list 7 | val failures : t -> (OpamPackage.t * string) list 8 | val get : key -> Package.t 9 | 10 | val incremental : 11 | config:Config.t -> 12 | blacklist:string list -> 13 | opam:Git.Commit.t Current.t -> 14 | Track.t list Current.t -> 15 | t Current.t 16 | -------------------------------------------------------------------------------- /src/lib/solver_pool.ml: -------------------------------------------------------------------------------- 1 | let spawn_local ~jobs ?solver_dir () : Solver_api.Solver.t = 2 | let p, c = Unix.(socketpair PF_UNIX SOCK_STREAM 0 ~cloexec:true) in 3 | Unix.clear_close_on_exec c; 4 | let solver_dir = 5 | match solver_dir with 6 | | None -> Fpath.to_string (Current.state_dir "solver") 7 | | Some x -> x 8 | in 9 | let cmd = ("", [| "ocaml-docs-ci-solver"; "--jobs"; string_of_int jobs |]) in 10 | let _child = 11 | Lwt_process.open_process_none ~cwd:solver_dir ~stdin:(`FD_move c) cmd 12 | in 13 | let switch = Lwt_switch.create () in 14 | let p = 15 | Lwt_unix.of_unix_file_descr p 16 | |> Capnp_rpc_unix.Unix_flow.connect ~switch 17 | |> Capnp_rpc_net.Endpoint.of_flow 18 | (module Capnp_rpc_unix.Unix_flow) 19 | ~peer_id:Capnp_rpc_net.Auth.Digest.insecure ~switch 20 | in 21 | let conn = 22 | Capnp_rpc_unix.CapTP.connect ~restore:Capnp_rpc_net.Restorer.none p 23 | in 24 | let solver = 25 | Capnp_rpc_unix.CapTP.bootstrap conn 26 | (Capnp_rpc_net.Restorer.Id.public "solver") 27 | in 28 | solver 29 | |> Capnp_rpc_lwt.Capability.when_broken (fun ex -> 30 | Fmt.failwith "Solver process failed: %a" Capnp_rpc.Exception.pp ex); 31 | solver 32 | -------------------------------------------------------------------------------- /src/lib/solver_pool.mli: -------------------------------------------------------------------------------- 1 | val spawn_local : jobs:int -> ?solver_dir:string -> unit -> Solver_api.Solver.t 2 | -------------------------------------------------------------------------------- /src/lib/spec.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | base : string; 3 | ops : Obuilder_spec.op list; 4 | children : (string * Obuilder_spec.t) list; 5 | } 6 | 7 | let add next_ops { base; ops; children } = 8 | { base; ops = ops @ next_ops; children } 9 | 10 | let children ~name spec { base; ops; children } = 11 | { base; ops; children = (name, spec) :: children } 12 | 13 | let finish { base; ops; children } = 14 | Obuilder_spec.stage ~child_builds:children ~from:base ops 15 | 16 | (* https://gist.github.com/iangreenleaf/279849 *) 17 | let rsync_retry_script = 18 | {|#!/bin/bash\n 19 | MAX_RETRIES=10\n 20 | i=0\n 21 | false\n 22 | while [ $? -ne 0 -a $i -lt $MAX_RETRIES ]\n 23 | do\n 24 | i=$(($i+1))\n 25 | echo "Rsync ($i)"\n 26 | /usr/bin/rsync $@\n 27 | done\n 28 | if [ $i -eq $MAX_RETRIES ]\n 29 | then\n 30 | echo "Hit maximum number of retries, giving up."\n 31 | exit 1\n 32 | fi\n 33 | |} 34 | 35 | let add_rsync_retry_script = 36 | Obuilder_spec.run 37 | "printf '%s' | sudo tee -a /usr/local/bin/rsync && sudo chmod +x \ 38 | /usr/local/bin/rsync && ls -l /usr/bin/rsync && cat /usr/local/bin/rsync" 39 | rsync_retry_script 40 | 41 | let network = [ "host" ] 42 | 43 | let make base = 44 | let open Obuilder_spec in 45 | { 46 | base; 47 | ops = 48 | [ 49 | user_unix ~uid:1000 ~gid:1000; 50 | run ~network 51 | "sudo ln -f /usr/bin/opam-2.3 /usr/bin/opam && opam init --reinit -ni"; 52 | workdir "/home/opam"; 53 | run "sudo chown opam:opam /home/opam"; 54 | ]; 55 | children = []; 56 | } 57 | 58 | let to_ocluster_spec build_spec = 59 | let spec_str = Fmt.to_to_string Obuilder_spec.pp (build_spec |> finish) in 60 | let open Cluster_api.Obuilder_job.Spec in 61 | { spec = `Contents spec_str } 62 | 63 | let to_spec build_spec = Fmt.to_to_string Obuilder_spec.pp (build_spec |> finish) 64 | -------------------------------------------------------------------------------- /src/lib/spec.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** An obuilder spec *) 3 | 4 | val make : string -> t 5 | (** [make image] Initialize the spec to build on [image] *) 6 | 7 | val add : Obuilder_spec.op list -> t -> t 8 | (** Add instructions to the spec *) 9 | 10 | val children : name:string -> Obuilder_spec.t -> t -> t 11 | (** Add child build to the spec *) 12 | 13 | val finish : t -> Obuilder_spec.t 14 | (** Finalize the spec and obtain the obuilder content. *) 15 | 16 | val to_ocluster_spec : t -> Cluster_api.Obuilder_job.Spec.t 17 | val to_spec : t -> string 18 | val add_rsync_retry_script : Obuilder_spec.op 19 | -------------------------------------------------------------------------------- /src/lib/storage.ml: -------------------------------------------------------------------------------- 1 | module Base = struct 2 | type repository = HtmlRaw of Epoch.t | Linked of Epoch.t | Compile | Prep 3 | 4 | let generation_folder stage generation = 5 | Fpath.(v ("epoch-" ^ Epoch.digest stage generation)) 6 | 7 | let folder = function 8 | | HtmlRaw generation -> 9 | Fpath.(generation_folder `Html generation / "html-raw") 10 | | Linked generation -> 11 | Fpath.(generation_folder `Linked generation / "linked") 12 | | Compile -> Fpath.v "compile" 13 | | Prep -> Fpath.v "prep" 14 | end 15 | 16 | type repository = 17 | | HtmlRaw of (Epoch.t * Package.Blessing.t) 18 | | Linked of (Epoch.t * Package.Blessing.t) 19 | | Compile of Package.Blessing.t 20 | | Prep 21 | 22 | let to_base_repo = function 23 | | HtmlRaw (t, _) -> Base.HtmlRaw t 24 | | Linked (t, _) -> Linked t 25 | | Compile _ -> Compile 26 | | Prep -> Prep 27 | 28 | let base_folder ~blessed ~prep package = 29 | let universes = if prep then "universes" else "u" in 30 | let universe = Package.universe package |> Package.Universe.hash in 31 | let opam = Package.opam package in 32 | let name = OpamPackage.name_to_string opam in 33 | let version = OpamPackage.version_to_string opam in 34 | if blessed then Fpath.(v "p" / name / version) 35 | else Fpath.(v universes / universe / name / version) 36 | 37 | let folder repository package = 38 | let blessed = 39 | match repository with 40 | | HtmlRaw (_, b) | Linked (_, b) | Compile b -> b 41 | | Prep -> Universe 42 | in 43 | let blessed = blessed = Blessed in 44 | Fpath.( 45 | Base.folder (to_base_repo repository) 46 | // base_folder ~blessed ~prep:(repository = Prep) package) 47 | 48 | let for_all packages command = 49 | let data = 50 | let pp_package f (repository, package) = 51 | let dir = folder repository package |> Fpath.to_string in 52 | let id = Package.id package in 53 | Fmt.pf f "%s,%s,%s" dir id (Package.opam package |> OpamPackage.to_string) 54 | in 55 | Fmt.(to_to_string (list ~sep:(const string " ") pp_package) packages) 56 | in 57 | Fmt.str "for DATA in %s; do IFS=\",\"; set -- $DATA; %s done" data command 58 | 59 | type id_hash = { id : string; hash : string } [@@deriving yojson] 60 | 61 | module Tar = struct 62 | let hash_command ?(extra_files = []) ~prefix () = 63 | match extra_files with 64 | | [] -> 65 | Fmt.str 66 | "HASH=$((sha256sum $1/content.tar | cut -d \" \" -f 1) || echo -n \ 67 | 'empty'); printf \"%s:$2:$HASH\\n\";" 68 | prefix 69 | | extra_files -> 70 | Fmt.str 71 | "HASH=$((sha256sum $1/content.tar %s | sort | sha256sum | cut -d \" \ 72 | \" -f 1) || echo -n 'empty'); printf \"%s:$2:$HASH\\n\";" 73 | (List.map (fun f -> "\"$1/" ^ f ^ "\"") extra_files 74 | |> String.concat " ") 75 | prefix 76 | end 77 | 78 | let hash_command ~prefix = 79 | Fmt.str 80 | "HASH=$(find $1 -type f -exec sha256sum {} \\; | sort | sha256sum); printf \ 81 | \"%s:$2:$HASH\\n\";" 82 | prefix 83 | 84 | let parse_hash ~prefix line = 85 | match String.split_on_char ':' line with 86 | | [ prev; id; hash ] when Astring.String.is_suffix ~affix:prefix prev -> 87 | Some { id; hash } 88 | | _ -> None 89 | -------------------------------------------------------------------------------- /src/lib/storage.mli: -------------------------------------------------------------------------------- 1 | type repository = 2 | | HtmlRaw of (Epoch.t * Package.Blessing.t) 3 | | Linked of (Epoch.t * Package.Blessing.t) 4 | | Compile of Package.Blessing.t 5 | | Prep 6 | 7 | val folder : repository -> Package.t -> Fpath.t 8 | 9 | module Base : sig 10 | type repository = HtmlRaw of Epoch.t | Linked of Epoch.t | Compile | Prep 11 | 12 | val folder : repository -> Fpath.t 13 | val generation_folder : Epoch.stage -> Epoch.t -> Fpath.t 14 | end 15 | 16 | (* [for_all repo packages command] is a command that executes [command] for all [packages] folders in [repo]. 17 | $1 contains the folder. $2 contains the package id. *) 18 | val for_all : (repository * Package.t) list -> string -> string 19 | 20 | type id_hash = { id : string; hash : string } [@@deriving yojson] 21 | 22 | (* print sha256 hash of the files $1 or empty if it doesn't exist as following line: 23 | :$HASH:$2*) 24 | val hash_command : prefix:string -> string 25 | 26 | module Tar : sig 27 | (* print sha256 hash of $1/content.tar or empty if it doesn't exist as following line: 28 | :$HASH:$2*) 29 | val hash_command : ?extra_files:string list -> prefix:string -> unit -> string 30 | end 31 | 32 | (* parse a line created by the previous command *) 33 | val parse_hash : prefix:string -> string -> id_hash option 34 | -------------------------------------------------------------------------------- /src/lib/symlink.ml: -------------------------------------------------------------------------------- 1 | module Op = struct 2 | type t = Config.Ssh.t * Current.Level.t 3 | 4 | module Key = struct 5 | type t = Fpath.t 6 | 7 | let digest = Fpath.to_string 8 | end 9 | 10 | module Value = Key 11 | module Outcome = Current.Unit 12 | 13 | let id = "symlink-folder" 14 | let pp f (k, v) = Fmt.pf f "Symlink folder: %a -> %a" Fpath.pp k Fpath.pp v 15 | let auto_cancel = true 16 | 17 | let publish (ssh, level) job name target_folder = 18 | let open Lwt.Syntax in 19 | let module Ssh = Config.Ssh in 20 | let* () = Current.Job.start ~level job in 21 | let live_file = Fpath.add_ext "log" name in 22 | let date_format = {|+"%Y-%m-%d %T"|} in 23 | let command = 24 | Bos.Cmd.( 25 | v "ssh" 26 | % "-p" 27 | % Int.to_string (Ssh.port ssh) 28 | % "-i" 29 | % p (Ssh.priv_key_file ssh) 30 | % (Ssh.user ssh ^ "@" ^ Ssh.host ssh) 31 | % Fmt.str "ln -sfT %a %a && echo `date %s` '%a' >> %a" Fpath.pp 32 | target_folder Fpath.pp name date_format Fpath.pp target_folder 33 | Fpath.pp live_file) 34 | in 35 | Current.Process.exec ~cancellable:true ~job 36 | ("", Bos.Cmd.to_list command |> Array.of_list) 37 | end 38 | 39 | module Publish = Current_cache.Output (Op) 40 | 41 | let remote_symbolic_link ?(level = Current.Level.Dangerous) ~ssh ~target ~name 42 | () = 43 | Publish.set (ssh, level) name target 44 | -------------------------------------------------------------------------------- /src/lib/symlink.mli: -------------------------------------------------------------------------------- 1 | (** Create a symbolic link on the [ssh] remove with [name] pointing to [target]. 2 | The command is `ln -sfT [target] [name]`. By default it's considered as a 3 | dangerous operation. *) 4 | 5 | val remote_symbolic_link : 6 | ?level:Current.Level.t -> 7 | ssh:Config.Ssh.t -> 8 | target:Fpath.t -> 9 | name:Fpath.t -> 10 | unit -> 11 | unit Current.Primitive.t 12 | -------------------------------------------------------------------------------- /src/lib/track.ml: -------------------------------------------------------------------------------- 1 | module Git = Current_git 2 | 3 | module OpamPackage = struct 4 | include OpamPackage 5 | 6 | let to_yojson t = `String (OpamPackage.to_string t) 7 | 8 | let of_yojson = function 9 | | `String str -> ( 10 | match OpamPackage.of_string_opt str with 11 | | Some x -> Ok x 12 | | None -> Error "failed to parse version") 13 | | _ -> Error "failed to parse version" 14 | end 15 | 16 | module Track = struct 17 | type t = No_context 18 | 19 | let id = "opam-repo-track" 20 | let auto_cancel = true 21 | 22 | module Key = struct 23 | type t = { limit : int option; repo : Git.Commit.t; filter : string list } 24 | 25 | let digest { repo; filter; limit } = 26 | Git.Commit.hash repo 27 | ^ String.concat ";" filter 28 | ^ "; " 29 | ^ (limit |> Option.map string_of_int |> Option.value ~default:"") 30 | end 31 | 32 | let pp f { Key.repo; filter; _ } = 33 | Fmt.pf f "opam repo track\n%a\n%a" Git.Commit.pp_short repo 34 | Fmt.(list string) 35 | filter 36 | 37 | module Value = struct 38 | type package_definition = { package : OpamPackage.t; digest : string } 39 | [@@deriving yojson] 40 | 41 | type t = package_definition list [@@deriving yojson] 42 | 43 | let marshal t = t |> to_yojson |> Yojson.Safe.to_string 44 | let unmarshal t = t |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok 45 | end 46 | 47 | let rec take n lst = 48 | match (n, lst) with 49 | | 0, _ -> [] 50 | | _, [] -> [] 51 | | n, a :: q -> a :: take (n - 1) q 52 | 53 | let take = function Some n -> take n | None -> Fun.id 54 | 55 | let get_file path = 56 | Lwt_io.with_file ~mode:Input (Fpath.to_string path) Lwt_io.read 57 | 58 | let get_versions ~limit path = 59 | let open Lwt.Syntax in 60 | let open Rresult in 61 | Bos.OS.Dir.contents path 62 | >>| (fun versions -> 63 | versions 64 | |> Lwt_list.map_p (fun path -> 65 | let+ content = get_file Fpath.(path / "opam") in 66 | Value. 67 | { 68 | package = path |> Fpath.basename |> OpamPackage.of_string; 69 | digest = Digest.(string content |> to_hex); 70 | })) 71 | |> Result.get_ok 72 | |> Lwt.map (fun v -> 73 | v 74 | |> List.sort (fun a b -> 75 | -OpamPackage.compare a.Value.package b.package) 76 | |> take limit) 77 | 78 | let build No_context job { Key.repo; filter; limit } = 79 | let open Lwt.Syntax in 80 | let open Rresult in 81 | let filter name = 82 | match filter with [] -> true | lst -> List.mem (Fpath.basename name) lst 83 | in 84 | let* () = Current.Job.start ~level:Harmless job in 85 | Git.with_checkout ~job repo @@ fun dir -> 86 | let result = 87 | Bos.OS.Dir.contents Fpath.(dir / "packages") >>| fun packages -> 88 | packages 89 | |> List.filter filter 90 | |> Lwt_list.map_s (get_versions ~limit) 91 | |> Lwt.map (fun v -> List.flatten v) 92 | in 93 | match result with 94 | | Ok v -> Lwt.map Result.ok v 95 | | Error e -> Lwt.return_error e 96 | end 97 | 98 | module TrackCache = Misc.LatchedBuilder (Track) 99 | open Track.Value 100 | 101 | type t = package_definition [@@deriving yojson] 102 | 103 | let pkg t = t.package 104 | let digest t = t.digest 105 | 106 | module Map = OpamStd.Map.Make (struct 107 | type nonrec t = t 108 | 109 | let compare a b = O.OpamPackage.compare a.package b.package 110 | 111 | let to_json { package; digest } = 112 | `A [ OpamPackage.to_json package; `String digest ] 113 | 114 | let of_json _ = None 115 | let to_string t = OpamPackage.to_string t.package 116 | end) 117 | 118 | let v ~limit ~(filter : string list) (repo : Git.Commit.t Current.t) = 119 | let open Current.Syntax in 120 | Current.component "Track packages - %a" Fmt.(list string) filter 121 | |> let> repo in 122 | (* opkey is a constant because we expect only one instance of track *) 123 | TrackCache.get ~opkey:"track" No_context { filter; repo; limit } 124 | -------------------------------------------------------------------------------- /src/lib/track.mli: -------------------------------------------------------------------------------- 1 | type t [@@deriving yojson] 2 | 3 | val digest : t -> string 4 | val pkg : t -> OpamPackage.t 5 | 6 | val v : 7 | limit:int option -> 8 | filter:string list -> 9 | Current_git.Commit.t Current.t -> 10 | t list Current.t 11 | 12 | module Map : OpamStd.MAP with type key = t 13 | -------------------------------------------------------------------------------- /src/lib/voodoo.ml: -------------------------------------------------------------------------------- 1 | let network = [ "host" ] 2 | 3 | let download_cache = 4 | Obuilder_spec.Cache.v "opam-archives" 5 | ~target:"/home/opam/.opam/download-cache" 6 | 7 | let dune_cache = 8 | Obuilder_spec.Cache.v "opam-dune-cache" ~target:"/home/opam/.cache/dune" 9 | 10 | let cache = [ download_cache; dune_cache ] 11 | 12 | module Git = Current_git 13 | 14 | type t0 = { 15 | voodoo_do : Git.Commit_id.t; 16 | voodoo_prep : Git.Commit_id.t; 17 | voodoo_gen : Git.Commit_id.t; 18 | } 19 | 20 | module Op = struct 21 | type voodoo = t0 22 | type t = No_context 23 | 24 | let id = "voodoo-repository" 25 | let pp f _ = Fmt.pf f "voodoo-repository" 26 | let auto_cancel = false 27 | 28 | module Key = struct 29 | type t = Git.Commit.t 30 | 31 | let digest = Git.Commit.hash 32 | end 33 | 34 | module Value = struct 35 | type t = voodoo 36 | 37 | let to_yojson commit = 38 | let hash = Git.Commit_id.hash commit in 39 | let repo = Git.Commit_id.repo commit in 40 | let gref = Git.Commit_id.gref commit in 41 | `Assoc 42 | [ 43 | ("hash", `String hash); ("repo", `String repo); ("gref", `String gref); 44 | ] 45 | 46 | let of_yojson_exn json = 47 | let open Yojson.Safe.Util in 48 | let hash = json |> member "hash" |> to_string in 49 | let gref = json |> member "gref" |> to_string in 50 | let repo = json |> member "repo" |> to_string in 51 | Git.Commit_id.v ~repo ~gref ~hash 52 | 53 | let marshal { voodoo_do; voodoo_prep; voodoo_gen } = 54 | `Assoc 55 | [ 56 | ("do", to_yojson voodoo_do); 57 | ("prep", to_yojson voodoo_prep); 58 | ("gen", to_yojson voodoo_gen); 59 | ] 60 | |> Yojson.Safe.to_string 61 | 62 | let unmarshal t = 63 | let json = Yojson.Safe.from_string t in 64 | let open Yojson.Safe.Util in 65 | let voodoo_do = json |> member "do" |> of_yojson_exn in 66 | let voodoo_prep = json |> member "prep" |> of_yojson_exn in 67 | let voodoo_gen = json |> member "gen" |> of_yojson_exn in 68 | { voodoo_do; voodoo_prep; voodoo_gen } 69 | end 70 | 71 | let voodoo_prep_paths = Fpath.[ v "voodoo-prep.opam"; v "src/voodoo-prep/" ] 72 | 73 | let voodoo_do_paths = 74 | Fpath. 75 | [ 76 | v "voodoo-do.opam"; 77 | v "voodoo-lib.opam"; 78 | v "src/voodoo-do/"; 79 | v "src/voodoo/"; 80 | ] 81 | 82 | let voodoo_gen_paths = 83 | Fpath. 84 | [ 85 | v "voodoo-gen.opam"; 86 | v "src/voodoo-gen/"; 87 | v "src/voodoo/"; 88 | v "src/voodoo-web/"; 89 | ] 90 | 91 | let get_oldest_commit_for ~job ~dir ~from paths = 92 | let paths = List.map Fpath.to_string paths in 93 | let cmd = 94 | "git" 95 | :: "log" 96 | :: "-n" 97 | :: "1" 98 | :: "--format=format:%H" 99 | :: from 100 | :: "--" 101 | :: paths 102 | in 103 | let cmd = ("", Array.of_list cmd) in 104 | Current.Process.check_output ~cwd:dir ~job ~cancellable:false cmd 105 | |> Lwt_result.map String.trim 106 | 107 | let with_hash ~id hash = 108 | Git.Commit_id.v ~repo:(Git.Commit_id.repo id) ~gref:(Git.Commit_id.gref id) 109 | ~hash 110 | 111 | let build No_context job commit = 112 | let open Lwt.Syntax in 113 | let ( let** ) = Lwt_result.bind in 114 | let* () = Current.Job.start ~level:Harmless job in 115 | Git.with_checkout ~job commit @@ fun dir -> 116 | let id = Git.Commit.id commit in 117 | let from = Git.Commit_id.hash id in 118 | let** voodoo_prep = 119 | get_oldest_commit_for ~job ~dir ~from voodoo_prep_paths 120 | in 121 | let** voodoo_do = get_oldest_commit_for ~job ~dir ~from voodoo_do_paths in 122 | let** voodoo_gen = get_oldest_commit_for ~job ~dir ~from voodoo_gen_paths in 123 | Current.Job.log job "Prep commit: %s" voodoo_prep; 124 | Current.Job.log job "Do commit: %s" voodoo_do; 125 | Current.Job.log job "Gen commit: %s" voodoo_gen; 126 | let voodoo_prep = with_hash ~id voodoo_prep in 127 | let voodoo_do = with_hash ~id voodoo_do in 128 | let voodoo_gen = with_hash ~id voodoo_gen in 129 | Lwt.return_ok { voodoo_prep; voodoo_do; voodoo_gen } 130 | end 131 | 132 | module VoodooCache = Current_cache.Make (Op) 133 | 134 | let v ~gref ~repo () = 135 | let daily = Current_cache.Schedule.v ~valid_for:(Duration.of_day 1) () in 136 | let git = Git.clone ~schedule:daily ~gref repo in 137 | let open Current.Syntax in 138 | Current.component "voodoo" 139 | |> let> git in 140 | VoodooCache.get No_context git 141 | 142 | type t = { 143 | voodoo_do : Git.Commit_id.t; 144 | voodoo_prep : Git.Commit_id.t; 145 | voodoo_gen : Git.Commit_id.t; 146 | config : Config.t; 147 | } 148 | 149 | let v config = 150 | let open Current.Syntax in 151 | let+ { voodoo_do; voodoo_prep; voodoo_gen } = 152 | v ~gref:(Config.voodoo_branch config) ~repo:(Config.voodoo_repo config) () 153 | in 154 | { voodoo_do; voodoo_prep; voodoo_gen; config } 155 | 156 | let remote_uri commit = 157 | let repo = Git.Commit_id.repo commit in 158 | let commit = Git.Commit_id.hash commit in 159 | repo ^ "#" ^ commit 160 | 161 | let digest t = 162 | let key = 163 | Fmt.str "%s\n%s\n%s\n" 164 | (Git.Commit_id.hash t.voodoo_prep) 165 | (Git.Commit_id.hash t.voodoo_do) 166 | (Git.Commit_id.hash t.voodoo_gen) 167 | in 168 | Digest.(string key |> to_hex) 169 | 170 | module Prep = struct 171 | type voodoo = t 172 | type t = Git.Commit_id.t 173 | 174 | let v { voodoo_prep; _ } = voodoo_prep 175 | 176 | let spec ~base t = 177 | let open Obuilder_spec in 178 | base 179 | |> Spec.add 180 | [ 181 | run ~network 182 | "sudo apt-get update && sudo apt-get install -yy m4 pkg-config"; 183 | run ~network ~cache "opam pin -ny %s && opam install -y voodoo-prep" 184 | (remote_uri t); 185 | run "cp $(opam config var bin)/voodoo-prep /home/opam"; 186 | ] 187 | 188 | let digest = Git.Commit_id.hash 189 | let commit = Fun.id 190 | end 191 | 192 | module Do = struct 193 | type voodoo = t 194 | 195 | type t = { commit : Git.Commit_id.t; config : Config.t } 196 | [@@ocaml.warning "-69"] 197 | 198 | let v { voodoo_do; config; _ } = { commit = voodoo_do; config } 199 | 200 | let spec ~base t = 201 | let open Obuilder_spec in 202 | base 203 | |> Spec.add 204 | [ 205 | run ~network "sudo apt-get update && sudo apt-get install -yy m4"; 206 | run ~network ~cache "opam pin -ny %s && opam install -y voodoo-do" 207 | (remote_uri t.commit); 208 | run 209 | "cp $(opam config var bin)/odoc $(opam config var bin)/voodoo-do \ 210 | /home/opam"; 211 | ] 212 | 213 | let digest t = Git.Commit_id.hash t.commit 214 | let commit t = t.commit 215 | end 216 | 217 | module Gen = struct 218 | type voodoo = t 219 | type t = { commit : Git.Commit_id.t } 220 | 221 | let v { voodoo_gen; _ } = { commit = voodoo_gen } 222 | 223 | let spec ~base t = 224 | let open Obuilder_spec in 225 | base 226 | |> Spec.add 227 | [ 228 | run ~network "sudo apt-get update && sudo apt-get install -yy m4"; 229 | run ~network ~cache "opam pin -ny %s && opam install -y voodoo-gen" 230 | (remote_uri t.commit); 231 | run 232 | "cp $(opam config var bin)/odoc $(opam config var bin)/voodoo-gen \ 233 | /home/opam"; 234 | ] 235 | 236 | let digest t = Git.Commit_id.hash t.commit 237 | let commit t = t.commit 238 | end 239 | -------------------------------------------------------------------------------- /src/lib/voodoo.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val v : Config.t -> t Current.t 4 | val cache : Obuilder_spec.Cache.t list 5 | val digest : t -> string 6 | 7 | module Prep : sig 8 | type voodoo = t 9 | type t 10 | 11 | val spec : base:Spec.t -> t -> Spec.t 12 | val v : voodoo -> t 13 | val digest : t -> string 14 | val commit : t -> Current_git.Commit_id.t 15 | end 16 | 17 | module Do : sig 18 | type voodoo = t 19 | type t 20 | 21 | val spec : base:Spec.t -> t -> Spec.t 22 | val v : voodoo -> t 23 | val digest : t -> string 24 | val commit : t -> Current_git.Commit_id.t 25 | end 26 | 27 | module Gen : sig 28 | type voodoo = t 29 | type t 30 | 31 | val spec : base:Spec.t -> t -> Spec.t 32 | val v : voodoo -> t 33 | val digest : t -> string 34 | val commit : t -> Current_git.Commit_id.t 35 | end 36 | -------------------------------------------------------------------------------- /src/logging.ml: -------------------------------------------------------------------------------- 1 | let reporter = 2 | let report src level ~over k msgf = 3 | let k _ = 4 | over (); 5 | k () 6 | in 7 | let src = Logs.Src.name src in 8 | msgf @@ fun ?header ?tags:_ fmt -> 9 | Fmt.kpf k Fmt.stdout 10 | ("%a %a @[" ^^ fmt ^^ "@]@.") 11 | Fmt.(styled `Magenta string) 12 | (Printf.sprintf "%14s" src) 13 | Logs_fmt.pp_header (level, header) 14 | in 15 | { Logs.report } 16 | 17 | let init ?(level = Logs.Info) () = 18 | Fmt_tty.setup_std_outputs (); 19 | Logs.set_level (Some level); 20 | Logs.set_reporter reporter 21 | 22 | let run x = 23 | match Lwt_main.run x with 24 | | Ok () -> Ok () 25 | | Error (`Msg m) as e -> 26 | Logs.err (fun f -> f "%a" Fmt.lines m); 27 | e 28 | -------------------------------------------------------------------------------- /src/logging.mli: -------------------------------------------------------------------------------- 1 | val init : ?level:Logs.level -> unit -> unit 2 | (** Initialise the Logs library with some sensible defaults. *) 3 | 4 | val run : unit Current.or_error Lwt.t -> unit Current.or_error 5 | (** [run x] is like [Lwt_main.run x], but logs the returned error, if any. *) 6 | -------------------------------------------------------------------------------- /src/ocaml_docs_ci.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Capnp_rpc_lwt 3 | module Git = Current_git 4 | 5 | let setup_log default_level = 6 | Prometheus_unix.Logging.init ?default_level (); 7 | Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna); 8 | Logging.init (); 9 | Memtrace.trace_if_requested ~context:"ocaml-docs-ci" () 10 | 11 | let hourly = Current_cache.Schedule.v ~valid_for:(Duration.of_hour 1) () 12 | let program_name = "ocaml-docs-ci" 13 | 14 | (* Access control policy. *) 15 | let has_role user = function 16 | | `Viewer | `Monitor -> true 17 | | _ -> ( 18 | match Option.map Current_web.User.id user with 19 | | Some 20 | ( "github:talex5" | "github:avsm" | "github:kit-ty-kate" 21 | | "github:samoht" | "github:tmcgilchrist" | "github:dra27" 22 | | "github:jonludlam" | "github:TheLortex" | "github:sabine" 23 | | "github:mtelvers" | "github:shonfeder" ) -> 24 | true 25 | | _ -> false) 26 | 27 | let or_die = function Ok x -> x | Error (`Msg m) -> failwith m 28 | 29 | let check_dir x = 30 | Lwt.catch 31 | (fun () -> 32 | Lwt_unix.stat x >|= function 33 | | Unix.{ st_kind = S_DIR; _ } -> `Present 34 | | _ -> Fmt.failwith "Exists, but is not a directory: %S" x) 35 | (function 36 | | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return `Missing 37 | | exn -> Lwt.fail exn) 38 | 39 | let ensure_dir path = 40 | check_dir path >>= function 41 | | `Present -> 42 | Logs.info (fun f -> f "Directory %s exists" path); 43 | Lwt.return_unit 44 | | `Missing -> 45 | Logs.info (fun f -> f "Creating %s directory" path); 46 | Lwt_unix.mkdir path 0o777 47 | 48 | let run_capnp capnp_public_address capnp_listen_address = 49 | match (capnp_public_address, capnp_listen_address) with 50 | | None, None -> Lwt.return (Capnp_rpc_unix.client_only_vat (), None) 51 | | Some _, None -> 52 | Lwt.fail_invalid_arg 53 | "Public address for Cap'n Proto RPC can't be set without setting a \ 54 | capnp-listen-address to listen on." 55 | | Some _, Some _ | None, Some _ -> 56 | let ci_profile = 57 | match Sys.getenv_opt "CI_PROFILE" with 58 | | Some "production" | None -> `Production 59 | | Some "dev" -> `Dev 60 | | Some x -> Fmt.failwith "Unknown $CI_PROFILE setting %S." x 61 | in 62 | let cap_secrets = 63 | match ci_profile with 64 | | `Production -> "/capnp-secrets" 65 | | `Dev -> "./capnp-secrets" 66 | in 67 | let secret_key = cap_secrets ^ "/secret-key.pem" in 68 | let cap_file = cap_secrets ^ "/ocaml-docs-ci.cap" in 69 | let internal_port = 9000 in 70 | 71 | let listen_address = 72 | match capnp_listen_address with 73 | | Some listen_address -> listen_address 74 | | None -> 75 | Capnp_rpc_unix.Network.Location.tcp ~host:"0.0.0.0" 76 | ~port:internal_port 77 | in 78 | let public_address = 79 | match capnp_public_address with 80 | | None -> listen_address 81 | | Some public_address -> public_address 82 | in 83 | ensure_dir cap_secrets >>= fun () -> 84 | let config = 85 | Capnp_rpc_unix.Vat_config.create ~public_address 86 | ~secret_key:(`File secret_key) listen_address 87 | in 88 | let rpc_engine, rpc_engine_resolver = Capability.promise () in 89 | let service_id = Capnp_rpc_unix.Vat_config.derived_id config "ci" in 90 | let restore = Capnp_rpc_net.Restorer.single service_id rpc_engine in 91 | Capnp_rpc_unix.serve config ~restore >>= fun vat -> 92 | Capnp_rpc_unix.Cap_file.save_service vat service_id cap_file |> or_die; 93 | Logs.app (fun f -> f "Wrote capability reference to %S" cap_file); 94 | Lwt.return (vat, Some rpc_engine_resolver) 95 | 96 | let main () current_config github_auth mode capnp_public_address 97 | capnp_listen_address config migrations = 98 | ignore 99 | @@ Logging.run 100 | (let () = 101 | match Docs_ci_lib.Init.setup (Docs_ci_lib.Config.ssh config) with 102 | | Ok () -> () 103 | | Error (`Msg msg) -> 104 | Docs_ci_lib.Log.err (fun f -> 105 | f "Failed to initialize the storage server:\n%s" msg); 106 | exit 1 107 | in 108 | run_capnp capnp_public_address capnp_listen_address 109 | >>= fun (_vat, rpc_engine_resolver) -> 110 | let repo_opam = 111 | Git.clone ~schedule:hourly 112 | "https://github.com/ocaml/opam-repository.git" 113 | in 114 | let monitor = Docs_ci_lib.Monitor.make () in 115 | let engine = 116 | Current.Engine.create ~config:current_config (fun () -> 117 | Docs_ci_pipelines.Docs.v ~config ~opam:repo_opam ~monitor 118 | ~migrations () 119 | |> Current.ignore_value) 120 | in 121 | rpc_engine_resolver 122 | |> Option.iter (fun r -> 123 | Capability.resolve_ok r 124 | (Docs_ci_pipelines.Api_impl.make ~monitor)); 125 | 126 | let has_role = 127 | if github_auth = None then Current_web.Site.allow_all else has_role 128 | in 129 | let secure_cookies = github_auth <> None in 130 | let authn = Option.map Current_github.Auth.make_login_uri github_auth in 131 | let site = 132 | let routes = 133 | Routes.( 134 | (s "login" /? nil) @--> Current_github.Auth.login github_auth) 135 | :: Docs_ci_lib.Monitor.routes monitor engine 136 | @ Current_web.routes engine 137 | in 138 | Current_web.Site.(v ?authn ~has_role ~secure_cookies) 139 | ~name:program_name routes 140 | in 141 | Lwt.choose 142 | [ 143 | Current.Engine.thread engine; 144 | (* The main thread evaluating the pipeline. *) 145 | Current_web.run ~mode site (* Optional: provides a web UI *); 146 | ]) 147 | 148 | (* Command-line parsing *) 149 | 150 | open Cmdliner 151 | 152 | let setup_log = 153 | let docs = Manpage.s_common_options in 154 | Term.(const setup_log $ Logs_cli.level ~docs ()) 155 | 156 | let capnp_public_address = 157 | Arg.value 158 | @@ Arg.opt (Arg.some Capnp_rpc_unix.Network.Location.cmdliner_conv) None 159 | @@ Arg.info 160 | ~doc: 161 | "Public address (SCHEME:HOST:PORT) for Cap'n Proto RPC (default: no \ 162 | RPC).\n\ 163 | \ If --capnp-listen-address isn't set it will run no RPC." 164 | ~docv:"ADDR" [ "capnp-public-address" ] 165 | 166 | let capnp_listen_address = 167 | let i = 168 | Arg.info ~docv:"ADDR" 169 | ~doc: 170 | "Address to listen on, e.g. $(b,unix:/run/my.socket) (default: no RPC)." 171 | [ "capnp-listen-address" ] 172 | in 173 | Arg.( 174 | value 175 | @@ opt (Arg.some Capnp_rpc_unix.Network.Location.cmdliner_conv) None 176 | @@ i) 177 | 178 | let migrations = 179 | Arg.( 180 | value 181 | @@ opt (some dir) None 182 | @@ info ~docv:"MIGRATIONS_PATH" 183 | ~doc: 184 | "Specify the path to the migration directory. If no path is given \ 185 | the migration step is ignored." 186 | [ "migration-path" ]) 187 | 188 | let version = 189 | match Build_info.V1.version () with 190 | | None -> "n/a" 191 | | Some v -> Build_info.V1.Version.to_string v 192 | 193 | let cmd = 194 | let doc = "An OCurrent pipeline" in 195 | let info = Cmd.info program_name ~doc ~version in 196 | Cmd.v info 197 | Term.( 198 | const main 199 | $ setup_log 200 | $ Current.Config.cmdliner 201 | $ Current_github.Auth.cmdliner 202 | $ Current_web.cmdliner 203 | $ capnp_public_address 204 | $ capnp_listen_address 205 | $ Docs_ci_lib.Config.cmdliner 206 | $ migrations) 207 | 208 | let () = exit @@ Cmd.eval cmd 209 | -------------------------------------------------------------------------------- /src/ocaml_docs_ci.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocurrent/ocaml-docs-ci/4dfe7e6265610da4e0ce2a386cfbf0b8eac3d9bd/src/ocaml_docs_ci.mli -------------------------------------------------------------------------------- /src/pipelines/dune: -------------------------------------------------------------------------------- 1 | ;; 2 | 3 | (library 4 | (name docs_ci_pipelines) 5 | (package ocaml-docs-ci) 6 | (libraries 7 | docs_ci_lib 8 | current 9 | current.cache 10 | current_github 11 | current_git 12 | current_web 13 | current_docker 14 | current_rpc 15 | capnp-rpc-unix 16 | pipeline_api 17 | astring 18 | dockerfile 19 | cmdliner 20 | fmt.tty 21 | logs.fmt 22 | lwt 23 | lwt.unix 24 | obuilder-spec 25 | opam-file-format) 26 | (preprocess 27 | (pps ppx_deriving_yojson))) 28 | -------------------------------------------------------------------------------- /src/solver/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (package ocaml-docs-ci) 4 | (public_name ocaml-docs-ci-solver) 5 | (preprocess 6 | (pps ppx_deriving.std ppx_deriving_yojson)) 7 | (libraries 8 | lwt.unix 9 | solver_api 10 | ppx_deriving_yojson.runtime 11 | opam-0install 12 | capnp-rpc-unix 13 | git-unix)) 14 | -------------------------------------------------------------------------------- /src/solver/epoch_lock.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | type 'a t = { 4 | mutable current : 5 | [ `Idle 6 | | `Activating of unit Lwt.t (* Promise resolves after moving to [`Active] *) 7 | | `Active of string * 'a 8 | | `Draining of 9 | unit Lwt.t * unit Lwt_condition.t 10 | (* Promise resolves after moving back to [`Active] *) ]; 11 | mutable users : int; 12 | (* Zero unless active or draining *) 13 | create : string -> 'a Lwt.t; 14 | dispose : 'a -> unit Lwt.t; 15 | } 16 | 17 | let activate t epoch ~ready ~set_ready = 18 | t.current <- `Activating ready; 19 | t.create epoch >|= fun v -> 20 | t.current <- `Active (epoch, v); 21 | Lwt.wakeup_later set_ready () 22 | 23 | let rec with_epoch t epoch fn = 24 | match t.current with 25 | | `Active (current_epoch, v) when current_epoch = epoch -> 26 | t.users <- t.users + 1; 27 | Lwt.finalize 28 | (fun () -> fn v) 29 | (fun () -> 30 | t.users <- t.users - 1; 31 | (match t.current with 32 | | `Active _ -> () 33 | | `Draining (_, cond) -> 34 | if t.users = 0 then Lwt_condition.broadcast cond () 35 | | `Idle | `Activating _ -> assert false); 36 | Lwt.return_unit) 37 | | `Active (_, old_v) -> 38 | let cond = Lwt_condition.create () in 39 | let ready, set_ready = Lwt.wait () in 40 | t.current <- `Draining (ready, cond); 41 | (* After this point, no new users can start. *) 42 | let rec drain () = 43 | if t.users = 0 then Lwt.return_unit 44 | else Lwt_condition.wait cond >>= drain 45 | in 46 | drain () >>= fun () -> 47 | t.dispose old_v >>= fun () -> 48 | activate t epoch ~ready ~set_ready >>= fun () -> with_epoch t epoch fn 49 | | `Draining (ready, _) | `Activating ready -> 50 | ready >>= fun () -> with_epoch t epoch fn 51 | | `Idle -> 52 | let ready, set_ready = Lwt.wait () in 53 | activate t epoch ~ready ~set_ready >>= fun () -> with_epoch t epoch fn 54 | 55 | let v ~create ~dispose () = { current = `Idle; users = 0; create; dispose } 56 | -------------------------------------------------------------------------------- /src/solver/epoch_lock.mli: -------------------------------------------------------------------------------- 1 | (** Divide jobs up into distinct epochs. Any number of jobs can run at the same 2 | time within an epoch, but changing epoch requires first draining the 3 | existing jobs, finishing the epoch, and then creating the new one. The 4 | solver uses this to handle updates to opam-repository (each commit is a 5 | separate epoch). *) 6 | 7 | type 'a t 8 | 9 | val v : 10 | create:(string -> 'a Lwt.t) -> dispose:('a -> unit Lwt.t) -> unit -> 'a t 11 | (** [v ~create ~dispose ()] is an epoch lock that calls [create] to start a new 12 | epoch and [dispose] to finish one. A new epoch doesn't start until the old 13 | one has been disposed. *) 14 | 15 | val with_epoch : 'a t -> string -> ('a -> 'b Lwt.t) -> 'b Lwt.t 16 | (** [with_epoch t epoch fn] runs [fn v] with the [v] for [epoch]. If we are 17 | already in [epoch], [fn] runs immediately. If we are already in another 18 | epoch then we wait for all users in the previous epoch to finish, then 19 | create a new one, then run [fn]. *) 20 | -------------------------------------------------------------------------------- /src/solver/git_context.ml: -------------------------------------------------------------------------------- 1 | module Store = Git_unix.Store 2 | module Search = Git.Search.Make (Digestif.SHA1) (Store) 3 | open Lwt.Infix 4 | 5 | type rejection = UserConstraint of OpamFormula.atom | Unavailable 6 | 7 | type t = { 8 | env : string -> OpamVariable.variable_contents option; 9 | packages : OpamFile.OPAM.t OpamPackage.Version.Map.t OpamPackage.Name.Map.t; 10 | pins : (OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t; 11 | constraints : OpamFormula.version_constraint OpamTypes.name_map; 12 | (* User-provided constraints *) 13 | test : OpamPackage.Name.Set.t; 14 | } 15 | 16 | let user_restrictions t name = OpamPackage.Name.Map.find_opt name t.constraints 17 | let dev = OpamPackage.Version.of_string "dev" 18 | 19 | let env t pkg v = 20 | if List.mem v OpamPackageVar.predefined_depends_variables then None 21 | else 22 | match OpamVariable.Full.to_string v with 23 | | "version" -> Some (OpamTypes.S (OpamPackage.version_to_string pkg)) 24 | | x -> t.env x 25 | 26 | let filter_deps t pkg f = 27 | let dev = OpamPackage.Version.compare (OpamPackage.version pkg) dev = 0 in 28 | let test = OpamPackage.Name.Set.mem (OpamPackage.name pkg) t.test in 29 | f 30 | |> OpamFilter.partial_filter_formula (env t pkg) 31 | |> OpamFilter.filter_deps ~build:true ~post:true ~test ~doc:false ~dev 32 | ~dev_setup:false ~default:false 33 | 34 | let candidates t name = 35 | match OpamPackage.Name.Map.find_opt name t.pins with 36 | | Some (version, opam) -> [ (version, Ok opam) ] 37 | | None -> ( 38 | match OpamPackage.Name.Map.find_opt name t.packages with 39 | | None -> 40 | OpamConsole.log "opam-0install" "Package %S not found!" 41 | (OpamPackage.Name.to_string name); 42 | [] 43 | | Some versions -> 44 | let user_constraints = user_restrictions t name in 45 | OpamPackage.Version.Map.bindings versions 46 | |> List.rev_map (fun (v, opam) -> 47 | match user_constraints with 48 | | Some test 49 | when not 50 | (OpamFormula.check_version_formula 51 | (OpamFormula.Atom test) v) -> 52 | (v, Error (UserConstraint (name, Some test))) 53 | | _ -> ( 54 | let pkg = OpamPackage.create name v in 55 | let available = OpamFile.OPAM.available opam in 56 | match 57 | OpamFilter.eval ~default:(B false) (env t pkg) available 58 | with 59 | | B true -> (v, Ok opam) 60 | | B false -> (v, Error Unavailable) 61 | | _ -> 62 | OpamConsole.error 63 | "Available expression not a boolean: %s" 64 | (OpamFilter.to_string available); 65 | (v, Error Unavailable)))) 66 | 67 | let pp_rejection f = function 68 | | UserConstraint x -> 69 | Fmt.pf f "Rejected by user-specified constraint %s" 70 | (OpamFormula.string_of_atom x) 71 | | Unavailable -> Fmt.string f "Availability condition not satisfied" 72 | 73 | let read_dir store hash = 74 | Store.read store hash >|= function 75 | | Error e -> Fmt.failwith "Failed to read tree: %a" Store.pp_error e 76 | | Ok (Git.Value.Tree tree) -> Some tree 77 | | Ok _ -> None 78 | 79 | let read_package store pkg hash = 80 | Search.find store hash (`Path [ "opam" ]) >>= function 81 | | None -> 82 | Fmt.failwith "opam file not found for %s" (OpamPackage.to_string pkg) 83 | | Some hash -> ( 84 | Store.read store hash >|= function 85 | | Ok (Git.Value.Blob blob) -> 86 | OpamFile.OPAM.read_from_string (Store.Value.Blob.to_string blob) 87 | | _ -> 88 | Fmt.failwith "Bad Git object type for %s!" (OpamPackage.to_string pkg) 89 | ) 90 | 91 | (* Get a map of the versions inside [entry] (an entry under "packages") *) 92 | let read_versions store (entry : Store.Value.Tree.entry) = 93 | read_dir store entry.node >>= function 94 | | None -> Lwt.return_none 95 | | Some tree -> 96 | Store.Value.Tree.to_list tree 97 | |> Lwt_list.fold_left_s 98 | (fun acc (entry : Store.Value.Tree.entry) -> 99 | match OpamPackage.of_string_opt entry.name with 100 | | Some pkg -> 101 | read_package store pkg entry.node >|= fun opam -> 102 | OpamPackage.Version.Map.add pkg.version opam acc 103 | | None -> 104 | OpamConsole.log "opam-0install" "Invalid package name %S" 105 | entry.name; 106 | Lwt.return acc) 107 | OpamPackage.Version.Map.empty 108 | >|= fun versions -> Some versions 109 | 110 | let read_packages store commit = 111 | Search.find store commit (`Commit (`Path [ "packages" ])) >>= function 112 | | None -> Fmt.failwith "Failed to find packages directory!" 113 | | Some tree_hash -> ( 114 | read_dir store tree_hash >>= function 115 | | None -> Fmt.failwith "'packages' is not a directory!" 116 | | Some tree -> 117 | Store.Value.Tree.to_list tree 118 | |> Lwt_list.fold_left_s 119 | (fun acc (entry : Store.Value.Tree.entry) -> 120 | match OpamPackage.Name.of_string entry.name with 121 | | exception ex -> 122 | OpamConsole.log "opam-0install" 123 | "Invalid package name %S: %s" entry.name 124 | (Printexc.to_string ex); 125 | Lwt.return acc 126 | | name -> ( 127 | read_versions store entry >|= function 128 | | None -> acc 129 | | Some versions -> 130 | OpamPackage.Name.Map.add name versions acc)) 131 | OpamPackage.Name.Map.empty) 132 | 133 | let create ?(test = OpamPackage.Name.Set.empty) 134 | ?(pins = OpamPackage.Name.Map.empty) ~constraints ~env ~packages () = 135 | { env; packages; pins; constraints; test } 136 | -------------------------------------------------------------------------------- /src/solver/git_context.mli: -------------------------------------------------------------------------------- 1 | include Opam_0install.S.CONTEXT 2 | 3 | val read_packages : 4 | Git_unix.Store.t -> 5 | Git_unix.Store.Hash.t -> 6 | OpamFile.OPAM.t OpamPackage.Version.Map.t OpamPackage.Name.Map.t Lwt.t 7 | (** [read_packages store commit] is an index of the opam files in [store] at 8 | [commit]. *) 9 | 10 | val create : 11 | ?test:OpamPackage.Name.Set.t -> 12 | ?pins:(OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t -> 13 | constraints:OpamFormula.version_constraint OpamPackage.Name.Map.t -> 14 | env:(string -> OpamVariable.variable_contents option) -> 15 | packages:OpamFile.OPAM.t OpamPackage.Version.Map.t OpamPackage.Name.Map.t -> 16 | unit -> 17 | t 18 | -------------------------------------------------------------------------------- /src/solver/main.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let n_workers = 20 4 | 5 | let pp_timestamp f x = 6 | let open Unix in 7 | let tm = localtime x in 8 | Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) 9 | tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec 10 | 11 | let reporter = 12 | let report src level ~over k msgf = 13 | let k _ = 14 | over (); 15 | k () 16 | in 17 | let src = Logs.Src.name src in 18 | msgf @@ fun ?header ?tags:_ fmt -> 19 | Fmt.kpf k Fmt.stderr 20 | ("%a %a %a @[" ^^ fmt ^^ "@]@.") 21 | pp_timestamp (Unix.gettimeofday ()) 22 | Fmt.(styled `Magenta string) 23 | (Printf.sprintf "%14s" src) 24 | Logs_fmt.pp_header (level, header) 25 | in 26 | { Logs.report } 27 | 28 | let () = 29 | Logs.(set_level (Some Warning)); 30 | Logs.set_reporter reporter 31 | 32 | let export service ~on:socket = 33 | let restore = 34 | Capnp_rpc_net.Restorer.single 35 | (Capnp_rpc_net.Restorer.Id.public "solver") 36 | service 37 | in 38 | let switch = Lwt_switch.create () in 39 | let stdin = 40 | Capnp_rpc_unix.Unix_flow.connect socket 41 | |> Capnp_rpc_net.Endpoint.of_flow 42 | (module Capnp_rpc_unix.Unix_flow) 43 | ~peer_id:Capnp_rpc_net.Auth.Digest.insecure ~switch 44 | in 45 | let (_ : Capnp_rpc_unix.CapTP.t) = 46 | Capnp_rpc_unix.CapTP.connect ~restore stdin 47 | in 48 | let crashed, set_crashed = Lwt.wait () in 49 | Lwt_switch.add_hook_or_exec (Some switch) (fun () -> 50 | Lwt.wakeup_exn set_crashed (Failure "Capnp switch turned off"); 51 | Lwt.return_unit) 52 | >>= fun () -> crashed 53 | 54 | let () = 55 | match Sys.argv with 56 | | [| prog |] -> 57 | Lwt_main.run 58 | (let create_worker hash = 59 | let cmd = 60 | ("", [| prog; "--worker"; Git_unix.Store.Hash.to_hex hash |]) 61 | in 62 | Lwt_process.open_process cmd 63 | in 64 | Service.v ~n_workers ~create_worker >>= fun service -> 65 | export service ~on:Lwt_unix.stdin) 66 | | [| prog; "--jobs"; numjobs |] -> 67 | let n_workers = int_of_string numjobs in 68 | Lwt_main.run 69 | (let create_worker hash = 70 | let cmd = 71 | ("", [| prog; "--worker"; Git_unix.Store.Hash.to_hex hash |]) 72 | in 73 | Lwt_process.open_process cmd 74 | in 75 | Service.v ~n_workers ~create_worker >>= fun service -> 76 | export service ~on:Lwt_unix.stdin) 77 | | [| _prog; "--worker"; hash |] -> 78 | Solver.main (Git_unix.Store.Hash.of_hex hash) 79 | | args -> 80 | Fmt.failwith "Usage: ocaml-ci-solver (got %a)" 81 | Fmt.(array (quote string)) 82 | args 83 | -------------------------------------------------------------------------------- /src/solver/main.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocurrent/ocaml-docs-ci/4dfe7e6265610da4e0ce2a386cfbf0b8eac3d9bd/src/solver/main.mli -------------------------------------------------------------------------------- /src/solver/opam_repository.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | module Log = Solver_api.Solver.Log 3 | module Store = Git_unix.Store 4 | 5 | let clone_path = "opam-repository" 6 | 7 | let open_store () = 8 | let path = Fpath.v clone_path in 9 | Git_unix.Store.v ~dotgit:path path >|= function 10 | | Ok x -> x 11 | | Error e -> 12 | Fmt.failwith "Failed to open opam-repository: %a" Store.pp_error e 13 | 14 | let clone () = 15 | match Unix.lstat clone_path with 16 | | Unix.{ st_kind = S_DIR; _ } -> Lwt.return_unit 17 | | _ -> Fmt.failwith "%S is not a directory!" clone_path 18 | | exception Unix.Unix_error (Unix.ENOENT, _, "opam-repository") -> 19 | Process.exec 20 | ( "", 21 | [| 22 | "git"; 23 | "clone"; 24 | "--bare"; 25 | "https://github.com/ocaml/opam-repository.git"; 26 | clone_path; 27 | |] ) 28 | 29 | (** Find the oldest commit that touches all the paths. Should find the most 30 | recent commit backwards `from` that have touched the paths. Process all the 31 | paths and check using `OpamFile.OPAM.effectively_equal` to see whether 32 | Resolve for a packages revdeps. 33 | 34 | Don't want to scope on opam_repository *) 35 | let oldest_commit_with ~log ~from pkgs = 36 | let from = Store.Hash.to_hex from in 37 | let paths = 38 | pkgs 39 | |> List.map (fun pkg -> 40 | let name = OpamPackage.name_to_string pkg in 41 | let version = OpamPackage.version_to_string pkg in 42 | Printf.sprintf "packages/%s/%s.%s" name name version) 43 | in 44 | let cmd = 45 | "git" 46 | :: "-C" 47 | :: clone_path 48 | :: "log" 49 | :: "-n" 50 | :: "1" 51 | :: "--format=format:%H" 52 | :: from 53 | :: "--" 54 | :: paths 55 | in 56 | Log.info log "oldest_commit_with %a" (Fmt.list ~sep:Fmt.sp Fmt.string) cmd; 57 | let cmd = ("", Array.of_list cmd) in 58 | Process.pread cmd >|= String.trim 59 | 60 | let fetch () = 61 | Process.exec ("", [| "git"; "-C"; clone_path; "fetch"; "origin" |]) 62 | -------------------------------------------------------------------------------- /src/solver/opam_repository.mli: -------------------------------------------------------------------------------- 1 | module Log = Solver_api.Solver.Log 2 | 3 | val open_store : unit -> Git_unix.Store.t Lwt.t 4 | (** [open_store()] opens "./opam-repository" if it exists. If not fails an 5 | exception. *) 6 | 7 | val clone : unit -> unit Lwt.t 8 | (** [clone ()] ensures that "./opam-repository" exists. If not, it clones it. *) 9 | 10 | val oldest_commit_with : 11 | log:Log.t -> from:Git_unix.Store.Hash.t -> OpamPackage.t list -> string Lwt.t 12 | (** Use "git-log" to find the oldest commit with these package versions. This 13 | avoids invalidating the Docker build cache on every update to 14 | opam-repository. 15 | 16 | @param log The Capnp logger for this job. 17 | @param from The commit at which to begin the search. *) 18 | 19 | val fetch : unit -> unit Lwt.t 20 | (** Does a "git fetch origin" to update the store. *) 21 | -------------------------------------------------------------------------------- /src/solver/process.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let pp_args = 4 | let sep = Fmt.(const string) " " in 5 | Fmt.(array ~sep (quote string)) 6 | 7 | let pp_cmd f = function 8 | | "", args -> pp_args f args 9 | | bin, args -> Fmt.pf f "(%S, %a)" bin pp_args args 10 | 11 | let pp_signal f x = 12 | let open Sys in 13 | if x = sigkill then Fmt.string f "kill" 14 | else if x = sigterm then Fmt.string f "term" 15 | else Fmt.int f x 16 | 17 | let pp_status f = function 18 | | Unix.WEXITED x -> Fmt.pf f "exited with status %d" x 19 | | Unix.WSIGNALED x -> Fmt.pf f "failed with signal %d" x 20 | | Unix.WSTOPPED x -> Fmt.pf f "stopped with signal %d" x 21 | 22 | let check_status cmd = function 23 | | Unix.WEXITED 0 -> () 24 | | status -> Fmt.failwith "%a %a" pp_cmd cmd pp_status status 25 | 26 | let exec cmd = 27 | let proc = Lwt_process.open_process_none cmd in 28 | proc#status >|= check_status cmd 29 | 30 | let pread cmd = 31 | let proc = Lwt_process.open_process_in cmd in 32 | Lwt_io.read proc#stdout >>= fun output -> 33 | proc#status >|= check_status cmd >|= fun () -> output 34 | -------------------------------------------------------------------------------- /src/solver/service.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Capnp_rpc_lwt 3 | module Worker = Solver_api.Worker 4 | module Log = Solver_api.Solver.Log 5 | module Selection = Worker.Selection 6 | module Store = Git_unix.Store 7 | 8 | module Epoch : sig 9 | type t 10 | 11 | (* An Epoch handles all requests for a single opam-repository HEAD commit. *) 12 | 13 | val create : 14 | n_workers:int -> 15 | create_worker:(Git_unix.Store.Hash.t -> Lwt_process.process) -> 16 | Store.Hash.t -> 17 | t Lwt.t 18 | 19 | val handle : 20 | log:Solver_api.Solver.Log.t -> 21 | Worker.Solve_request.t -> 22 | t -> 23 | Selection.t list Lwt.t 24 | 25 | val dispose : t -> unit Lwt.t 26 | end = struct 27 | type t = Lwt_process.process Lwt_pool.t 28 | 29 | let validate (worker : Lwt_process.process) = 30 | match Lwt.state worker#status with 31 | | Lwt.Sleep -> Lwt.return true 32 | | Lwt.Fail ex -> Lwt.fail ex 33 | | Lwt.Return status -> 34 | Format.eprintf "Worker %d is dead (%a) - removing from pool@." 35 | worker#pid Process.pp_status status; 36 | Lwt.return false 37 | 38 | let dispose (worker : Lwt_process.process) = 39 | let pid = worker#pid in 40 | Fmt.epr "Terminating worker %d@." pid; 41 | worker#terminate; 42 | worker#status >|= fun _ -> Fmt.epr "Worker %d finished@." pid 43 | 44 | let create ~n_workers ~create_worker hash = 45 | ( Opam_repository.open_store () >>= fun store -> 46 | Store.mem store hash >>= function 47 | | true -> Lwt.return_unit 48 | | false -> ( 49 | Fmt.pr "Need to update opam-repository to get new commit %a@." 50 | Store.Hash.pp hash; 51 | Opam_repository.fetch () >>= fun () -> 52 | Opam_repository.open_store () >>= fun new_store -> 53 | Store.mem new_store hash >>= function 54 | | false -> Fmt.failwith "Still missing commit after update!" 55 | | true -> Lwt.return_unit) ) 56 | >|= fun () -> 57 | Lwt_pool.create n_workers ~validate ~dispose (fun () -> 58 | Lwt.return (create_worker hash)) 59 | 60 | let dispose = Lwt_pool.clear 61 | 62 | (* Send [request] to [worker] and read the reply. *) 63 | let process ~log ~id request worker = 64 | let request_str = 65 | Worker.Solve_request.to_yojson request |> Yojson.Safe.to_string 66 | in 67 | let request_str = 68 | Printf.sprintf "%d\n%s" (String.length request_str) request_str 69 | in 70 | Lwt_io.write worker#stdin request_str >>= fun () -> 71 | Lwt_io.read_line worker#stdout >>= fun time -> 72 | Lwt_io.read_line worker#stdout >>= fun len -> 73 | match Astring.String.to_int len with 74 | | None -> Fmt.failwith "Bad frame from worker: time=%S len=%S" time len 75 | | Some len -> ( 76 | let buf = Bytes.create len in 77 | Lwt_io.read_into_exactly worker#stdout buf 0 len >|= fun () -> 78 | let results = Bytes.unsafe_to_string buf in 79 | match results.[0] with 80 | | '+' -> 81 | Log.info log "%s: found solution in %s s" id time; 82 | Astring.String.with_range ~first:1 results 83 | |> Yojson.Safe.from_string 84 | |> Solver.solve_result_of_yojson 85 | | '-' -> 86 | Log.info log "%s: eliminated all possibilities in %s s" id time; 87 | let msg = results |> Astring.String.with_range ~first:1 in 88 | Error msg 89 | | '!' -> 90 | let msg = results |> Astring.String.with_range ~first:1 in 91 | Fmt.failwith "BUG: solver worker failed: %s" msg 92 | | _ -> Fmt.failwith "BUG: bad output: %s" results) 93 | 94 | let handle ~log request t = 95 | let { Worker.Solve_request.opam_repository_commit; platforms; pkgs; _ } = 96 | request 97 | in 98 | Log.info log "Solving for %a using opam_repository_commit %s" 99 | Fmt.(list ~sep:comma string) 100 | pkgs opam_repository_commit; 101 | let opam_repository_commit = Store.Hash.of_hex opam_repository_commit in 102 | platforms 103 | |> Lwt_list.map_p (fun p -> 104 | let id = fst p in 105 | let slice = { request with platforms = [ p ] } in 106 | Lwt_pool.use t (process ~log ~id slice) >>= function 107 | | Error _ as e -> Lwt.return (id, e) 108 | | Ok packages -> 109 | let repo_packages = 110 | List.map (fun (pkg, _) -> OpamPackage.of_string pkg) packages 111 | in 112 | Opam_repository.oldest_commit_with repo_packages 113 | ~from:opam_repository_commit ~log 114 | >|= fun commit -> 115 | (id, Ok { Worker.Selection.id; packages; commit })) 116 | >|= List.filter_map (fun (id, result) -> 117 | Log.info log "= %s =" id; 118 | match result with 119 | | Ok result -> 120 | Log.info log "-> @[%a@]" 121 | Fmt.(list ~sep:sp string) 122 | (List.map fst result.Selection.packages); 123 | Log.info log "(valid since opam-repository commit %s)" 124 | result.Selection.commit; 125 | Some result 126 | | Error msg -> 127 | Log.info log "%s" msg; 128 | None) 129 | end 130 | 131 | (* Handle a request by distributing it among the worker processes and then aggregating their responses. *) 132 | let handle t ~log (request : Worker.Solve_request.t) = 133 | Epoch_lock.with_epoch t request.opam_repository_commit 134 | (Epoch.handle ~log request) 135 | 136 | let v ~n_workers ~create_worker = 137 | Opam_repository.clone () >|= fun () -> 138 | let create hash = 139 | Epoch.create ~n_workers ~create_worker (Store.Hash.of_hex hash) 140 | in 141 | let t = Epoch_lock.v ~create ~dispose:Epoch.dispose () in 142 | let module X = Solver_api.Raw.Service.Solver in 143 | X.local 144 | @@ object 145 | inherit X.service 146 | 147 | method solve_impl params release_param_caps = 148 | let open X.Solve in 149 | let request = Params.request_get params in 150 | let log = Params.log_get params in 151 | release_param_caps (); 152 | match log with 153 | | None -> Service.fail "Missing log argument!" 154 | | Some log -> ( 155 | Capnp_rpc_lwt.Service.return_lwt @@ fun () -> 156 | Capability.with_ref log @@ fun log -> 157 | match 158 | Worker.Solve_request.of_yojson (Yojson.Safe.from_string request) 159 | with 160 | | Error msg -> 161 | Lwt_result.fail 162 | (`Capnp (Capnp_rpc.Error.exn "Bad JSON in request: %s" msg)) 163 | | Ok request -> 164 | Lwt.catch 165 | (* TODO Pass in a switch here to handle Cancellation. 166 | handle t ~switch:(Lwt_switch.create ()) ~log request 167 | *) 168 | (fun () -> handle t ~log request >|= Result.ok) 169 | (function 170 | | Failure msg -> Lwt_result.fail (`Msg msg) 171 | | ex -> Lwt.return (Fmt.error_msg "%a" Fmt.exn ex)) 172 | >|= fun selections -> 173 | let json = 174 | Yojson.Safe.to_string 175 | (Worker.Solve_response.to_yojson selections) 176 | in 177 | let response, results = 178 | Capnp_rpc_lwt.Service.Response.create Results.init_pointer 179 | in 180 | Results.response_set results json; 181 | Ok response) 182 | end 183 | -------------------------------------------------------------------------------- /src/solver/service.mli: -------------------------------------------------------------------------------- 1 | val v : 2 | n_workers:int -> 3 | create_worker:(Git_unix.Store.Hash.t -> Lwt_process.process) -> 4 | Solver_api.Solver.t Lwt.t 5 | (** [v ~n_workers ~create_worker] is a solver service that distributes work to 6 | up to [n_workers] subprocesses, using [create_worker hash] to spawn new 7 | workers. *) 8 | -------------------------------------------------------------------------------- /src/solver/solver.ml: -------------------------------------------------------------------------------- 1 | module Worker = Solver_api.Worker 2 | module Solver = Opam_0install.Solver.Make (Git_context) 3 | module Store = Git_unix.Store 4 | open Lwt.Infix 5 | 6 | let env (vars : Worker.Vars.t) = 7 | let env = 8 | Opam_0install.Dir_context.std_env ~arch:vars.arch ~os:vars.os 9 | ~os_distribution:vars.os_distribution ~os_version:vars.os_version 10 | ~os_family:vars.os_family () 11 | in 12 | function "opam-version" -> Some (OpamTypes.S "2.1.0") | v -> env v 13 | 14 | let get_names = OpamFormula.fold_left (fun a (name, _) -> name :: a) [] 15 | 16 | let universes ~packages (resolutions : OpamPackage.t list) = 17 | let memo = Hashtbl.create (List.length resolutions) in 18 | 19 | let rec aux root = 20 | match Hashtbl.find_opt memo root with 21 | | Some universe -> universe 22 | | None -> 23 | let name, version = (OpamPackage.name root, OpamPackage.version root) in 24 | let opamfile : OpamFile.OPAM.t = 25 | packages 26 | |> OpamPackage.Name.Map.find name 27 | |> OpamPackage.Version.Map.find version 28 | in 29 | let deps = 30 | opamfile 31 | |> OpamFile.OPAM.depends 32 | |> OpamFilter.partial_filter_formula 33 | (OpamFilter.deps_var_env ~build:true ~post:false ~test:false 34 | ~doc:false ~dev_setup:false ~dev:false) 35 | |> get_names 36 | |> OpamPackage.Name.Set.of_list 37 | in 38 | let depopts = 39 | opamfile 40 | |> OpamFile.OPAM.depopts 41 | |> OpamFilter.partial_filter_formula 42 | (OpamFilter.deps_var_env ~build:true ~post:false ~test:false 43 | ~doc:false ~dev_setup:false ~dev:false) 44 | |> get_names 45 | |> OpamPackage.Name.Set.of_list 46 | in 47 | let deps = 48 | resolutions 49 | |> List.filter (fun res -> 50 | let name = OpamPackage.name res in 51 | OpamPackage.Name.Set.mem name deps 52 | || OpamPackage.Name.Set.mem name depopts) 53 | |> List.rev_map (fun pkg -> OpamPackage.Set.add pkg (aux pkg)) 54 | in 55 | let result = 56 | List.fold_left OpamPackage.Set.union OpamPackage.Set.empty deps 57 | in 58 | Hashtbl.add memo root result; 59 | result 60 | in 61 | List.rev_map 62 | (fun pkg -> (pkg, aux pkg |> OpamPackage.Set.elements)) 63 | resolutions 64 | 65 | let solve ~packages ~constraints ~root_pkgs (vars : Worker.Vars.t) = 66 | let context = Git_context.create () ~packages ~env:(env vars) ~constraints in 67 | let t0 = Unix.gettimeofday () in 68 | let r = Solver.solve context root_pkgs in 69 | let t1 = Unix.gettimeofday () in 70 | Printf.printf "%.2f\n" (t1 -. t0); 71 | match r with 72 | | Ok sels -> 73 | let pkgs = Solver.packages_of_result sels in 74 | let universes = universes ~packages pkgs in 75 | Ok 76 | (List.rev_map 77 | (fun (pkg, univ) -> 78 | (OpamPackage.to_string pkg, List.rev_map OpamPackage.to_string univ)) 79 | universes) 80 | | Error diagnostics -> Error (Solver.diagnostics diagnostics) 81 | 82 | type solve_result = (string * string list) list [@@deriving yojson] 83 | 84 | let main commit = 85 | let packages = 86 | Lwt_main.run 87 | ( Opam_repository.open_store () >>= fun store -> 88 | Git_context.read_packages store commit ) 89 | in 90 | let rec aux () = 91 | match input_line stdin with 92 | | exception End_of_file -> () 93 | | len -> 94 | let len = int_of_string len in 95 | let data = really_input_string stdin len in 96 | let request = 97 | Worker.Solve_request.of_yojson (Yojson.Safe.from_string data) 98 | |> Result.get_ok 99 | in 100 | let { 101 | Worker.Solve_request.opam_repository_commit; 102 | pkgs; 103 | constraints; 104 | platforms; 105 | } = 106 | request 107 | in 108 | let opam_repository_commit = Store.Hash.of_hex opam_repository_commit in 109 | assert (Store.Hash.equal opam_repository_commit commit); 110 | let root_pkgs = pkgs |> List.rev_map OpamPackage.Name.of_string in 111 | let constraints = 112 | constraints 113 | |> List.rev_map (fun (name, rel, version) -> 114 | ( OpamPackage.Name.of_string name, 115 | (rel, OpamPackage.Version.of_string version) )) 116 | |> OpamPackage.Name.Map.of_list 117 | in 118 | platforms 119 | |> List.iter (fun (_id, platform) -> 120 | let msg = 121 | match solve ~packages ~constraints ~root_pkgs platform with 122 | | Ok packages -> 123 | "+" 124 | ^ (solve_result_to_yojson packages |> Yojson.Safe.to_string) 125 | | Error msg -> "-" ^ msg 126 | in 127 | Printf.printf "%d\n%s%!" (String.length msg) msg); 128 | aux () 129 | in 130 | aux () 131 | 132 | let main commit = 133 | try main commit 134 | with ex -> 135 | Fmt.epr "solver bug: %a@." Fmt.exn ex; 136 | let msg = 137 | match ex with Failure msg -> msg | ex -> Printexc.to_string ex 138 | in 139 | let msg = "!" ^ msg in 140 | Printf.printf "0.0\n%d\n%s%!" (String.length msg) msg; 141 | raise ex 142 | -------------------------------------------------------------------------------- /src/solver/solver.mli: -------------------------------------------------------------------------------- 1 | type solve_result = (string * string list) list [@@deriving yojson] 2 | 3 | val main : Git_unix.Store.Hash.t -> unit 4 | (** [main hash] runs a worker process that reads requests from stdin and writes 5 | results to stdout, using commit [hash] in opam-repository. *) 6 | -------------------------------------------------------------------------------- /test/cli/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (files run.md) 3 | (deps 4 | %{bin:epoch} 5 | (file run)) 6 | (package ocaml-docs-ci-client)) 7 | -------------------------------------------------------------------------------- /test/cli/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | absolute_path() { 4 | echo "$(cd "$(dirname "$1")" && pwd)/$(basename "$1")" 5 | } 6 | 7 | EPOCH_BIN="epoch -s" 8 | EPOCH_DATA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'data') 9 | trap 'rm -rf \"${EPOCH_DATA_TEMP}\"' EXIT 10 | 11 | # Linked universes - DO NOT prune 12 | # # find . -name bf6f7d00b40806e7dd74ad1828a0aa6d 13 | # ./epoch-097e46a4d589b9e34ed2903beecd1a04/html-raw/u/bf6f7d00b40806e7dd74ad1828a0aa6d 14 | # ./epoch-410108220dc0168ea4d9bd697dfa8e34/linked/u/bf6f7d00b40806e7dd74ad1828a0aa6d 15 | # ./compile/u/bf6f7d00b40806e7dd74ad1828a0aa6d 16 | # ./prep/universes/bf6f7d00b40806e7dd74ad1828a0aa6d 17 | echo "Creating linked universe bf6f7d00b40806e7dd74ad1828a0aa6d" 18 | mkdir -p "$EPOCH_DATA_TEMP/epoch-097e46a4d589b9e34ed2903beecd1a04/html-raw/u/bf6f7d00b40806e7dd74ad1828a0aa6d" 19 | mkdir -p "$EPOCH_DATA_TEMP/epoch-410108220dc0168ea4d9bd697dfa8e34/linked/u/bf6f7d00b40806e7dd74ad1828a0aa6d" 20 | mkdir -p "$EPOCH_DATA_TEMP/compile/u/bf6f7d00b40806e7dd74ad1828a0aa6d" 21 | mkdir -p "$EPOCH_DATA_TEMP/prep/universes/bf6f7d00b40806e7dd74ad1828a0aa6d" 22 | 23 | # # find . -name 7ee85f63014c898d8cb21b3436d42150 24 | # ./epoch-3820829bb005c559218fffb16ee32f3b/linked/u/7ee85f63014c898d8cb21b3436d42150 25 | # ./epoch-9baa5939aca1673d141e85b6ecd1e770/html-raw/u/7ee85f63014c898d8cb21b3436d42150 26 | # ./epoch-097e46a4d589b9e34ed2903beecd1a04/html-raw/u/7ee85f63014c898d8cb21b3436d42150 27 | # ./epoch-410108220dc0168ea4d9bd697dfa8e34/linked/u/7ee85f63014c898d8cb21b3436d42150 28 | # ./compile/u/7ee85f63014c898d8cb21b3436d42150 29 | # ./prep/universes/7ee85f63014c898d8cb21b3436d42150 30 | 31 | echo "Creating linked universe 7ee85f63014c898d8cb21b3436d42150" 32 | mkdir -p "$EPOCH_DATA_TEMP/epoch-3820829bb005c559218fffb16ee32f3b/linked/u/7ee85f63014c898d8cb21b3436d42150" 33 | mkdir -p "$EPOCH_DATA_TEMP/epoch-9baa5939aca1673d141e85b6ecd1e770/html-raw/u/7ee85f63014c898d8cb21b3436d42150" 34 | mkdir -p "$EPOCH_DATA_TEMP/epoch-097e46a4d589b9e34ed2903beecd1a04/html-raw/u/7ee85f63014c898d8cb21b3436d42150" 35 | mkdir -p "$EPOCH_DATA_TEMP/epoch-410108220dc0168ea4d9bd697dfa8e34/linked/u/7ee85f63014c898d8cb21b3436d42150" 36 | mkdir -p "$EPOCH_DATA_TEMP/compile/u/7ee85f63014c898d8cb21b3436d42150" 37 | mkdir -p "$EPOCH_DATA_TEMP/prep/universes/7ee85f63014c898d8cb21b3436d42150" 38 | 39 | # Orphan universes - can be pruned 40 | # # find . -name 3e4e2c1d81edea2e42fbfaba428f5965 41 | # ./compile/u/3e4e2c1d81edea2e42fbfaba428f5965 42 | # ./prep/universes/3e4e2c1d81edea2e42fbfaba428f5965 43 | 44 | echo "Created orphan universe 3e4e2c1d81edea2e42fbfaba428f5965" 45 | mkdir -p "$EPOCH_DATA_TEMP/compile/u/3e4e2c1d81edea2e42fbfaba428f5965" 46 | mkdir -p "$EPOCH_DATA_TEMP/prep/universes/3e4e2c1d81edea2e42fbfaba428f5965" 47 | 48 | # # find . -name 5e2dcd36d81e7c2394110782b5bf906f 49 | # ./compile/u/5e2dcd36d81e7c2394110782b5bf906f 50 | # ./prep/universes/5e2dcd36d81e7c2394110782b5bf906f 51 | 52 | echo "Created orphan universe 5e2dcd36d81e7c2394110782b5bf906f" 53 | mkdir -p "$EPOCH_DATA_TEMP/compile/u/5e2dcd36d81e7c2394110782b5bf906f" 54 | mkdir -p "$EPOCH_DATA_TEMP/prep/universes/5e2dcd36d81e7c2394110782b5bf906f" 55 | 56 | # Tree is useful to debug what the structure of the epoch folder looks like 57 | # tree "$EPOCH_DATA_TEMP" 58 | 59 | ${EPOCH_BIN} --base-dir "$EPOCH_DATA_TEMP" 60 | 61 | # tree "$EPOCH_DATA_TEMP" 62 | 63 | check_universe() { 64 | UNIVERSE_HASH=$1 65 | NUMBER_OCCURANCE=$2 66 | FOUND=$(find "$EPOCH_DATA_TEMP" -name "$UNIVERSE_HASH" |wc -l |tr -d '[:space:]') 67 | [ "$FOUND" = "$NUMBER_OCCURANCE" ] || { echo "Expected to find $NUMBER_OCCURANCE universes instead found $FOUND universes" ; exit 1; } 68 | } 69 | 70 | # Expect to find these universes untouched 71 | check_universe "bf6f7d00b40806e7dd74ad1828a0aa6d" 4 72 | check_universe "7ee85f63014c898d8cb21b3436d42150" 6 73 | 74 | # Expect these universes to get pruned 75 | check_universe "3e4e2c1d81edea2e42fbfaba428f5965" 0 76 | check_universe "5e2dcd36d81e7c2394110782b5bf906f" 0 -------------------------------------------------------------------------------- /test/cli/run.md: -------------------------------------------------------------------------------- 1 | # Epoch management tool 2 | 3 | `epoch` - command line tool for managing epochs and storage in ocaml-docs-ci 4 | 5 | Epoch tool provides version information about git version it was built with: 6 | ```sh 7 | $ epoch --version 8 | n/a 9 | ``` 10 | 11 | Epoch provides a manpage with help options: 12 | ```sh 13 | $ epoch --help=plain 14 | NAME 15 | epoch - Epoch pruning 16 | 17 | SYNOPSIS 18 | epoch [--base-dir=BASE_DIR] [--dry-run] [-s] [OPTION]… 19 | 20 | OPTIONS 21 | --base-dir=BASE_DIR (required) 22 | Base directory containing epochs. eg 23 | /var/lib/docker/volumes/infra_docs-data/_data 24 | 25 | --dry-run 26 | If set, only list the files to be deleted but do not deleted them 27 | 28 | -s Run epoch tool silently emitting no progress bars. 29 | 30 | COMMON OPTIONS 31 | --help[=FMT] (default=auto) 32 | Show this help in format FMT. The value FMT must be one of auto, 33 | pager, groff or plain. With auto, the format is pager or plain 34 | whenever the TERM env var is dumb or undefined. 35 | 36 | --version 37 | Show version information. 38 | 39 | EXIT STATUS 40 | epoch exits with: 41 | 42 | 0 on success. 43 | 44 | 123 on indiscriminate errors reported on standard error. 45 | 46 | 124 on command line parsing errors. 47 | 48 | 125 on unexpected internal errors (bugs). 49 | 50 | ``` 51 | 52 | The primary use of epoch is to trim the directories that exist in `prep` and `compile` that are no longer linked from an `epoch-*`. These directories can accumulate many Gb of data, causing ocaml-docs-ci pipelines to fail with not enough disk space. 53 | 54 | Running the tests should delete orphan universes and leave linked universe alone: 55 | ```sh 56 | $ ./run 57 | Creating linked universe bf6f7d00b40806e7dd74ad1828a0aa6d 58 | Creating linked universe 7ee85f63014c898d8cb21b3436d42150 59 | Created orphan universe 3e4e2c1d81edea2e42fbfaba428f5965 60 | Created orphan universe 5e2dcd36d81e7c2394110782b5bf906f 61 | Files to be deleted in prep/universes 62 | 3e4e2c1d81edea2e42fbfaba428f5965 63 | 5e2dcd36d81e7c2394110782b5bf906f 64 | Deleting 2 files in prep/universes 65 | Files to be deleted in compile/u 66 | 3e4e2c1d81edea2e42fbfaba428f5965 67 | 5e2dcd36d81e7c2394110782b5bf906f 68 | Deleting 2 files in compile/u 69 | ``` 70 | -------------------------------------------------------------------------------- /test/lib/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_lib) 3 | (libraries docs_ci_lib current alcotest alcotest-lwt)) 4 | 5 | (rule 6 | (alias runtest) 7 | (action 8 | (run ./test_lib.exe -e))) 9 | -------------------------------------------------------------------------------- /test/lib/test_compile.ml: -------------------------------------------------------------------------------- 1 | module Compile = Docs_ci_lib.Compile 2 | 3 | let test_extract_hashes_no_retry _switch () = 4 | let log_lines = 5 | "compile/u/d5bd534a65ac29b409950ab82ea7ec10/stdlib-shims/0.3.0/page-doc.odoc\n\ 6 | \ compile/u/d5bd534a65ac29b409950ab82ea7ec10/ppx_derivers/1.2.1/1.2.1/\n\ 7 | \ compile/u/d5bd534a65ac29b409950ab82ea7ec10/ppx_derivers/1.2.1/1.2.1/lib/\n\ 8 | compile/u/d5bd534a65ac29b409950ab82ea7ec10/ppx_derivers/1.2.1/1.2.1/lib/ppx_derivers/\n" 9 | in 10 | let expected = 0 in 11 | let result = Compile.extract_hashes ((None, None), []) log_lines in 12 | Alcotest.(check int) "" expected (List.length (snd result)) |> Lwt.return 13 | 14 | let test_extract_hashes_rsync_retry _switch () = 15 | let log_lines = 16 | "Warning: Permanently added \ 17 | '[staging.docs.ci.ocaml.org]:2222,[51.158.163.148]:2222' (ECDSA) to the \ 18 | list of known hosts.\n\ 19 | \ ssh: connect to host staging.docs.ci.ocaml.org port 2222: Connection \ 20 | timed out\n\ 21 | \ rsync: connection unexpectedly closed (0 bytes received so far) \ 22 | [Receiver]\n\ 23 | \ rsync error: unexplained error (code 255) at io.c(228) [Receiver=3.2.3]" 24 | in 25 | let result = Compile.extract_hashes ((None, None), []) log_lines in 26 | Alcotest.(check string) "" log_lines (List.hd (snd result)) |> Lwt.return 27 | 28 | let test_extract_hashes_several_retry _switch () = 29 | let log_lines = 30 | "Warning: Permanently added \ 31 | '[staging.docs.ci.ocaml.org]:2222,[51.158.163.148]:2222' (ECDSA) to the \ 32 | list of known hosts.\n\ 33 | \ ssh: connect to host staging.docs.ci.ocaml.org port 2222: Connection \ 34 | timed out\n\ 35 | \ Temporary failure due to some unknown cause\n\ 36 | \ Could not resolve host\n\ 37 | \ rsync error: unexplained error (code 255) at io.c(228) \ 38 | [Receiver=3.2.3]" 39 | in 40 | let result = Compile.extract_hashes ((None, None), []) log_lines in 41 | Alcotest.(check string) "" log_lines (List.hd (snd result)) |> Lwt.return 42 | 43 | let test_extract_hashes_succeeded_no_retry _switch () = 44 | let log_lines = 45 | "Warning: Permanently added \ 46 | '[staging.docs.ci.ocaml.org]:2222,[51.158.163.148]:2222' (ECDSA) to the \ 47 | list of known hosts.\n\ 48 | \ ssh: connect to host staging.docs.ci.ocaml.org port 2222: Connection \ 49 | timed out\n\ 50 | \ Temporary failure due to some unknown cause\n\ 51 | \ Could not resolve host\n\ 52 | \ rsync error: unexplained error (code 255) at io.c(228) \ 53 | [Receiver=3.2.3]\n\ 54 | \ Job succeeded" 55 | in 56 | let expected = 0 in 57 | let result = Compile.extract_hashes ((None, None), []) log_lines in 58 | List.iteri (fun i s -> Printf.printf "%d: %s" i s) (snd result); 59 | Alcotest.(check int) "" expected (List.length (snd result)) |> Lwt.return 60 | 61 | let tests = 62 | [ 63 | Alcotest_lwt.test_case "extract_hashes_no_retry" `Quick 64 | test_extract_hashes_no_retry; 65 | Alcotest_lwt.test_case "extract_hashes_rsync_retry" `Quick 66 | test_extract_hashes_rsync_retry; 67 | Alcotest_lwt.test_case "extract_hashes_several_retry" `Quick 68 | test_extract_hashes_several_retry; 69 | Alcotest_lwt.test_case "extract_hashes_succeeded_no_retry" `Quick 70 | test_extract_hashes_succeeded_no_retry; 71 | ] 72 | -------------------------------------------------------------------------------- /test/lib/test_lib.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Lwt_main.run 3 | @@ Alcotest_lwt.run "test_lib" 4 | [ ("retry", Test_retry.tests); ("compile", Test_compile.tests) ] 5 | -------------------------------------------------------------------------------- /test/lib/test_retry.ml: -------------------------------------------------------------------------------- 1 | module Retry = Docs_ci_lib.Retry 2 | open Lwt.Infix 3 | 4 | let test_simple_success_no_retry _switch () = 5 | let fn () = Lwt.return_ok (42, []) in 6 | let expected = 42 in 7 | Retry.retry_loop ~sleep_duration:(fun _ -> 0.) fn >>= fun r -> 8 | Alcotest.(check int) "" expected (Result.get_ok r) |> Lwt.return 9 | 10 | let test_retry _switch () = 11 | let counter = ref (-1) in 12 | let fn () = 13 | counter := !counter + 1; 14 | Lwt.return_ok (!counter, [ true ]) 15 | in 16 | let max_number_of_attempts = 5 in 17 | let expected = "maximum attempts reached" in 18 | Retry.retry_loop 19 | ~sleep_duration:(fun _ -> 0.) 20 | ~log_string:"" ~number_of_attempts:0 ~max_number_of_attempts fn 21 | >>= fun r -> 22 | let (`Msg result) = Result.get_error r in 23 | Alcotest.(check string) "" expected result |> Lwt.return 24 | 25 | let test_no_retry _switch () = 26 | let counter = ref (-1) in 27 | let fn () = 28 | counter := !counter + 1; 29 | Lwt.return_error (`Msg "Error") 30 | in 31 | let max_number_of_attempts = 5 in 32 | let expected = "Error" in 33 | Retry.retry_loop 34 | ~sleep_duration:(fun _ -> 0.) 35 | ~log_string:"" ~number_of_attempts:0 ~max_number_of_attempts fn 36 | >>= fun r -> 37 | let (`Msg error_string) = Result.get_error r in 38 | Alcotest.(check string) "" expected error_string |> Lwt.return 39 | 40 | let tests = 41 | [ 42 | Alcotest_lwt.test_case "simple_no_retry" `Quick test_simple_success_no_retry; 43 | Alcotest_lwt.test_case "simple_with_retry" `Quick test_retry; 44 | Alcotest_lwt.test_case "simple_with_error_thus_no_retry" `Quick 45 | test_no_retry; 46 | ] 47 | -------------------------------------------------------------------------------- /test/monitor/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_monitor) 3 | (libraries docs_ci_lib current current_web alcotest alcotest-lwt)) 4 | 5 | (rule 6 | (alias runtest) 7 | (action 8 | (run ./test_monitor.exe -e))) 9 | -------------------------------------------------------------------------------- /test/monitor/test_monitor.ml: -------------------------------------------------------------------------------- 1 | module Monitor = Docs_ci_lib.Monitor 2 | 3 | let step1 = 4 | Current_git.clone 5 | ~schedule:(Current_cache.Schedule.v ()) 6 | ~gref:"main" "https://github.com/ocurrent/ocaml-docs-ci.git" 7 | 8 | let step2 = 9 | Current_git.clone 10 | ~schedule:(Current_cache.Schedule.v ()) 11 | "https://google.com/" 12 | 13 | let step3 : unit Current.t = Current.fail "oh no" 14 | 15 | let running = 16 | Current_docker.Default.build ~level:Current.Level.Dangerous ~pull:false 17 | `No_context 18 | 19 | let fakepkg ~blessing name = 20 | let open Docs_ci_lib in 21 | let root = OpamPackage.of_string name in 22 | let pkg = Package.make ~blacklist:[] ~commit:"0" ~root [] in 23 | let blessing = 24 | let set = 25 | Package.Blessing.Set.v ~counts:(Package.Map.singleton pkg 0) [ pkg ] 26 | in 27 | OpamPackage.Map.add root (Current.return set) blessing 28 | in 29 | (pkg, blessing) 30 | 31 | let pipeline monitor = 32 | let open Docs_ci_lib in 33 | let blessing = OpamPackage.Map.empty in 34 | let pkg, blessing = fakepkg ~blessing "docs-ci.1.0.0" in 35 | let pkg2, blessing = fakepkg ~blessing "ocurrent.1.1.0" in 36 | let pkg3, blessing = fakepkg ~blessing "ocluster.0.7.0" in 37 | 38 | let values = 39 | [ 40 | ( pkg, 41 | Monitor.( 42 | Seq 43 | [ 44 | ("step1", Item step1); 45 | ("step2", Item step2); 46 | ( "and-pattern", 47 | And [ ("sub-step3", Item step1); ("sub-step4", Item step3) ] ); 48 | ]) ); 49 | (pkg2, Monitor.(Seq [ ("fake-running-step", Item running) ])); 50 | (pkg3, Monitor.(Item step1)); 51 | ] 52 | |> List.to_seq 53 | |> Package.Map.of_seq 54 | in 55 | let solve_failure = 56 | [ (OpamPackage.of_string "mirage.4.0.0", "solver failed") ] 57 | in 58 | Monitor.register monitor solve_failure OpamPackage.Map.empty blessing values; 59 | monitor 60 | 61 | let package_step_list_testable = 62 | Alcotest.testable Monitor.pp_package_steps Monitor.equal_package_steps 63 | 64 | let test_lookup_steps_docs_ci _switch () = 65 | let monitor = pipeline (Monitor.make ()) in 66 | let result = Monitor.lookup_steps monitor ~name:"docs-ci" |> Result.get_ok in 67 | let expected = 68 | [ 69 | { 70 | Monitor.package = OpamPackage.of_string "docs-ci.1.0.0"; 71 | status = Monitor.Failed; 72 | steps = 73 | [ 74 | { Monitor.typ = "step1"; job_id = None; status = Monitor.Active }; 75 | { Monitor.typ = "step2"; job_id = None; status = Monitor.Active }; 76 | { 77 | Monitor.typ = "and-pattern:sub-step3"; 78 | job_id = None; 79 | status = Monitor.Active; 80 | }; 81 | { 82 | Monitor.typ = "and-pattern:sub-step4"; 83 | job_id = None; 84 | status = Monitor.Err "oh no"; 85 | }; 86 | ]; 87 | }; 88 | ] 89 | in 90 | Alcotest.(check (list package_step_list_testable)) "" expected result 91 | |> Lwt.return 92 | 93 | let test_lookup_steps_ocurrent _switch () = 94 | let monitor = pipeline (Monitor.make ()) in 95 | let result = Monitor.lookup_steps monitor ~name:"ocurrent" |> Result.get_ok in 96 | let expected = 97 | [ 98 | { 99 | Monitor.package = OpamPackage.of_string "ocurrent.1.1.0"; 100 | status = Monitor.Running; 101 | steps = 102 | [ 103 | { 104 | Monitor.typ = "fake-running-step"; 105 | job_id = None; 106 | status = Monitor.Active; 107 | }; 108 | ]; 109 | }; 110 | ] 111 | in 112 | Alcotest.(check (list package_step_list_testable)) "" expected result 113 | |> Lwt.return 114 | 115 | let test_lookup_steps_ocluster _switch () = 116 | let monitor = pipeline (Monitor.make ()) in 117 | let result = Monitor.lookup_steps monitor ~name:"ocluster" |> Result.get_ok in 118 | let expected = 119 | [ 120 | { 121 | Monitor.package = OpamPackage.of_string "ocluster.0.7.0"; 122 | status = Monitor.Running; 123 | steps = [ { Monitor.typ = ""; job_id = None; status = Monitor.Active } ]; 124 | }; 125 | ] 126 | in 127 | Alcotest.(check (list package_step_list_testable)) "" expected result 128 | |> Lwt.return 129 | 130 | let test_lookup_steps_solve_failure_example _switch () = 131 | let monitor = pipeline (Monitor.make ()) in 132 | let result = 133 | Monitor.lookup_steps monitor ~name:"mirage.4.0.0" |> Result.get_error 134 | in 135 | let expected = "no packages found with name: mirage.4.0.0" in 136 | Alcotest.(check string) "" expected result |> Lwt.return 137 | 138 | let tests = 139 | [ 140 | Alcotest_lwt.test_case "simple_lookup_steps_example_1" `Quick 141 | test_lookup_steps_docs_ci; 142 | Alcotest_lwt.test_case "simple_lookup_steps_example_2" `Quick 143 | test_lookup_steps_ocurrent; 144 | Alcotest_lwt.test_case "simple_lookup_steps_example_3" `Quick 145 | test_lookup_steps_ocluster; 146 | Alcotest_lwt.test_case "simple_lookup_steps_example_4" `Quick 147 | test_lookup_steps_solve_failure_example; 148 | ] 149 | 150 | let () = Lwt_main.run @@ Alcotest_lwt.run "test_lib" [ ("monitor", tests) ] 151 | --------------------------------------------------------------------------------