Add builder-db access-list command

.gitignore

@@ -1,4 +1 @@
 _build
-*~
-*#
-

.ocp-indent

@@ -1,130 +0,0 @@
-# -*- conf -*-
-# This is an example configuration file for ocp-indent
-#
-# Copy to the root of your project with name ".ocp-indent", customise, and
-# transparently get consistent indentation on all your ocaml source files.
-
-# Starting the configuration file with a preset ensures you won't fallback to
-# definitions from "~/.ocp/ocp-indent.conf".
-# These are `normal`, `apprentice` and `JaneStreet` and set different defaults.
-normal
-
-#
-#    INDENTATION VALUES
-#
-
-# Number of spaces used in all base cases, for example:
-#    let foo =
-#    ^^bar
-base = 2
-
-# Indent for type definitions:
-#    type t =
-#    ^^int
-type = 2
-
-# Indent after `let in` (unless followed by another `let`):
-#    let foo = () in
-#    ^^bar
-in = 0
-
-# Indent after `match/try with` or `function`:
-#    match foo with
-#    ^^| _ -> bar
-with = 0
-
-# Indent for clauses inside a pattern-match (after the arrow):
-#    match foo with
-#    | _ ->
-#    ^^^^bar
-# the default is 2, which aligns the pattern and the expression
-match_clause = 2
-
-# Indentation for items inside extension nodes:
-#    [%% id.id
-#    ^^^^contents ]
-#    [@@id
-#    ^^^^foo
-#    ]
-ppx_stritem_ext = 2
-
-# When nesting expressions on the same line, their indentation are in
-# some cases stacked, so that it remains correct if you close them one
-# at a line. This may lead to large indents in complex code though, so
-# this parameter can be used to set a maximum value. Note that it only
-# affects indentation after function arrows and opening parens at end
-# of line.
-#
-# for example (left: `none`; right: `4`)
-#    let f = g (h (i (fun x ->     #    let f = g (h (i (fun x ->
-#          x)                      #        x)
-#        )                         #      )
-#      )                           #    )
-max_indent = 4
-
-
-#
-#    INDENTATION TOGGLES
-#
-
-# Wether the `with` parameter should be applied even when in a sub-block.
-# Can be `always`, `never` or `auto`.
-# if `always`, there are no exceptions
-# if `auto`, the `with` parameter is superseded when seen fit (most of the time,
-#            but not after `begin match` for example)
-# if `never`, `with` is only applied if the match block starts a line.
-#
-# For example, the following is not indented if set to `always`:
-#    let f = function
-#    ^^| Foo -> bar
-strict_with = never
-
-# Controls indentation after the `else` keyword. `always` indents after the
-# `else` keyword normally, like after `then`.
-# If set to `never', the `else` keyword won't indent when followed by a newline.
-# `auto` indents after `else` unless in a few "unclosable" cases (`let in`,
-# `match`...).
-#
-# For example, with `strict_else=never`:
-#    if cond then
-#      foo
-#    else
-#    bar;
-#    baz
-# `never` is discouraged if you may encounter code like this example,
-# because it hides the scoping error (`baz` is always executed)
-strict_else = always
-
-# Ocp-indent will normally try to preserve your in-comment indentation, as long
-# as it respects the left-margin or starts with `(*\n`. Setting this to `true`
-# forces alignment within comments.
-strict_comments = false
-
-# Toggles preference of column-alignment over line indentation for most
-# of the common operators and after mid-line opening parentheses.
-#
-# for example (left: `false'; right: `true')
-#    let f x = x            #    let f x = x
-#      + y                  #              + y
-align_ops = true
-
-# Function parameters are normally indented one level from the line containing
-# the function. This option can be used to have them align relative to the
-# column of the function body instead.
-# if set to `always`, always align below the function
-# if `auto`, only do that when seen fit (mainly, after arrows)
-# if `never`, no alignment whatsoever
-#
-# for example (left: `never`; right: `always or `auto)
-#    match foo with         #    match foo with
-#    | _ -> some_fun        #    | _ -> some_fun
-#      ^^parameter          #           ^^parameter
-align_params = auto
-
-
-#
-#    SYNTAX EXTENSIONS
-#
-
-# You can also add syntax extensions (as per the --syntax command-line option):
-# syntax = mll lwt

CHANGES.md

@@ -1,27 +0,0 @@
-## v0.2.0 (2024-09-05)
-
-A whole slew of changes. Internally, we made a lot of incremental changes and improvements without doing a release. Thus this release is rather big. There is a lot of database migrations to apply, and unfortunately they have to be applied one at a time.
-
-* Add a /failed-builds/ endpoint that lists the most recent failed builds.
-* By default don't display failed builds on the front page.
-* Times are printed with the 'Z' time zone offset indicator.
-* Link to comparisons of builds take into account whether the "input", among others the list of dependencies, is different.
-* New subcommand `builder-db extract-build` takes a build UUID and extracts the builder "full" file.
-* Add /job/<job>/build/<build>/all.tar.gz endpoint with a gzip compressed tar archive of all build artifacts.
-* Visual overhaul.
-* Add (optional) visualizations displaying package dependencies ("opam-graph") and for unikernels a "modulectomy" view of how much each OCaml module is contributing to the final binary size. The visualizations are read from a cache on disk and can be generated from a script.
-* A script hook is added on file upload. It may be used to generate visualizations or publish system packages to a repository.
-* The 404 file not found page tries to be more informative.
-* The build page for a unikernel build displays the solo5 device manifest, e.g. `with block devices "storage", and net devices "service"`.
-* URLs with trailing slash redirect to without the trailing slash.
-* Builder-web will try to be more helpful if its database doesn't exist or the database version is wrong.
-* The opam diff works for mirage 4 unikernels taking into account the opam-monorepo/duniverse packages.
-* Markdown rendering is now done using cmarkit instead of omd.
-* Builder-web doesn't display jobs older than 30 days (customizable with `--expired-jobs` command line argument) on the front page.
-* Build artifacts are stored by their content, and artifacts are automatically deduplicated. This makes builder-web much more space efficient on deployments that don't use deduplication on the filesystem level.
-* New subcommands `builder-db vacuum *` to remove older builds. Can be called from a cron job to keep disk usage bounded.
-* Lots of other improvements and bug fixes.
-
-## v0.1.0 (2021-11-12)
-
-* Initial public release

README.md

@@ -1,26 +1,20 @@
 # Builder-web - a web frontend for reproducible builds
 
-Builder-web takes in submissions of builds, typically from [builder](https://github.com/robur-coop/builder/), and displays the produced artifacts in a way that makes it easy to compare checksums and build status.
-Produced binaries can be downloaded and executed.
-[builds.robur.coop](https://builds.robur.coop/) itself runs builder-web.
+Builder-web takes in submissions of builds, typically from [builder](https://github.com/roburio/builder/), and displays the produced artifacts in a way that makes it easy to compare checksums and build status.
+Produced binaries can be downloaded and run by users.
 
 ## Overview
 
 Builder-web is a single binary web server using a sqlite3 database with versioned schemas.
-Finished builds from [builder](https://github.com/robur-coop/builder/) are uploaded to builder-web, stored and indexed in the database and presented in the web interface to the user.
+Finished builds from [builder](https://github.com/roburio/builder/) are uploaded to builder-web, stored and indexed in the database and presented in the web interface to the user.
 Users can:
 
-* Get an overview of *jobs* - a job is typically script or opam package that is run and builds an artifact,
+* Get an overview of *jobs* - a job is typically script or opam package that is run and builds an artifact, 
 * Browse all *builds* of a job - each job may have multiple builds, that are executed periodically by builder
-* Browse individual *build* and download artifacts and build information for reproducing the same binary.
-* Compare two builds, observing the differences in used opam packages, environment variables, and system packages.
-* Search for the SHA-256 hash of a binary to view a build that resulted in that binary.
+* Browse individual *build* and download artifacts and build information for reproducing the same binary. 
+Each build has a single binary as output - which checksum is recorded and can be searched for. The build information (opam acpackges, environment variables, host system packages) can be compared, and they may differ even if the checksum of the binary is identical.
 
-## Installation
-
-Installing from source can be done with opam: `opam install builder-web`.
-
-We also provide [reproducible binary packages](https://builds.robur.coop/job/builder-web/).
+The build artifacts are stored on the filesystem, its metadata is stored in the database.
 
 ## Setup
 
@@ -28,33 +22,11 @@ Builder-web consists of a binary `builder-web` that runs a web server on port 30
 These values can be changed with the `--port` and `--host` flags respectively.
 See `builder-web --help` for more information.
 
-Service scripts for FreeBSD and systemd are provided.
-
 The web server expects a sqlite3 database in its data directory.
-An empty database can be created with `builder-db migrate`.
 
 ## Database migrations
 
 The sqlite3 database builder-web uses contains versioning information.
 On every schema change the database schema version is updated, and migration and rollback scripts are provided.
 The tool for database migrations is `builder-migrations`.
-See the `builder-migrations --help` output for each migration for further details.
-
-## Less common workflows
-
-Here are listed some less common but useful workflows:
-
-### Extracting builds from one server to another
-
-This is useful for development on a separate machine that doesn't run the build jobs itself.
-
-On the source server:
-```ocaml
-builder-db extract-build <build-hash> --dest <build-hash>.full
-```
-
-After copying the file over the destination server (you need a user first,
-see `builder-db user-add --help`):
-```ocaml
-curl --data-binary @<build-hash>.full http://<user>:<passwd>@localhost:<builder-web-port>/upload
-```
+See the `--help` output for each migration for further details.

auth/builder_web_auth.ml

@@ -12,9 +12,9 @@ let scrypt_params ?(scrypt_n = 16384) ?(scrypt_r = 8) ?(scrypt_p = 1) () =
   { scrypt_n; scrypt_r; scrypt_p }
 
 type pbkdf2_sha256 =
-  [ `Pbkdf2_sha256 of string * string * pbkdf2_sha256_params ]
+  [ `Pbkdf2_sha256 of Cstruct.t * Cstruct.t * pbkdf2_sha256_params ]
 
-type scrypt = [ `Scrypt of string * string * scrypt_params ]
+type scrypt = [ `Scrypt of Cstruct.t * Cstruct.t * scrypt_params ]
 
 type password_hash = [ pbkdf2_sha256 | scrypt ]
 
@@ -25,10 +25,10 @@ type 'a user_info = {
 }
 
 let pbkdf2_sha256 ~params:{ pbkdf2_sha256_iter = count } ~salt ~password =
-  Pbkdf.pbkdf2 ~prf:`SHA256 ~count ~dk_len:32l ~salt ~password
+  Pbkdf.pbkdf2 ~prf:`SHA256 ~count ~dk_len:32l ~salt ~password:(Cstruct.of_string password)
 
 let scrypt ~params:{ scrypt_n = n; scrypt_r = r; scrypt_p = p } ~salt ~password =
-  Scrypt.scrypt ~n ~r ~p ~dk_len:32l ~salt ~password
+  Scrypt_kdf.scrypt_kdf ~n ~r ~p ~dk_len:32l ~salt ~password:(Cstruct.of_string password)
 
 let hash ?(scrypt_params=scrypt_params ())
     ~username ~password ~restricted () =
@@ -43,10 +43,10 @@ let hash ?(scrypt_params=scrypt_params ())
 let verify_password password user_info =
   match user_info.password_hash with
   | `Pbkdf2_sha256 (password_hash, salt, params) ->
-    String.equal
+    Cstruct.equal
       (pbkdf2_sha256 ~params ~salt ~password)
       password_hash
   | `Scrypt (password_hash, salt, params) ->
-    String.equal
+    Cstruct.equal
       (scrypt ~params ~salt ~password)
       password_hash

auth/dune

@@ -1,3 +1,3 @@
 (library
  (name builder_web_auth)
- (libraries kdf.pbkdf kdf.scrypt mirage-crypto-rng))
+ (libraries pbkdf scrypt-kdf mirage-crypto-rng))

bin/builder_db.ml

@@ -0,0 +1,488 @@
+let ( let* ) = Result.bind
+let ( let+ ) x f = Result.map f x
+
+let or_die exit_code = function
+  | Ok r -> r
+  | Error (`Msg msg) ->
+    Format.eprintf "Error: %s" msg;
+    exit exit_code
+  | Error (#Caqti_error.t as e) ->
+    Format.eprintf "Database error: %a" Caqti_error.pp e;
+    exit exit_code
+
+let foreign_keys =
+  Caqti_request.exec
+    Caqti_type.unit
+    "PRAGMA foreign_keys = ON"
+
+let defer_foreign_keys =
+  Caqti_request.exec
+    Caqti_type.unit
+    "PRAGMA defer_foreign_keys = ON"
+
+let connect uri =
+  let* (module Db : Caqti_blocking.CONNECTION) = Caqti_blocking.connect uri in
+  let* () = Db.exec foreign_keys () in
+  let* () = Db.exec defer_foreign_keys () in
+  Ok (module Db : Caqti_blocking.CONNECTION)
+
+let do_migrate dbpath =
+  let* (module Db : Caqti_blocking.CONNECTION) =
+    connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ())
+  in
+  List.fold_left
+    (fun r migrate ->
+       let* () = r in
+       Logs.debug (fun m -> m "Executing migration query: %a" Caqti_request.pp migrate);
+       Db.exec migrate ())
+    (Ok ())
+    Builder_db.migrate
+
+let migrate () dbpath =
+  or_die 1 (do_migrate dbpath)
+
+let user_mod action dbpath scrypt_n scrypt_r scrypt_p username unrestricted =
+  let scrypt_params = Builder_web_auth.scrypt_params ?scrypt_n ?scrypt_r ?scrypt_p () in
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    print_string "Password: ";
+    flush stdout;
+    (* FIXME: getpass *)
+    let password = read_line () in
+    let restricted = not unrestricted in
+    let user_info = Builder_web_auth.hash ~scrypt_params ~username ~password ~restricted () in
+    match action with
+    | `Add ->
+      Db.exec Builder_db.User.add user_info
+    | `Update ->
+      Db.exec Builder_db.User.update_user user_info
+  in
+  or_die 1 r
+
+let user_add () dbpath = user_mod `Add dbpath
+
+let user_update () dbpath = user_mod `Update dbpath
+
+let user_list () dbpath =
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    Db.iter_s Builder_db.User.get_all
+      (fun (_id, username) -> Ok (print_endline username))
+      ()
+  in
+  or_die 1 r
+
+let user_remove () dbpath username =
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    let* () = Db.exec Builder_db.Access_list.remove_all_by_username username in
+    Db.exec Builder_db.User.remove_user username
+  in
+  or_die 1 r
+
+let user_disable () dbpath username =
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    let* () = Db.exec Builder_db.Access_list.remove_all_by_username username in
+    let* user = Db.find_opt Builder_db.User.get_user username in
+    match user with
+    | None -> Error (`Msg "user not found")
+    | Some (_, user_info) ->
+      let password_hash = `Scrypt (Cstruct.empty, Cstruct.empty, Builder_web_auth.scrypt_params ()) in
+      let user_info = { user_info with password_hash ; restricted = true } in
+      Db.exec Builder_db.User.update_user user_info
+  in
+  or_die 1 r
+
+let access_add () dbpath username jobname =
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    let* (user_id, _) =
+      Result.bind (Db.find_opt Builder_db.User.get_user username)
+        (Option.to_result ~none:(`Msg "unknown user"))
+    in
+    let* job_id =
+      Result.bind (Db.find_opt Builder_db.Job.get_id_by_name jobname)
+        (Option.to_result ~none:(`Msg "job not found"))
+    in
+    Db.exec Builder_db.Access_list.add (user_id, job_id)
+   in
+   or_die 1 r
+
+let access_remove () dbpath username jobname =
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    let* (user_id, _) =
+      Result.bind (Db.find_opt Builder_db.User.get_user username)
+        (Option.to_result ~none:(`Msg "unknown user"))
+    in
+    let* (job_id) =
+      Result.bind (Db.find_opt Builder_db.Job.get_id_by_name jobname)
+        (Option.to_result ~none:(`Msg "job not found"))
+    in
+    Db.exec Builder_db.Access_list.remove (user_id, job_id)
+   in
+   or_die 1 r
+
+let access_list () dbpath =
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    Db.iter_s Builder_db.Access_list.get_all_names
+      (fun (username, job) -> Ok (Printf.printf "%s:%s\n" username job))
+      ()
+  in
+  or_die 1 r
+
+let job_remove () datadir jobname =
+  let dbpath = datadir ^ "/builder.sqlite3" in
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    let* job_id_opt = Db.find_opt Builder_db.Job.get_id_by_name jobname in
+    match job_id_opt with
+    | None ->
+      Logs.info (fun m -> m "Job %S doesn't exist or has already been removed." jobname);
+      Ok ()
+    | Some job_id ->
+      let* () = Db.start () in
+      let* () = Db.exec defer_foreign_keys () in
+      let r =
+        let* builds = Db.collect_list Builder_db.Build.get_all job_id in
+        let* () =
+          List.fold_left (fun r (build_id, build) ->
+              let* () = r in
+              let dir = Fpath.(v datadir / jobname / Uuidm.to_string build.Builder_db.Build.uuid) in
+              (match Bos.OS.Dir.delete ~recurse:true dir with
+               | Ok _ -> ()
+               | Error `Msg e -> Logs.warn (fun m -> m "failed to remove build directory %a: %s" Fpath.pp dir e));
+              let* () = Db.exec Builder_db.Build_artifact.remove_by_build build_id in
+              Db.exec Builder_db.Build.remove build_id)
+            (Ok ())
+            builds
+        in
+        let* () = Db.exec Builder_db.Job.remove job_id in
+        Db.commit ()
+      in
+      match r with
+      | Ok () -> Ok ()
+      | Error _ as e ->
+        Logs.warn (fun m -> m "Error: rolling back...");
+        let* () = Db.rollback () in
+        e
+  in
+  or_die 1 r
+
+let input_ids =
+   Caqti_request.collect
+     Caqti_type.unit
+     Builder_db.Rep.cstruct
+     "SELECT DISTINCT input_id FROM build WHERE input_id IS NOT NULL"
+
+let main_artifact_hash =
+   Caqti_request.collect
+     Builder_db.Rep.cstruct
+     (Caqti_type.tup3 Builder_db.Rep.cstruct Builder_db.Rep.uuid Caqti_type.string)
+     {|
+       SELECT a.sha256, b.uuid, j.name FROM build_artifact a, build b, job j
+       WHERE b.input_id = ? AND a.id = b.main_binary AND b.job = j.id
+     |}
+
+let verify_input_id () dbpath =
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    let* input_ids = Db.collect_list input_ids () in
+    List.fold_left (fun acc input_id ->
+        let* () = acc in
+        let+ hashes = Db.collect_list main_artifact_hash input_id in
+        match hashes with
+        | (h, uuid, jobname) :: tl ->
+          List.iter (fun (h', uuid', _) ->
+              if Cstruct.equal h h' then
+                ()
+              else
+                Logs.warn (fun m -> m "job %s input id %a with two different hashes (%a, %a), build %a and %a"
+                              jobname Cstruct.hexdump_pp input_id
+                              Cstruct.hexdump_pp h Cstruct.hexdump_pp h'
+                              Uuidm.pp uuid Uuidm.pp uuid'))
+            tl
+        | [] -> ())
+      (Ok ()) input_ids
+  in
+  or_die 1 r
+
+let num_build_artifacts =
+  Caqti_request.find
+    Caqti_type.unit
+    Caqti_type.int
+    "SELECT count(*) FROM build_artifact"
+
+let build_artifacts : (unit, string * Uuidm.t * (Fpath.t * Fpath.t * Cstruct.t * int64), [ `One | `Zero | `Many ]) Caqti_request.t =
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup3 string Builder_db.Rep.uuid (tup4 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct int64))
+    {| SELECT job.name, b.uuid, a.filepath, a.localpath, a.sha256, a.size
+       FROM build_artifact a, build b, job
+       WHERE a.build = b.id AND b.job = job.id |}
+
+let script_and_console : (unit, _, [`One | `Zero | `Many ]) Caqti_request.t =
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup4 string Builder_db.Rep.uuid Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    {| SELECT job.name, b.uuid, b.console, b.script
+       FROM build b, job
+       WHERE job.id = b.job |}
+
+module FpathSet = Set.Make(Fpath)
+
+let files_in_dir dir =
+  Bos.OS.Dir.fold_contents ~elements:`Files ~dotfiles:true
+    (fun f acc ->
+       let f = Option.get (Fpath.rem_prefix dir f) in
+       FpathSet.add f acc)
+    FpathSet.empty
+    dir
+
+let verify_data_dir () datadir =
+  let files_in_filesystem = or_die 1 (files_in_dir (Fpath.v datadir)) in
+  Logs.info (fun m -> m "files in filesystem: %d" (FpathSet.cardinal files_in_filesystem));
+  let files_tracked = ref (FpathSet.singleton (Fpath.v "builder.sqlite3")) in
+  let dbpath = datadir ^ "/builder.sqlite3" in
+  Logs.info (fun m -> m "connecting to %s" dbpath);
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    let* num_build_artifacts = Db.find num_build_artifacts () in
+    Logs.info (fun m -> m "total: %d artifacts" num_build_artifacts);
+    let progress =
+      let idx = ref 0 in
+      fun () -> incr idx; if !idx mod 100 = 0 then Logs.info (fun m -> m "%d" !idx);
+    in
+    let verify_job_and_uuid ?fpath job uuid path =
+      match Fpath.segs path with
+      | job' :: uuid' :: tl ->
+        if String.equal job job' then () else Logs.warn (fun m -> m "job names do not match: %s vs %s" job job');
+        if String.equal (Uuidm.to_string uuid) uuid' then () else Logs.warn (fun m -> m "uuid does not match: %s vs %s" (Uuidm.to_string uuid) uuid');
+        (match fpath, tl with
+         | None, _ -> ()
+         | Some f, "output" :: tl ->
+           if Fpath.equal (Fpath.v (String.concat "/" tl)) f then
+            ()
+           else
+            Logs.err (fun m -> m "path (%a) and fpath (%a) do not match" Fpath.pp path Fpath.pp f)
+         | Some _, _ ->
+           Logs.err (fun m -> m "path is not of form <job>/<uuid>/output/<filename>: %a" Fpath.pp path))
+      | _ -> Logs.err (fun m -> m "path is not of form <job>/<uuid>/...: %a" Fpath.pp path)
+    in
+    let* () =
+      Db.iter_s build_artifacts (fun (job, uuid, (fpath, lpath, sha, size)) ->
+          progress ();
+          verify_job_and_uuid ~fpath job uuid lpath;
+          let abs_path = Fpath.(v datadir // lpath) in
+          (match Bos.OS.File.read abs_path with
+           | Error (`Msg msg) -> Logs.err (fun m -> m "file %a not present: %s" Fpath.pp abs_path msg)
+           | Ok data ->
+             files_tracked := FpathSet.add lpath !files_tracked;
+             let s = Int64.of_int (String.length data) in
+             if s <> size then Logs.err (fun m -> m "File %a has different size (in DB %Lu on disk %Lu)" Fpath.pp abs_path size s);
+             let sh = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
+             if not (Cstruct.equal sha sh) then Logs.err (fun m -> m "File %a has different hash (in DB %a on disk %a" Fpath.pp abs_path Cstruct.hexdump_pp sha Cstruct.hexdump_pp sh)) ;
+          Ok ()
+        ) ()
+    in
+    Db.iter_s script_and_console (fun (job, uuid, console, script) ->
+       verify_job_and_uuid job uuid console;
+       verify_job_and_uuid job uuid script;
+       let console_file = Fpath.(v datadir // console)
+       and script_file = Fpath.(v datadir // script)
+       in
+       let* _ = Bos.OS.File.must_exist console_file in
+       let* _ = Bos.OS.File.must_exist script_file in
+       files_tracked := FpathSet.add console (FpathSet.add script !files_tracked);
+       Ok ()) ()
+  in
+  let files_untracked = FpathSet.diff files_in_filesystem !files_tracked in
+  FpathSet.iter (fun f ->
+      Logs.warn (fun m -> m "untracked file in filesystem: %a" Fpath.pp f))
+    files_untracked;
+  or_die 1 r
+
+let help man_format cmds = function
+  | None -> `Help (man_format, None)
+  | Some cmd ->
+    if List.mem cmd cmds
+    then `Help (man_format, Some cmd)
+    else `Error (true, "Unknown command: " ^ cmd)
+
+let dbpath =
+  let doc = "sqlite3 database path" in
+  Cmdliner.Arg.(value &
+                opt non_dir_file "/var/db/builder-web/builder.sqlite3" &
+                info ~doc ["dbpath"])
+
+let dbpath_new =
+  let doc = "sqlite3 database path" in
+  Cmdliner.Arg.(value &
+                opt string "/var/db/builder-web/builder.sqlite3" &
+                info ~doc ["dbpath"])
+
+let datadir =
+  let doc = "data directory" in
+  Cmdliner.Arg.(value &
+                opt dir "/var/db/builder-web/" &
+                info ~doc ["datadir"])
+
+let jobname =
+  let doc = "jobname" in
+  Cmdliner.Arg.(required &
+                pos 0 (some string) None &
+                info ~doc ~docv:"JOBNAME" [])
+
+let username =
+  let doc = "username" in
+  Cmdliner.Arg.(required &
+                pos 0 (some string) None &
+                info ~doc ~docv:"USERNAME" [])
+
+let password_iter =
+  let doc = "password hash count" in
+  Cmdliner.Arg.(value &
+                opt (some int) None &
+                info ~doc ["hash-count"])
+
+let scrypt_n =
+  let doc = "scrypt n parameter" in
+  Cmdliner.Arg.(value &
+                opt (some int) None &
+                info ~doc ["scrypt-n"])
+
+let scrypt_r =
+  let doc = "scrypt r parameter" in
+  Cmdliner.Arg.(value &
+                opt (some int) None &
+                info ~doc ["scrypt-r"])
+
+let scrypt_p =
+  let doc = "scrypt p parameter" in
+  Cmdliner.Arg.(value &
+                opt (some int) None &
+                info ~doc ["scrypt-p"])
+
+let unrestricted =
+  let doc = "unrestricted user" in
+  Cmdliner.Arg.(value & flag & info ~doc [ "unrestricted" ])
+
+let job =
+  let doc = "job" in
+  Cmdliner.Arg.(required &
+                pos 1 (some string) None &
+                info ~doc ~docv:"JOB" [])
+
+let setup_log =
+  let setup_log level =
+    Logs.set_level level;
+    Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ());
+    Logs.debug (fun m -> m "Set log level %s" (Logs.level_to_string level))
+  in
+  Cmdliner.Term.(const setup_log $ Logs_cli.level ())
+
+let migrate_cmd =
+  let doc = "create database and add tables" in
+  Cmdliner.Term.(pure migrate $ setup_log $ dbpath_new),
+  Cmdliner.Term.info ~doc "migrate"
+
+let user_add_cmd =
+  let doc = "add a user" in
+  (Cmdliner.Term.(pure user_add $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username $ unrestricted),
+   Cmdliner.Term.info ~doc "user-add")
+
+let user_update_cmd =
+  let doc = "update a user password" in
+  (Cmdliner.Term.(pure user_update $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username $ unrestricted),
+   Cmdliner.Term.info ~doc "user-update")
+
+let user_remove_cmd =
+  let doc = "remove a user" in
+  (Cmdliner.Term.(pure user_remove $ setup_log $ dbpath $ username),
+   Cmdliner.Term.info ~doc "user-remove")
+
+let user_disable_cmd =
+  let doc = "disable a user" in
+  (Cmdliner.Term.(pure user_disable $ setup_log $ dbpath $ username),
+   Cmdliner.Term.info ~doc "user-disable")
+
+let user_list_cmd =
+  let doc = "list all users" in
+  (Cmdliner.Term.(pure user_list $ setup_log $ dbpath),
+   Cmdliner.Term.info ~doc "user-list")
+
+let access_add_cmd =
+  let doc = "grant access to user and job" in
+  (Cmdliner.Term.(pure access_add $ setup_log $ dbpath $ username $ job),
+   Cmdliner.Term.info ~doc "access-add")
+
+let access_remove_cmd =
+  let doc = "remove access to user and job" in
+  (Cmdliner.Term.(pure access_remove $ setup_log $ dbpath $ username $ job),
+   Cmdliner.Term.info ~doc "access-remove")
+
+let access_list_cmd =
+  let doc = "list user access" in
+  (Cmdliner.Term.(pure access_list $ setup_log $ dbpath),
+   Cmdliner.Term.info ~doc "access-list")
+
+let job_remove_cmd =
+  let doc = "remove job and its associated builds and artifacts" in
+  (Cmdliner.Term.(pure job_remove $ setup_log $ datadir $ jobname),
+   Cmdliner.Term.info ~doc "job-remove")
+
+let verify_input_id_cmd =
+  let doc = "verify that the main binary hash of all builds with the same input are equal" in
+  (Cmdliner.Term.(pure verify_input_id $ setup_log $ dbpath),
+   Cmdliner.Term.info ~doc "verify-input-id")
+
+let verify_data_dir_cmd =
+  let doc = "verify that the data directory is consistent with the build_artifact table" in
+  (Cmdliner.Term.(pure verify_data_dir $ setup_log $ datadir),
+   Cmdliner.Term.info ~doc "verify-data-dir")
+
+let help_cmd =
+  let topic =
+    let doc = "Command to get help on" in
+    Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"COMMAND" [])
+  in
+  let doc = "Builder database help" in
+  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ topic)),
+  Cmdliner.Term.info ~doc "help"
+
+let default_cmd =
+  let doc = "Builder database command" in
+  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ const None)),
+  Cmdliner.Term.info ~doc "builder-db"
+
+let () =
+  Mirage_crypto_rng_unix.initialize ();
+  Cmdliner.Term.eval_choice
+    default_cmd
+    [help_cmd; migrate_cmd;
+     user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd; user_disable_cmd;
+     access_add_cmd; access_remove_cmd; access_list_cmd; job_remove_cmd;
+     verify_input_id_cmd; verify_data_dir_cmd ]
+  |> Cmdliner.Term.exit

bin/builder_system.ml

@@ -1,17 +0,0 @@
-let uname =
-  let cmd = Bos.Cmd.(v "uname" % "-s") in
-  lazy (match Bos.OS.Cmd.(run_out cmd |> out_string |> success) with
-      | Ok s when s = "FreeBSD" -> `FreeBSD
-      | Ok s when s = "Linux" -> `Linux
-      | Ok s -> invalid_arg (Printf.sprintf "OS %s not supported" s)
-      | Error (`Msg m) -> invalid_arg m)
-
-let default_datadir =
-  match Lazy.force uname with
-  | `FreeBSD -> "/var/db/builder-web"
-  | `Linux -> "/var/lib/builder-web"
-
-let default_configdir =
-  match Lazy.force uname with
-  | `FreeBSD -> "/usr/local/etc/builder-web"
-  | `Linux -> "/etc/builder-web"

bin/builder_web_app.ml

@@ -30,7 +30,7 @@ let write_raw s buf =
          safe_close s >|= fun () ->
          Error `Exception)
   in
-  (*  Logs.debug (fun m -> m "writing %a" (Ohex.pp_hexdump ()) (Bytes.unsafe_to_string buf)) ; *)
+  (*  Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *)
   w 0 (Bytes.length buf)
 
 let process =
@@ -78,101 +78,30 @@ let init_influx name data =
     in
     Lwt.async report
 
-let run_batch_viz ~cachedir ~datadir ~configdir =
-  let open Rresult.R.Infix in
-  begin
-    let script = Fpath.(configdir / "batch-viz.sh")
-    and script_log = Fpath.(cachedir / "batch-viz.log")
-    and viz_script = Fpath.(configdir / "upload-hooks" / "visualizations.sh")
-    in
-    Bos.OS.File.exists script >>= fun script_exists ->
-    if not script_exists then begin
-      Logs.warn (fun m -> m "Didn't find %s" (Fpath.to_string script));
-      Ok ()
-    end else
-      let args =
-        [ "--cache-dir=" ^ Fpath.to_string cachedir;
-          "--data-dir=" ^ Fpath.to_string datadir;
-          "--viz-script=" ^ Fpath.to_string viz_script ]
-        |> List.map (fun s -> "\"" ^ String.escaped s ^ "\"")
-        |> String.concat " "
-      in
-      (*> Note: The reason for appending, is that else a new startup could
-          overwrite an existing running batch's log*)
-      (Fpath.to_string script ^ " " ^ args
-       ^ " 2>&1 >> " ^ Fpath.to_string script_log
-       ^ " &")
-      |> Sys.command
-      |> ignore
-      |> Result.ok
-  end
-  |> function
-  | Ok () -> ()
-  | Error err ->
-    Logs.warn (fun m ->
-        m "Error while starting batch-viz.sh: %a"
-          Rresult.R.pp_msg err)
-
-let setup_app level influx port host datadir cachedir configdir run_batch_viz_flag expired_jobs =
+let setup_app level influx port host datadir =
   let dbpath = Printf.sprintf "%s/builder.sqlite3" datadir in
   let datadir = Fpath.v datadir in
-  let cachedir =
-    cachedir |> Option.fold ~none:Fpath.(datadir / "_cache") ~some:Fpath.v
-  in
-  let configdir = Fpath.v configdir in
-  let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) in
   let () = init_influx "builder-web" influx in
-  let () =
-    if run_batch_viz_flag then
-      run_batch_viz ~cachedir ~datadir ~configdir
-  in
   match Builder_web.init dbpath datadir with
-  | exception Sqlite3.Error e ->
-    Format.eprintf "Error: @[@,%s.\
-                    @,Does the database file exist? Create with `builder-db migrate`.@]\n%!"
-      e;
-    exit 2
   | Error (#Caqti_error.load as e) ->
     Format.eprintf "Error: %a\n%!" Caqti_error.pp e;
     exit 2
-          | Error (`Wrong_version _ as e) ->
-    Format.eprintf "Error: @[@,%a.\
-                    @,Migrate database version with `builder-migrations`,\
-                    @,or start with a fresh database with `builder-db migrate`.@]\n%!"
-      Builder_web.pp_error e;
-  | Error (
-      #Caqti_error.connect
-    | #Caqti_error.call_or_retrieve
-    | `Msg _ as e
-    ) ->
+  | Error (#Caqti_error.connect | #Caqti_error.call_or_retrieve | `Msg _ | `Wrong_version _ as e) ->
     Format.eprintf "Error: %a\n%!" Builder_web.pp_error e;
     exit 1
   | Ok () ->
-    let level = match level with
-      | None -> None
-      | Some Logs.Debug -> Some `Debug
-      | Some Info -> Some `Info
-      | Some Warning -> Some `Warning
-      | Some Error -> Some `Error
-      | Some App -> None
-    in
-    let error_handler = Dream.error_template Builder_web.error_template in
+    let level = match level with None -> None | Some Logs.Debug -> Some `Debug | Some Info -> Some `Info | Some Warning -> Some `Warning | Some Error -> Some `Error | Some App -> None in
     Dream.initialize_log ?level ();
-    let dream_routes = Builder_web.(
-        routes ~datadir ~cachedir ~configdir ~expired_jobs
-        |> to_dream_routes
-      )
-    in
-    Dream.run ~port ~interface:host ~tls:false ~error_handler
+    Dream.run ~port ~interface:host ~https:false
     @@ Dream.logger
     @@ Dream.sql_pool ("sqlite3:" ^ dbpath)
     @@ Http_status_metrics.handle
-    @@ Builder_web.Middleware.remove_trailing_url_slash
-    @@ Dream.router dream_routes
+    @@ Builder_web.add_routes datadir
+    @@ Dream.not_found
 
 open Cmdliner
 
-let ip_port : (Ipaddr.V4.t * int) Arg.conv =
+let ip_port : (Ipaddr.V4.t * int) Arg.converter =
   let default_port = 8094 in
   let parse s =
     match
@@ -184,40 +113,16 @@ let ip_port : (Ipaddr.V4.t * int) Arg.conv =
       end
         | _ -> Error "multiple : found"
     with
-    | Error msg -> Error (`Msg msg)
+    | Error msg -> `Error msg
     | Ok (ip, port) -> match Ipaddr.V4.of_string ip with
-      | Ok ip -> Ok (ip, port)
-      | Error `Msg msg -> Error (`Msg msg)
+      | Ok ip -> `Ok (ip, port)
+      | Error `Msg msg -> `Error msg
   in
-  let printer ppf (ip, port) =
-    Format.fprintf ppf "%a:%d" Ipaddr.V4.pp ip port in
-  Arg.conv (parse, printer)
+  parse, fun ppf (ip, port) -> Format.fprintf ppf "%a:%d" Ipaddr.V4.pp ip port
 
 let datadir =
   let doc = "data directory" in
-  let docv = "DATA_DIR" in
-  let env = Cmdliner.Cmd.Env.info "BUILDER_WEB_DATADIR" in
-  Arg.(
-    value &
-    opt dir Builder_system.default_datadir &
-    info ~env [ "d"; "datadir" ] ~doc ~docv
-  )
-
-let cachedir =
-  let doc = "cache directory" in
-  let docv = "CACHE_DIR" in
-  Arg.(
-    value
-    & opt (some ~none:"DATADIR/_cache" dir) None
-    & info [ "cachedir" ] ~doc ~docv)
-
-let configdir =
-  let doc = "config directory" in
-  let docv = "CONFIG_DIR" in
-  Arg.(
-    value &
-    opt dir Builder_system.default_configdir &
-    info [ "c"; "configdir" ] ~doc ~docv)
+  Arg.(value & opt dir "/var/db/builder-web/" & info [ "d"; "datadir" ] ~doc)
 
 let port =
   let doc = "port" in
@@ -228,31 +133,13 @@ let host =
   Arg.(value & opt string "0.0.0.0" & info [ "h"; "host" ] ~doc)
 
 let influx =
-  let doc = "IP address and port (default: 8094) to report metrics to \
-             influx line protocol" in
-  Arg.(
-    value &
-    opt (some ip_port) None &
-    info [ "influx" ] ~doc ~docv:"INFLUXHOST[:PORT]")
-
-let run_batch_viz =
-  let doc = "Run CONFIG_DIR/batch-viz.sh on startup. \
-             Note that this is started in the background - so the user \
-             is in charge of not running several instances of this. A \
-             log is written to CACHE_DIR/batch-viz.log" in
-  Arg.(value & flag & info [ "run-batch-viz" ] ~doc)
-
-let expired_jobs =
-  let doc = "Amount of days after which a job is considered to be inactive if \
-             no successful build has been achieved (use 0 for infinite)" in
-  Arg.(value & opt int 30 & info [ "expired-jobs" ] ~doc)
+  let doc = "IP address and port (default: 8094) to report metrics to in influx line protocol" in
+  Arg.(value & opt (some ip_port) None & info [ "influx" ] ~doc ~docv:"INFLUXHOST[:PORT]")
 
 let () =
-  let term =
-    Term.(const setup_app $ Logs_cli.level () $ influx $ port $ host $ datadir $
-          cachedir $ configdir $ run_batch_viz $ expired_jobs)
-  in
-  let info = Cmd.info "Builder web" ~doc:"Builder web" ~man:[] in
-  Cmd.v info term
-  |> Cmd.eval
-  |> exit
+  let term = Term.(pure setup_app $ Logs_cli.level () $ influx $ port $ host $ datadir) in
+  let info = Term.info "Builder web" ~doc:"Builder web" ~man:[] in
+  match Term.eval (term, info) with
+  | `Ok () -> exit 0
+  | `Error _ -> exit 1
+  | _ -> exit 0

bin/dune

@@ -1,19 +1,11 @@
-(library
- (name builder_system)
- (modules builder_system)
- (libraries bos))
-
 (executable
  (public_name builder-web)
  (name builder_web_app)
  (modules builder_web_app)
- (libraries builder_web builder_system mirage-crypto-rng.unix cmdliner
-   logs.cli metrics metrics-lwt metrics-influx metrics-rusage ipaddr
-   ipaddr.unix http_status_metrics))
+ (libraries builder_web mirage-crypto-rng.unix cmdliner logs.cli metrics metrics-lwt metrics-influx metrics-rusage ipaddr ipaddr.unix http_status_metrics))
 
 (executable
  (public_name builder-db)
- (name builder_db_app)
- (modules builder_db_app)
- (libraries builder_web builder_db builder_system caqti.blocking uri bos fmt
-   logs logs.cli logs.fmt cmdliner mirage-crypto-rng.unix builder))
+ (name builder_db)
+ (modules builder_db)
+ (libraries builder_db caqti.blocking uri bos fmt logs logs.cli logs.fmt cmdliner mirage-crypto-rng.unix))

bin/migrations/builder_migrations.ml

@@ -24,7 +24,7 @@ let pp_error ppf = function
 let or_die exit_code = function
   | Ok r -> r
   | Error e ->
-    Format.eprintf "Database error: %a\n" pp_error e;
+    Format.eprintf "Database error: %a" pp_error e;
     exit exit_code
 
 let do_database_action action () datadir =
@@ -61,10 +61,9 @@ let help man_format migrations = function
 
 let datadir =
   let doc = "data directory containing builder.sqlite3 and data files" in
-  let env = Cmdliner.Cmd.Env.info "BUILDER_WEB_DATADIR" in
   Cmdliner.Arg.(value &
-                opt dir Builder_system.default_datadir &
-                info ~env ~doc ["datadir"; "d"])
+                opt dir "/var/db/builder-web/" &
+                info ~doc ["datadir"])
 
 let setup_log =
   let setup_log level =
@@ -73,69 +72,53 @@ let setup_log =
   in
   Cmdliner.Term.(const setup_log $ Logs_cli.level ())
 
-open Cmdliner
-
 let actions (module M : MIGRATION) =
   let c s = s ^ "-" ^ M.identifier in
   let v doc from_ver to_ver = Printf.sprintf "%s (DB version %Ld -> %Ld)" doc from_ver to_ver in
-  let migrate_cmd =
-    let term = Term.(
-        const do_database_action $ const M.migrate $ setup_log $ datadir) in
-    let info = Cmd.info ~doc:(v M.migrate_doc M.old_version M.new_version)
-        (c "migrate") in
-    Cmd.v info term
-  in
-  let rollback_cmd =
-    let term = Term.(
-        const do_database_action $ const M.rollback $ setup_log $ datadir) in
-    let info = Cmd.info ~doc:(v M.rollback_doc M.new_version M.old_version)
-        (c "rollback") in
-    Cmd.v info term
-  in
-  [ migrate_cmd; rollback_cmd ]
+  [
+    (Cmdliner.Term.(const do_database_action $ const M.migrate $ setup_log $ datadir),
+     Cmdliner.Term.info ~doc:(v M.migrate_doc M.old_version M.new_version)
+       (c "migrate"));
+    (Cmdliner.Term.(const do_database_action $ const M.rollback $ setup_log $ datadir),
+     Cmdliner.Term.info ~doc:(v M.rollback_doc M.new_version M.old_version)
+       (c "rollback"));
+  ]
 
 let f20210308 =
   let doc = "Remove broken builds as fixed in commit a57798f4c02eb4d528b90932ec26fb0b718f1a13. \
     Note that the files on disk have to be removed manually." in
-  let term = Term.(const do_database_action $ const M20210308.fixup $ setup_log $ datadir) in
-  let info = Cmd.info ~doc "fixup-2021-03-08" in
-  Cmd.v info term
+  Cmdliner.Term.(const do_database_action $ const M20210308.fixup $ setup_log $ datadir),
+  Cmdliner.Term.info ~doc "fixup-2021-03-08"
 
 let f20210707a =
   let doc = "Remove orb.deb and orb.txz that ended up in the build." in
-  let term = Term.(const do_database_action $ const M20210707a.fixup $ setup_log $ datadir) in
-  let info = Cmd.info ~doc "fixup-2021-07-07a" in
-  Cmd.v info term
+  Cmdliner.Term.(const do_database_action $ const M20210707a.fixup $ setup_log $ datadir),
+  Cmdliner.Term.info ~doc "fixup-2021-07-07a"
 
 let f20210707b =
   let doc = "Move *.deb.debug to bin/*.deb and remove the earlier bin/*.deb. Adjust main_binary of build." in
-  let term = Term.(const do_database_action $ const M20210707b.fixup $ setup_log $ datadir) in
-  let info = Cmd.info ~doc "fixup-2021-07-07b" in
-  Cmd.v info term
+  Cmdliner.Term.(const do_database_action $ const M20210707b.fixup $ setup_log $ datadir),
+  Cmdliner.Term.info ~doc "fixup-2021-07-07b"
 
 let f20210707c =
   let doc = "Strip bin/*.{hvt,xen} if no *.{hvt,xen} exists. Adjust build_artifact table and main_binary of build." in
-  let term = Term.(const do_database_action $ const M20210707c.fixup $ setup_log $ datadir) in
-  let info = Cmd.info ~doc "fixup-2021-07-07c" in
-  Cmd.v info term
+  Cmdliner.Term.(const do_database_action $ const M20210707c.fixup $ setup_log $ datadir),
+  Cmdliner.Term.info ~doc "fixup-2021-07-07c"
 
 let f20210707d =
   let doc = "Remove ./ from filepath." in
-  let term = Term.(const do_database_action $ const M20210707d.fixup $ setup_log $ datadir) in
-  let info = Cmd.info ~doc "fixup-2021-07-07d" in
-  Cmd.v info term
+  Cmdliner.Term.(const do_database_action $ const M20210707d.fixup $ setup_log $ datadir),
+  Cmdliner.Term.info ~doc "fixup-2021-07-07d"
 
 let f20210712b =
   let doc = "Remove build-hashes and README from artifacts." in
-  let term = Term.(const do_database_action $ const M20210712b.fixup $ setup_log $ datadir) in
-  let info = Cmd.info ~doc "fixup-2021-07-12b" in
-  Cmd.v info term
+  Cmdliner.Term.(const do_database_action $ const M20210712b.fixup $ setup_log $ datadir),
+  Cmdliner.Term.info ~doc "fixup-2021-07-12b"
 
 let f20210910 =
   let doc = "Undo builds with script and console mixed up." in
-  let term = Term.(const do_database_action $ const M20210910.fixup $ setup_log $ datadir) in
-  let info = Cmd.info ~doc "fixup-2021-09-10" in
-  Cmd.v info term
+  Cmdliner.Term.(const do_database_action $ const M20210910.fixup $ setup_log $ datadir),
+  Cmdliner.Term.info ~doc "fixup-2021-09-10"
 
 let help_cmd =
   let topic =
@@ -143,16 +126,17 @@ let help_cmd =
     Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"MIGRATION" [])
   in
   let doc = "Builder migration help" in
-  let term = Term.(ret (const help $ Arg.man_format $ choice_names $ topic)) in
-  let info = Cmd.info ~doc "help" in
-  Cmd.v info term
+  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ topic)),
+  Cmdliner.Term.info ~doc "help"
+
+let default_cmd =
+  let doc = "Builder migration command" in
+  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ const None)),
+  Cmdliner.Term.info ~doc "builder-migrations"
 
 let () =
-  let doc = "Builder migration command" in
-  let default_term = Term.(ret (const help $ Arg.man_format $ choice_names $ const None)) in
-  let default_info = Cmd.info ~doc "builder-migrations" in
-  Cmd.group
-    ~default:default_term default_info
+  Cmdliner.Term.eval_choice
+    default_cmd
     (List.concat [
         [ help_cmd ];
         actions (module M20210126);
@@ -179,9 +163,5 @@ let () =
         actions (module M20210712c);
         [ f20210910 ];
         actions (module M20211105);
-        actions (module M20220509);
-        actions (module M20230911);
-        actions (module M20230914);
       ])
-  |> Cmd.eval
-  |> exit
+  |> Cmdliner.Term.exit

bin/migrations/dune

@@ -1,5 +1,4 @@
 (executable
  (public_name builder-migrations)
  (name builder_migrations)
- (libraries builder_system builder_db caqti caqti-driver-sqlite3
-   caqti.blocking cmdliner logs logs.cli logs.fmt opam-format bos duration))
+ (libraries builder_db caqti caqti-driver-sqlite3 caqti.blocking cmdliner logs logs.cli logs.fmt opam-format bos duration))

bin/migrations/grej.ml

@@ -1,29 +1,20 @@
 (* Grej is utilities *)
 module Syntax = struct
-  open Caqti_request.Infix
   let ( let* ) = Result.bind
   let ( let+ ) x f = Result.map f x
-  let ( ->. ) = ( ->. ) ~oneshot:true
-  let ( ->! ) = ( ->! ) ~oneshot:true
-  let ( ->? ) = ( ->? ) ~oneshot:true
-  let ( ->* ) = ( ->* ) ~oneshot:true
 end
 
 module Infix = struct
-  open Caqti_request.Infix
   let ( >>= ) = Result.bind
   let ( >>| ) x f = Result.map f x
-  let ( ->. ) = ( ->. ) ~oneshot:true
-  let ( ->! ) = ( ->! ) ~oneshot:true
-  let ( ->? ) = ( ->? ) ~oneshot:true
-  let ( ->* ) = ( ->* ) ~oneshot:true
 end
 
 open Syntax
 
 let set_version version =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  Printf.sprintf "PRAGMA user_version = %Ld" version
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    (Printf.sprintf "PRAGMA user_version = %Ld" version)
 
 let check_version
     ?application_id:(desired_application_id=Builder_db.application_id)
@@ -43,5 +34,6 @@ let list_iter_result f xs =
 
 let foreign_keys on =
   let on = if on then "ON" else "OFF" in
-  Caqti_type.unit ->. Caqti_type.unit @@
-  Printf.sprintf "PRAGMA foreign_keys = %s" on
+  Caqti_request.exec
+    Caqti_type.unit
+    (Printf.sprintf "PRAGMA foreign_keys = %s" on)

bin/migrations/m20210126.ml

@@ -3,27 +3,32 @@ let identifier = "2021-01-26"
 let migrate_doc = "add column main_binary to build"
 let rollback_doc = "remove column main_binary from build"
 
-open Grej.Infix
-
 let set_application_id =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  Printf.sprintf "PRAGMA application_id = %ld" Builder_db.application_id
+  Caqti_request.exec
+    Caqti_type.unit
+    (Printf.sprintf "PRAGMA application_id = %ld" Builder_db.application_id)
 
 let alter_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE build ADD COLUMN main_binary TEXT"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "ALTER TABLE build ADD COLUMN main_binary TEXT"
 
 let all_builds =
-  Caqti_type.unit ->* Caqti_type.int64 @@
-  "SELECT id FROM build"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.int64
+    "SELECT id FROM build"
 
 let bin_artifact =
-  Caqti_type.int64 ->* Caqti_type.(t2 int64 string) @@
-  "SELECT id, filepath FROM build_artifact WHERE build = ? AND filepath LIKE 'bin/%'"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.int64
+    Caqti_type.(tup2 int64 string)
+    "SELECT id, filepath FROM build_artifact WHERE build = ? AND filepath LIKE 'bin/%'"
 
 let set_main_binary =
-  Caqti_type.(t2 int64 (option string)) ->. Caqti_type.unit @@
-  "UPDATE build SET main_binary = $2 WHERE id = $1"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup2 int64 (option string))
+    "UPDATE build SET main_binary = ?2 WHERE id = ?1"
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let open Grej.Infix in
@@ -47,36 +52,39 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Db.exec (Grej.set_version new_version) ()
 
 let rename_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE build RENAME TO __tmp_build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "ALTER TABLE build RENAME TO __tmp_build"
 
 let create_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_kind TINYINT NOT NULL,
-       result_code INTEGER,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       job INTEGER NOT NULL,
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_kind TINYINT NOT NULL,
+         result_code INTEGER,
+         result_msg TEXT,
+         console BLOB NOT NULL,
+         script TEXT NOT NULL,
+         job INTEGER NOT NULL,
 
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+       |}
 
 let rollback_data =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| INSERT INTO build
-     SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
-       result_kind, result_code, result_msg, console, script, job
-     FROM __tmp_build
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO build
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_kind, result_code, result_msg, console, script, job
+       FROM __tmp_build
+    |}
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let open Grej.Infix in

bin/migrations/m20210202.ml

@@ -7,16 +7,18 @@ open Grej.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let job_build_idx =
-    Caqti_type.unit ->. Caqti_type.unit @@
-    "CREATE INDEX job_build_idx ON build(job)";
+    Caqti_request.exec ~oneshot:true
+      Caqti_type.unit
+      "CREATE INDEX job_build_idx ON build(job)";
   in
   Grej.check_version ~user_version:1L (module Db) >>= fun () ->
   Db.exec job_build_idx ()
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let q =
-    Caqti_type.unit ->. Caqti_type.unit @@
-    "DROP INDEX IF EXISTS job_build_idx"
+    Caqti_request.exec ~oneshot:true
+      Caqti_type.unit
+      "DROP INDEX IF EXISTS job_build_idx"
   in
   Grej.check_version ~user_version:1L (module Db) >>= fun () ->
   Db.exec q ()

bin/migrations/m20210216.ml

@@ -4,43 +4,46 @@ let identifier = "2021-02-16"
 let migrate_doc = "change to scrypt hashed passwords (NB: destructive!!)"
 let rollback_doc = "rollback scrypt hashed passwords (NB: destructive!!)"
 
-open Grej.Infix
-
 let drop_user =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE user"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "DROP TABLE user"
 
 let new_user =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE user (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       username VARCHAR(255) NOT NULL UNIQUE,
-       password_hash BLOB NOT NULL,
-       password_salt BLOB NOT NULL,
-       scrypt_n INTEGER NOT NULL,
-       scrypt_r INTEGER NOT NULL,
-       scrypt_p INTEGER NOT NULL
-     )
-  |}
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    {| CREATE TABLE user (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         username VARCHAR(255) NOT NULL UNIQUE,
+         password_hash BLOB NOT NULL,
+         password_salt BLOB NOT NULL,
+         scrypt_n INTEGER NOT NULL,
+         scrypt_r INTEGER NOT NULL,
+         scrypt_p INTEGER NOT NULL
+       )
+      |}
 
 let old_user =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE user (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       username VARCHAR(255) NOT NULL UNIQUE,
-       password_hash BLOB NOT NULL,
-       password_salt BLOB NOT NULL,
-       password_iter INTEGER NOT NULL
-     )
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE user (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         username VARCHAR(255) NOT NULL UNIQUE,
+         password_hash BLOB NOT NULL,
+         password_salt BLOB NOT NULL,
+         password_iter INTEGER NOT NULL
+       )
+    |}
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec drop_user () >>= fun () ->
   Db.exec new_user () >>= fun () ->
   Db.exec (Grej.set_version new_version) ()
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
   Db.exec drop_user () >>= fun () ->
   Db.exec old_user () >>= fun () ->

bin/migrations/m20210218.ml

@@ -4,75 +4,86 @@ let identifier = "2021-02-18"
 let migrate_doc = "add column size to build_file and build_artifact"
 let rollback_doc = "remove column size to build_file and build_artifact"
 
-open Grej.Infix
-
 let new_build_artifact =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build_artifact (
-         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-         filepath TEXT NOT NULL, -- the path as in the build
-         localpath TEXT NOT NULL, -- local path to the file on disk
-         sha256 BLOB NOT NULL,
-         size INTEGER NOT NULL,
-         build INTEGER NOT NULL,
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    {| CREATE TABLE new_build_artifact (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           filepath TEXT NOT NULL, -- the path as in the build
+           localpath TEXT NOT NULL, -- local path to the file on disk
+           sha256 BLOB NOT NULL,
+           size INTEGER NOT NULL,
+           build INTEGER NOT NULL,
 
-         FOREIGN KEY(build) REFERENCES build(id),
-         UNIQUE(build, filepath)
-       )
-  |}
+           FOREIGN KEY(build) REFERENCES build(id),
+           UNIQUE(build, filepath)
+         )
+      |}
 
 let new_build_file =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build_file (
-         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-         filepath TEXT NOT NULL, -- the path as in the build
-         localpath TEXT NOT NULL, -- local path to the file on disk
-         sha256 BLOB NOT NULL,
-         size INTEGER NOT NULL,
-         build INTEGER NOT NULL,
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    {| CREATE TABLE new_build_file (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           filepath TEXT NOT NULL, -- the path as in the build
+           localpath TEXT NOT NULL, -- local path to the file on disk
+           sha256 BLOB NOT NULL,
+           size INTEGER NOT NULL,
+           build INTEGER NOT NULL,
 
-         FOREIGN KEY(build) REFERENCES build(id),
-         UNIQUE(build, filepath)
-       )
-  |}
+           FOREIGN KEY(build) REFERENCES build(id),
+           UNIQUE(build, filepath)
+         )
+      |}
 
 let collect_build_artifact =
-  Caqti_type.unit ->* Caqti_type.(t3 int64 (t3 string string octets) int64) @@
-  "SELECT id, filepath, localpath, sha256, build FROM build_artifact"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.(tup3 int64 (tup3 string string octets) int64)
+    "SELECT id, filepath, localpath, sha256, build FROM build_artifact"
 
 let collect_build_file =
-  Caqti_type.unit ->* Caqti_type.(t3 int64 (t3 string string octets) int64) @@
-  "SELECT id, filepath, localpath, sha256, build FROM build_file"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.(tup3 int64 (tup3 string string octets) int64)
+    "SELECT id, filepath, localpath, sha256, build FROM build_file"
 
 let insert_new_build_artifact =
-  Caqti_type.(t3 int64 (t4 string string octets int64) int64) ->. Caqti_type.unit @@
-  {| INSERT INTO new_build_artifact (id, filepath, localpath, sha256, size, build)
-     VALUES (?, ?, ?, ?, ?, ?)
-  |}
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup3 int64 (tup4 string string octets int64) int64)
+    {| INSERT INTO new_build_artifact (id, filepath, localpath, sha256, size, build)
+       VALUES (?, ?, ?, ?, ?, ?)
+    |}
 
 let insert_new_build_file =
-  Caqti_type.(t3 int64 (t4 string string octets int64) int64) ->. Caqti_type.unit @@
-  {| INSERT INTO new_build_file (id, filepath, localpath, sha256, size, build)
-     VALUES (?, ?, ?, ?, ?, ?)
-  |}
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup3 int64 (tup4 string string octets int64) int64)
+    {| INSERT INTO new_build_file (id, filepath, localpath, sha256, size, build)
+       VALUES (?, ?, ?, ?, ?, ?)
+    |}
 
 let drop_build_artifact =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE build_artifact"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "DROP TABLE build_artifact"
 
 let drop_build_file =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE build_file"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "DROP TABLE build_file"
 
 let rename_build_artifact =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE new_build_artifact RENAME TO build_artifact"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "ALTER TABLE new_build_artifact RENAME TO build_artifact"
 
 let rename_build_file =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE new_build_file RENAME TO build_file"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "ALTER TABLE new_build_file RENAME TO build_file"
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec new_build_artifact () >>= fun () ->
   Db.rev_collect_list collect_build_artifact () >>= fun build_artifacts ->
@@ -99,42 +110,47 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Db.exec (Grej.set_version new_version) ()
 
 let old_build_artifact =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build_artifact (
-         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-         filepath TEXT NOT NULL, -- the path as in the build
-         localpath TEXT NOT NULL, -- local path to the file on disk
-         sha256 BLOB NOT NULL,
-         build INTEGER NOT NULL,
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    {| CREATE TABLE new_build_artifact (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           filepath TEXT NOT NULL, -- the path as in the build
+           localpath TEXT NOT NULL, -- local path to the file on disk
+           sha256 BLOB NOT NULL,
+           build INTEGER NOT NULL,
 
-         FOREIGN KEY(build) REFERENCES build(id),
-         UNIQUE(build, filepath)
-       )
-  |}
+           FOREIGN KEY(build) REFERENCES build(id),
+           UNIQUE(build, filepath)
+         )
+      |}
 
 let old_build_file =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build_file (
-         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-         filepath TEXT NOT NULL, -- the path as in the build
-         localpath TEXT NOT NULL, -- local path to the file on disk
-         sha256 BLOB NOT NULL,
-         build INTEGER NOT NULL,
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    {| CREATE TABLE new_build_file (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           filepath TEXT NOT NULL, -- the path as in the build
+           localpath TEXT NOT NULL, -- local path to the file on disk
+           sha256 BLOB NOT NULL,
+           build INTEGER NOT NULL,
 
-         FOREIGN KEY(build) REFERENCES build(id),
-         UNIQUE(build, filepath)
-       )
-  |}
+           FOREIGN KEY(build) REFERENCES build(id),
+           UNIQUE(build, filepath)
+         )
+      |}
 
 let copy_build_artifact =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "INSERT INTO new_build_artifact SELECT id, filepath, localpath, sha256, build FROM build_artifact"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "INSERT INTO new_build_artifact SELECT id, filepath, localpath, sha256, build FROM build_artifact"
 
 let copy_build_file =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "INSERT INTO new_build_file SELECT id, filepath, localpath, sha256, build FROM build_file"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "INSERT INTO new_build_file SELECT id, filepath, localpath, sha256, build FROM build_file"
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
   Db.exec old_build_artifact () >>= fun () ->
   Db.exec copy_build_artifact () >>= fun () ->

bin/migrations/m20210308.ml

@@ -1,21 +1,22 @@
 module Rep = Builder_db.Rep
 
-open Grej.Infix
-
 let broken_builds =
-  Caqti_type.unit ->* Caqti_type.t3 (Rep.id `build) Rep.uuid Caqti_type.string @@
-  {| SELECT b.id, b.uuid, job.name FROM build b, job
-     WHERE result_kind = 0 AND result_code = 0 AND main_binary IS NOT NULL AND job.id = b.job AND
-       (SELECT COUNT( * ) FROM build_artifact a
-        WHERE a.build = b.id and a.filepath = b.main_binary) = 0
-  |}
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    (Caqti_type.tup3 (Rep.id `build) Rep.uuid Caqti_type.string)
+    {| SELECT b.id, b.uuid, job.name FROM build b, job
+       WHERE result_kind = 0 AND result_code = 0 AND main_binary IS NOT NULL AND job.id = b.job AND
+         (SELECT COUNT( * ) FROM build_artifact a
+          WHERE a.build = b.id and a.filepath = b.main_binary) = 0
+    |}
 
-let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
+let fixup _datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:3L (module Db) >>= fun () ->
   Db.rev_collect_list broken_builds () >>= fun broken_builds ->
   Grej.list_iter_result
     (fun ((build, uuid, job_name) : [`build] Rep.id * Uuidm.t * string) ->
-       Format.printf "Removing job %a.\nPlease clean up data files in %a/%s/%a\n"
-         Uuidm.pp uuid Fpath.pp datadir job_name Uuidm.pp uuid;
+       Format.printf "Removing job %a.\nPlease clean up data files in /var/db/builder-web/%s/%a\n"
+         Uuidm.pp uuid job_name Uuidm.pp uuid;
        Db.exec Builder_db.Build.remove build)
     broken_builds

bin/migrations/m20210427.ml

@@ -7,12 +7,14 @@ open Grej.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let idx_build_job_start =
-    Caqti_type.unit ->. Caqti_type.unit @@
-    "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
+    Caqti_request.exec ~oneshot:true
+      Caqti_type.unit
+      "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
   in
   let rm_job_build_idx =
-    Caqti_type.unit ->. Caqti_type.unit @@
-    "DROP INDEX IF EXISTS job_build_idx"
+    Caqti_request.exec ~oneshot:true
+      Caqti_type.unit
+      "DROP INDEX IF EXISTS job_build_idx"
   in
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec rm_job_build_idx () >>= fun () ->
@@ -20,12 +22,14 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let job_build_idx =
-    Caqti_type.unit ->. Caqti_type.unit @@
-    "CREATE INDEX job_build_idx ON build(job)"
+    Caqti_request.exec ~oneshot:true
+      Caqti_type.unit
+      "CREATE INDEX job_build_idx ON build(job)"
   in
   let rm_idx_build_job_start =
-    Caqti_type.unit ->. Caqti_type.unit @@
-    "DROP INDEX IF EXISTS idx_build_job_start"
+    Caqti_request.exec ~oneshot:true
+      Caqti_type.unit
+      "DROP INDEX IF EXISTS idx_build_job_start"
   in
   Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
   Db.exec rm_idx_build_job_start () >>= fun () ->

bin/migrations/m20210531.ml

@@ -4,19 +4,21 @@ let identifier = "2021-05-31"
 let migrate_doc = "remove datadir prefix from build_artifact.localpath"
 let rollback_doc = "add datadir prefix to build_artifact.localpath"
 
-open Grej.Infix
-
 let build_artifacts =
-  Caqti_type.unit ->* Caqti_type.t2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath @@
-  "SELECT id, localpath FROM build_artifact"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.(tup2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath)
+    "SELECT id, localpath FROM build_artifact"
 
 let build_artifact_update_localpath =
-  Caqti_type.t2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath ->. Caqti_type.unit @@
-    "UPDATE build_artifact SET localpath = $2 WHERE id = $1"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath)
+    "UPDATE build_artifact SET localpath = ?2 WHERE id = ?1"
 
 (* We are not migrating build_file because it is unused *)
 
 let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.collect_list build_artifacts () >>= fun artifacts ->
   Grej.list_iter_result (fun (id, localpath) ->
@@ -27,6 +29,7 @@ let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
   Db.exec (Grej.set_version new_version) ()
 
 let rollback datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
    Db.collect_list build_artifacts () >>= fun artifacts ->
   Grej.list_iter_result (fun (id, localpath) ->

bin/migrations/m20210602.ml

@@ -3,114 +3,117 @@ let identifier = "2021-06-02"
 let migrate_doc = "build.main_binary foreign key"
 let rollback_doc = "build.main_binary filepath"
 
-open Grej.Infix
-
 let idx_build_job_start =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
 
 let new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_kind TINYINT NOT NULL,
-       result_code INTEGER,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       job INTEGER NOT NULL,
+    Caqti_request.exec
+      Caqti_type.unit
+      {| CREATE TABLE new_build (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           uuid VARCHAR(36) NOT NULL UNIQUE,
+           start_d INTEGER NOT NULL,
+           start_ps INTEGER NOT NULL,
+           finish_d INTEGER NOT NULL,
+           finish_ps INTEGER NOT NULL,
+           result_kind TINYINT NOT NULL,
+           result_code INTEGER,
+           result_msg TEXT,
+           console BLOB NOT NULL,
+           script TEXT NOT NULL,
+           main_binary INTEGER,
+           job INTEGER NOT NULL,
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+           FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
+           FOREIGN KEY(job) REFERENCES job(id)
+         )
+      |}
 
-let old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_kind TINYINT NOT NULL,
-       result_code INTEGER,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary TEXT,
-       job INTEGER NOT NULL,
+let old_build = 
+    Caqti_request.exec
+      Caqti_type.unit
+      {| CREATE TABLE new_build (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           uuid VARCHAR(36) NOT NULL UNIQUE,
+           start_d INTEGER NOT NULL,
+           start_ps INTEGER NOT NULL,
+           finish_d INTEGER NOT NULL,
+           finish_ps INTEGER NOT NULL,
+           result_kind TINYINT NOT NULL,
+           result_code INTEGER,
+           result_msg TEXT,
+           console BLOB NOT NULL,
+           script TEXT NOT NULL,
+           main_binary TEXT,
+           job INTEGER NOT NULL,
 
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+           FOREIGN KEY(job) REFERENCES job(id)
+         )
+      |}
 
 let collect_old_build =
-  Caqti_type.unit ->*
-  Caqti_type.(t3 Builder_db.Rep.untyped_id
-                (t3 (t4 string int64 int64 int64)
-                   (t4 int64 int (option int) (option string))
-                   (t3 octets string (option string)))
-                Builder_db.Rep.untyped_id) @@
-  {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg,
-            console, script, main_binary, job
-     FROM build |}
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.(tup3 Builder_db.Rep.untyped_id
+      (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option string)))
+      Builder_db.Rep.untyped_id)
+    {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg,
+              console, script, main_binary, job
+       FROM build |}
 
 let insert_new_build =
-  Caqti_type.(t3 Builder_db.Rep.untyped_id
-                (t3 (t4 string int64 int64 int64)
-                   (t4 int64 int (option int) (option string))
-                   (t3 octets string (option Builder_db.Rep.untyped_id)))
-                Builder_db.Rep.untyped_id) ->. Caqti_type.unit @@
-  {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
-                            result_code, result_msg, console, script, main_binary, job)
-     VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |}
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup3 Builder_db.Rep.untyped_id
+      (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option Builder_db.Rep.untyped_id)))
+      Builder_db.Rep.untyped_id)
+    {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
+                              result_code, result_msg, console, script, main_binary, job)
+       VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |}
 
 let drop_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
     "DROP TABLE build"
 
 let rename_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
     "ALTER TABLE new_build RENAME TO build"
 
 let find_main_artifact_id =
-  Caqti_type.(t2 Builder_db.Rep.untyped_id string) ->!  Builder_db.Rep.untyped_id @@
-  "SELECT id FROM build_artifact WHERE build = $1 AND filepath = $2"
+  Caqti_request.find ~oneshot:true
+    Caqti_type.(tup2 Builder_db.Rep.untyped_id string)
+    Builder_db.Rep.untyped_id
+    "SELECT id FROM build_artifact WHERE build = ?1 AND filepath = ?2"
 
 let find_main_artifact_filepath =
-  Builder_db.Rep.untyped_id ->! Caqti_type.string @@
+  Caqti_request.find ~oneshot:true
+    Builder_db.Rep.untyped_id
+    Caqti_type.string
     "SELECT filepath FROM build_artifact WHERE id = ?"
 
 let collect_new_build =
-  Caqti_type.unit ->*
-  Caqti_type.(t3 Builder_db.Rep.untyped_id
-                (t3 (t4 string int64 int64 int64)
-                   (t4 int64 int (option int) (option string))
-                   (t3 octets string (option Builder_db.Rep.untyped_id)))
-                Builder_db.Rep.untyped_id) @@
-  {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg,
-            console, script, main_binary, job
-     FROM build |}
-
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.(tup3 Builder_db.Rep.untyped_id
+      (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option Builder_db.Rep.untyped_id)))
+      Builder_db.Rep.untyped_id)
+    {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg,
+              console, script, main_binary, job
+       FROM build |}
+  
 let insert_old_build =
-  Caqti_type.(t3 Builder_db.Rep.untyped_id
-                (t3 (t4 string int64 int64 int64)
-                   (t4 int64 int (option int) (option string))
-                   (t3 octets string (option string)))
-                Builder_db.Rep.untyped_id) ->. Caqti_type.unit @@
-  {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
-                            result_code, result_msg, console, script, main_binary, job)
-     VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |}
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup3 Builder_db.Rep.untyped_id
+      (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option string)))
+      Builder_db.Rep.untyped_id)
+    {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
+                              result_code, result_msg, console, script, main_binary, job)
+       VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |}
 
 let migrate _ (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec new_build () >>= fun () ->
   Db.rev_collect_list collect_old_build () >>= fun builds ->
@@ -121,15 +124,16 @@ let migrate _ (module Db : Caqti_blocking.CONNECTION) =
          | Some path -> Db.find find_main_artifact_id (id, path) >>| fun id -> Some id)
        >>= fun main_binary_id ->
        Db.exec insert_new_build
-         (id, ((uuid, start_d, start_ps, finish_d), (finish_ps, result_kind, result_code, result_msg), (console, script, main_binary_id)), job))
+         (id, ((uuid, start_d, start_ps, finish_d), (finish_ps, result_kind, result_code, result_msg), (console, script, main_binary_id)), job)) 
     builds >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
   Db.exec idx_build_job_start () >>= fun () ->
   Db.exec (Grej.set_version new_version) ()
 
-
+ 
 let rollback _ (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
   Db.exec old_build () >>= fun () ->
   Db.rev_collect_list collect_new_build () >>= fun builds ->
@@ -140,7 +144,7 @@ let rollback _ (module Db : Caqti_blocking.CONNECTION) =
          | Some main_binary_id -> Db.find find_main_artifact_filepath main_binary_id >>| fun filepath -> Some filepath)
        >>= fun filepath ->
        Db.exec insert_old_build
-         (id, ((uuid, start_d, start_ps, finish_d), (finish_ps, result_kind, result_code, result_msg), (console, script, filepath)), job))
+         (id, ((uuid, start_d, start_ps, finish_d), (finish_ps, result_kind, result_code, result_msg), (console, script, filepath)), job)) 
     builds >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->

bin/migrations/m20210608.ml

@@ -3,79 +3,87 @@ let identifier = "2021-06-08"
 let migrate_doc = "add access list"
 let rollback_doc = "remove access list"
 
-open Grej.Infix
-
 let new_user =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_user (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       username VARCHAR(255) NOT NULL UNIQUE,
-       password_hash BLOB NOT NULL,
-       password_salt BLOB NOT NULL,
-       scrypt_n INTEGER NOT NULL,
-       scrypt_r INTEGER NOT NULL,
-       scrypt_p INTEGER NOT NULL,
-       restricted BOOLEAN NOT NULL
-     )
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_user (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         username VARCHAR(255) NOT NULL UNIQUE,
+         password_hash BLOB NOT NULL,
+         password_salt BLOB NOT NULL,
+         scrypt_n INTEGER NOT NULL,
+         scrypt_r INTEGER NOT NULL,
+         scrypt_p INTEGER NOT NULL,
+         restricted BOOLEAN NOT NULL
+       )
+    |}
 
 let old_user =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_user (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       username VARCHAR(255) NOT NULL UNIQUE,
-       password_hash BLOB NOT NULL,
-       password_salt BLOB NOT NULL,
-       scrypt_n INTEGER NOT NULL,
-       scrypt_r INTEGER NOT NULL,
-       scrypt_p INTEGER NOT NULL
-     )
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_user (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         username VARCHAR(255) NOT NULL UNIQUE,
+         password_hash BLOB NOT NULL,
+         password_salt BLOB NOT NULL,
+         scrypt_n INTEGER NOT NULL,
+         scrypt_r INTEGER NOT NULL,
+         scrypt_p INTEGER NOT NULL
+       )
+    |}
 
 let collect_old_user =
-  Caqti_type.unit ->*
-  Caqti_type.(t4 int64 string (t2 octets octets) (t3 int64 int64 int64)) @@
-  "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p FROM user"
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64))
+    "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p FROM user"
 
 let collect_new_user =
-  Caqti_type.unit ->*
-  Caqti_type.(t4 int64 string (t2 octets octets) (t4 int64 int64 int64 bool)) @@
-  "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted FROM user"
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool))
+    "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted FROM user"
 
 let insert_new_user =
-  Caqti_type.(t4 int64 string (t2 octets octets) (t4 int64 int64 int64 bool)) ->.
-  Caqti_type.unit @@
-  "INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
+  Caqti_request.exec
+    Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool))
+    "INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
 
 let insert_old_user =
-  Caqti_type.(t4 int64 string (t2 octets octets) (t3 int64 int64 int64)) ->.
-  Caqti_type.unit @@
-  "INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p) VALUES (?, ?, ?, ?, ?, ?, ?)"
+  Caqti_request.exec
+    Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64))
+    "INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p) VALUES (?, ?, ?, ?, ?, ?, ?)"
 
 let drop_user =
-  Caqti_type.unit ->. Caqti_type.unit @@
+  Caqti_request.exec
+    Caqti_type.unit
     "DROP TABLE user"
 
 let rename_new_user =
-  Caqti_type.unit ->. Caqti_type.unit @@
+  Caqti_request.exec
+    Caqti_type.unit
     "ALTER TABLE new_user RENAME TO user"
 
 let access_list =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE access_list (
-         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-         user INTEGER NOT NULL,
-         job INTEGER NOT NULL,
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE access_list (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           user INTEGER NOT NULL,
+           job INTEGER NOT NULL,
 
-         FOREIGN KEY(user) REFERENCES user(id),
-         FOREIGN KEY(job) REFERENCES job(id),
-         UNIQUE(user, job)
-       )
-  |}
+           FOREIGN KEY(user) REFERENCES user(id),
+           FOREIGN KEY(job) REFERENCES job(id),
+           UNIQUE(user, job)
+         )
+    |}
 
 let rollback_access_list =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE IF EXISTS access_list"
+ Caqti_request.exec
+   Caqti_type.unit
+   "DROP TABLE IF EXISTS access_list"
+
+open Grej.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

bin/migrations/m20210609.ml

@@ -3,92 +3,100 @@ let identifier = "2021-06-09"
 let migrate_doc = "add user column to build"
 let rollback_doc = "remove user column from build"
 
-open Grej.Infix
-
 let idx_build_job_start =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
 
 let nologin_user =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "INSERT INTO user (username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) \
-   VALUES ('nologin', x'', x'', 16384, 8, 1, true)"
+  Caqti_request.exec
+    Caqti_type.unit
+    "INSERT INTO user (username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) \
+     VALUES ('nologin', x'', x'', 16384, 8, 1, true)"
 
 let remove_nologin_user =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DELETE FROM user WHERE username = 'nologin'"
+  Caqti_request.exec
+    Caqti_type.unit
+    "DELETE FROM user WHERE username = 'nologin'"
 
 let new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_kind TINYINT NOT NULL,
-       result_code INTEGER,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_kind TINYINT NOT NULL,
+         result_code INTEGER,
+         result_msg TEXT,
+         console BLOB NOT NULL,
+         script TEXT NOT NULL,
+         main_binary INTEGER,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
-       FOREIGN KEY(job) REFERENCES job(id),
-       FOREIGN KEY(user) REFERENCES user(id)
-     )
-  |}
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
+         FOREIGN KEY(job) REFERENCES job(id),
+         FOREIGN KEY(user) REFERENCES user(id)
+       )
+    |}
 
 let old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_kind TINYINT NOT NULL,
-       result_code INTEGER,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       job INTEGER NOT NULL,
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_kind TINYINT NOT NULL,
+         result_code INTEGER,
+         result_msg TEXT,
+         console BLOB NOT NULL,
+         script TEXT NOT NULL,
+         main_binary INTEGER,
+         job INTEGER NOT NULL,
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
 
 let insert_from_old_build =
-  Builder_db.Rep.id (`user : [`user]) ->. Caqti_type.unit @@
-  {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps,
-                            result_kind, result_code, result_msg, console,
-                            script, main_binary, job, user)
-     SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
-       result_code, result_msg, console, script, main_binary, job, ?
-     FROM build |}
+  Caqti_request.exec ~oneshot:true
+    (Builder_db.Rep.id (`user : [`user]))
+    {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps,
+                              result_kind, result_code, result_msg, console,
+                              script, main_binary, job, user)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
+         result_code, result_msg, console, script, main_binary, job, ?
+       FROM build |}
 
 let insert_from_new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps,
-                            result_kind, result_code, result_msg, console,
-                            script, main_binary, job)
-     SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
-       result_code, result_msg, console, script, main_binary, job
-     FROM build |}
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps,
+                              result_kind, result_code, result_msg, console,
+                              script, main_binary, job)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
+         result_code, result_msg, console, script, main_binary, job
+       FROM build |}
 
 let drop_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE build"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "DROP TABLE build"
 
 let rename_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE new_build RENAME TO build"
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "ALTER TABLE new_build RENAME TO build"
+
+open Grej.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

bin/migrations/m20210625.ml

@@ -3,26 +3,28 @@ let identifier = "2021-06-25"
 let migrate_doc = "drop build_file table"
 let rollback_doc = "recreate build_file table"
 
-open Grej.Infix
-
 let build_file =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE build_file (
-         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-         filepath TEXT NOT NULL, -- the path as in the build
-         localpath TEXT NOT NULL, -- local path to the file on disk
-         sha256 BLOB NOT NULL,
-         size INTEGER NOT NULL,
-         build INTEGER NOT NULL,
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE build_file (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           filepath TEXT NOT NULL, -- the path as in the build
+           localpath TEXT NOT NULL, -- local path to the file on disk
+           sha256 BLOB NOT NULL,
+           size INTEGER NOT NULL,
+           build INTEGER NOT NULL,
 
-         FOREIGN KEY(build) REFERENCES build(id),
-         UNIQUE(build, filepath)
-       )
-  |}
+           FOREIGN KEY(build) REFERENCES build(id),
+           UNIQUE(build, filepath)
+         )
+      |}
 
 let drop_build_file =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE build_file"
+  Caqti_request.exec
+    Caqti_type.unit
+    "DROP TABLE build_file"
+
+open Grej.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

bin/migrations/m20210629.ml

@@ -3,50 +3,55 @@ let identifier = "2021-06-29"
 let migrate_doc = "add tag and job_tag table"
 let rollback_doc = "remove tag and job tag table"
 
-open Grej.Infix
-
 let tag =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE tag (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       tag VARCHAR(255) NOT NULL UNIQUE
-     )
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE tag (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         tag VARCHAR(255) NOT NULL UNIQUE
+       )
+    |}
 
 let job_tag =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE job_tag (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       tag INTEGER NOT NULL,
-       value TEXT NOT NULL,
-       job INTEGER NOT NULL,
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE job_tag (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         tag INTEGER NOT NULL,
+         value TEXT NOT NULL,
+         job INTEGER NOT NULL,
 
-       FOREIGN KEY(job) REFERENCES job(id),
-       FOREIGN KEY(tag) REFERENCES tag(id),
-       UNIQUE(tag, job)
-     )
-  |}
+         FOREIGN KEY(job) REFERENCES job(id),
+         FOREIGN KEY(tag) REFERENCES tag(id),
+         UNIQUE(tag, job)
+       )
+     |}
 
 let jobs =
-  Caqti_type.unit ->* Builder_db.Rep.untyped_id @@
-  "SELECT id FROM job"
+  Caqti_request.collect
+    Caqti_type.unit
+    Builder_db.Rep.untyped_id
+    "SELECT id FROM job"
 
 let latest_successful_build =
-  Builder_db.Rep.untyped_id ->? Builder_db.Rep.untyped_id @@
-  {| SELECT b.id
-     FROM build b
-     WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0
-     ORDER BY b.start_d DESC, b.start_ps DESC
-     LIMIT 1
-  |}
+  Caqti_request.find_opt
+    Builder_db.Rep.untyped_id
+    Builder_db.Rep.untyped_id
+    {| SELECT b.id
+       FROM build b
+       WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0
+       ORDER BY b.start_d DESC, b.start_ps DESC
+       LIMIT 1
+    |}
 
 let build_artifacts =
-  Builder_db.Rep.untyped_id ->*
-  Caqti_type.t2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@
-  {| SELECT a.filepath, a.localpath
-     FROM build_artifact a
-     WHERE a.build = ?
-  |}
+  Caqti_request.collect
+    Builder_db.Rep.untyped_id
+    Caqti_type.(tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    {| SELECT a.filepath, a.localpath
+       FROM build_artifact a
+       WHERE a.build = ?
+    |}
 
 
 let infer_section_and_synopsis artifacts =
@@ -92,27 +97,34 @@ let infer_section_and_synopsis artifacts =
       | None -> infer_section_from_packages opam_switch
     in
     Some section, infer_synopsis_and_descr opam_switch
-
+ 
 let remove_tag =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE tag"
+  Caqti_request.exec
+    Caqti_type.unit
+    "DROP TABLE tag"
 
 let remove_job_tag =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE job_tag"
+  Caqti_request.exec
+    Caqti_type.unit
+    "DROP TABLE job_tag"
 
 let insert_tag =
-  Caqti_type.string ->. Caqti_type.unit @@
-  "INSERT INTO tag (tag) VALUES (?)"
+   Caqti_request.exec
+     Caqti_type.string
+     "INSERT INTO tag (tag) VALUES (?)"
 
 let insert_job_tag =
-  Caqti_type.(t3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id) ->.
-  Caqti_type.unit @@
-  "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"
+   Caqti_request.exec
+     Caqti_type.(tup3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id)
+     "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"
 
 let find_tag =
-  Caqti_type.string ->! Builder_db.Rep.untyped_id @@
-  "SELECT id FROM tag where tag = ?"
+   Caqti_request.find
+     Caqti_type.string
+     Builder_db.Rep.untyped_id
+     "SELECT id FROM tag where tag = ?"
+
+open Grej.Infix
 
 let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

bin/migrations/m20210630.ml

@@ -3,49 +3,59 @@ let identifier = "2021-06-30"
 let migrate_doc = "add readme.md tag"
 let rollback_doc = "remove readme.md tag"
 
-open Grej.Infix
-
 let jobs =
-  Caqti_type.unit ->* Builder_db.Rep.untyped_id @@
-  "SELECT id FROM job"
+  Caqti_request.collect
+    Caqti_type.unit
+    Builder_db.Rep.untyped_id
+    "SELECT id FROM job"
 
 let latest_successful_build =
-  Builder_db.Rep.untyped_id ->? Builder_db.Rep.untyped_id @@
-  {| SELECT b.id
-     FROM build b
-     WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0
-     ORDER BY b.start_d DESC, b.start_ps DESC
-     LIMIT 1
-  |}
+  Caqti_request.find_opt
+    Builder_db.Rep.untyped_id
+    Builder_db.Rep.untyped_id
+    {| SELECT b.id
+       FROM build b
+       WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0
+       ORDER BY b.start_d DESC, b.start_ps DESC
+       LIMIT 1
+    |}
 
 let build_artifacts =
-  Builder_db.Rep.untyped_id ->*
-  Caqti_type.t2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@
-  {| SELECT a.filepath, a.localpath
-     FROM build_artifact a
-     WHERE a.build = ?
-  |}
+  Caqti_request.collect
+    Builder_db.Rep.untyped_id
+    Caqti_type.(tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    {| SELECT a.filepath, a.localpath
+       FROM build_artifact a
+       WHERE a.build = ?
+    |}
 
 let insert_tag =
-  Caqti_type.string ->. Caqti_type.unit @@
-  "INSERT INTO tag (tag) VALUES (?)"
+   Caqti_request.exec
+     Caqti_type.string
+     "INSERT INTO tag (tag) VALUES (?)"
 
 let insert_job_tag =
-  Caqti_type.(t3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id) ->.
-  Caqti_type.unit @@
-  "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"
+   Caqti_request.exec
+     Caqti_type.(tup3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id)
+     "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"
 
 let find_tag =
-  Caqti_type.string ->! Builder_db.Rep.untyped_id @@
-  "SELECT id FROM tag where tag = ?"
+   Caqti_request.find
+     Caqti_type.string
+     Builder_db.Rep.untyped_id
+     "SELECT id FROM tag where tag = ?"
 
 let remove_job_tag =
-  Builder_db.Rep.untyped_id ->. Caqti_type.unit @@
-  "DELETE FROM job_tag where tag = ?"
+   Caqti_request.exec
+     Builder_db.Rep.untyped_id
+     "DELETE FROM job_tag where tag = ?"
 
 let remove_tag =
-  Builder_db.Rep.untyped_id ->. Caqti_type.unit @@
-  "DELETE FROM tag where id = ?"
+   Caqti_request.exec
+     Builder_db.Rep.untyped_id
+     "DELETE FROM tag where id = ?"
+
+open Grej.Infix
 
 let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

bin/migrations/m20210701.ml

@@ -3,71 +3,76 @@ let identifier = "2021-07-01"
 let migrate_doc = "build.main_binary deferred foreign key constraint"
 let rollback_doc = "build.main_binary immediate foreign key constraint"
 
-open Grej.Infix
-
 let idx_build_job_start =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
 
 let new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_kind TINYINT NOT NULL,
-       result_code INTEGER,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
+    Caqti_request.exec
+      Caqti_type.unit
+      {| CREATE TABLE new_build (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           uuid VARCHAR(36) NOT NULL UNIQUE,
+           start_d INTEGER NOT NULL,
+           start_ps INTEGER NOT NULL,
+           finish_d INTEGER NOT NULL,
+           finish_ps INTEGER NOT NULL,
+           result_kind TINYINT NOT NULL,
+           result_code INTEGER,
+           result_msg TEXT,
+           console BLOB NOT NULL,
+           script TEXT NOT NULL,
+           main_binary INTEGER,
+           user INTEGER NOT NULL,
+           job INTEGER NOT NULL,
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
-       FOREIGN KEY(user) REFERENCES user(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+           FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+           FOREIGN KEY(user) REFERENCES user(id),
+           FOREIGN KEY(job) REFERENCES job(id)
+         )
+      |}
 
 let old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_kind TINYINT NOT NULL,
-       result_code INTEGER,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
+    Caqti_request.exec
+      Caqti_type.unit
+      {| CREATE TABLE new_build (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           uuid VARCHAR(36) NOT NULL UNIQUE,
+           start_d INTEGER NOT NULL,
+           start_ps INTEGER NOT NULL,
+           finish_d INTEGER NOT NULL,
+           finish_ps INTEGER NOT NULL,
+           result_kind TINYINT NOT NULL,
+           result_code INTEGER,
+           result_msg TEXT,
+           console BLOB NOT NULL,
+           script TEXT NOT NULL,
+           main_binary INTEGER,
+           user INTEGER NOT NULL,
+           job INTEGER NOT NULL,
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
-       FOREIGN KEY(user) REFERENCES user(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+           FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
+           FOREIGN KEY(user) REFERENCES user(id),
+           FOREIGN KEY(job) REFERENCES job(id)
+         )
+      |}
 
 let copy_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "INSERT INTO new_build SELECT * from build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "INSERT INTO new_build SELECT * from build"
 
 let drop_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "DROP TABLE build"
 
 let rename_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE new_build RENAME TO build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "ALTER TABLE new_build RENAME TO build"
+
+open Grej.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

bin/migrations/m20210706.ml

@@ -3,80 +3,88 @@ let identifier = "2021-07-06"
 let migrate_doc = "add a input_id column to the build table"
 let rollback_doc = "remove the input_id column from the build table"
 
-open Grej.Infix
-
 let add_input_id_to_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE build ADD COLUMN input_id BLOB"
+    Caqti_request.exec
+      Caqti_type.unit
+      {| ALTER TABLE build ADD COLUMN input_id BLOB |}
 
 let idx_build_job_start =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
 
 let old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_kind TINYINT NOT NULL,
-       result_code INTEGER,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
+    Caqti_request.exec
+      Caqti_type.unit
+      {| CREATE TABLE new_build (
+           id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+           uuid VARCHAR(36) NOT NULL UNIQUE,
+           start_d INTEGER NOT NULL,
+           start_ps INTEGER NOT NULL,
+           finish_d INTEGER NOT NULL,
+           finish_ps INTEGER NOT NULL,
+           result_kind TINYINT NOT NULL,
+           result_code INTEGER,
+           result_msg TEXT,
+           console BLOB NOT NULL,
+           script TEXT NOT NULL,
+           main_binary INTEGER,
+           user INTEGER NOT NULL,
+           job INTEGER NOT NULL,
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
-       FOREIGN KEY(user) REFERENCES user(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+           FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+           FOREIGN KEY(user) REFERENCES user(id),
+           FOREIGN KEY(job) REFERENCES job(id)
+         )
+      |}
 
 let copy_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "INSERT INTO new_build SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg, console, script, main_binary, user, job FROM build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "INSERT INTO new_build SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg, console, script, main_binary, user, job FROM build"
 
 let drop_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "DROP TABLE build"
 
 let rename_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE new_build RENAME TO build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "ALTER TABLE new_build RENAME TO build"
 
 let drop_input_id_from_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| ALTER TABLE build DROP COLUMN input_id |}
+    Caqti_request.exec
+      Caqti_type.unit
+      {| ALTER TABLE build DROP COLUMN input_id |}
 
 let builds =
-  Caqti_type.unit ->*
-  Caqti_type.t4
-    Builder_db.Rep.untyped_id
-    Caqti_type.octets
-    Caqti_type.octets
-    Caqti_type.octets @@
-  {| SELECT b.id, opam.sha256, env.sha256, system.sha256
-     FROM build b, build_artifact opam, build_artifact env, build_artifact system
-     WHERE opam.filepath = 'opam-switch' AND env.filepath = 'build-environment'
-       AND system.filepath = 'system-packages'
-       AND opam.build = b.id AND env.build = b.id AND system.build = b.id
-  |}
+  Caqti_request.collect
+    Caqti_type.unit
+    (Caqti_type.tup4
+       Builder_db.Rep.untyped_id
+       Builder_db.Rep.cstruct
+       Builder_db.Rep.cstruct
+       Builder_db.Rep.cstruct)
+    {| SELECT b.id, opam.sha256, env.sha256, system.sha256
+       FROM build b, build_artifact opam, build_artifact env, build_artifact system
+       WHERE opam.filepath = 'opam-switch' AND env.filepath = 'build-environment'
+         AND system.filepath = 'system-packages'
+         AND opam.build = b.id AND env.build = b.id AND system.build = b.id
+    |}
 
 let set_input_id =
-  Caqti_type.t2 Builder_db.Rep.untyped_id Caqti_type.octets ->. Caqti_type.unit @@
-  "UPDATE build SET input_id = $2 WHERE id = $1"
+  Caqti_request.exec
+    (Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.cstruct)
+    "UPDATE build SET input_id = ?2 WHERE id = ?1"
+
+open Grej.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec add_input_id_to_build () >>= fun () ->
   Db.collect_list builds () >>= fun builds ->
   Grej.list_iter_result (fun (id, opam_sha, env_sha, pkg_sha) ->
-     let input_id = Digestif.SHA256.(to_raw_string (digestv_string [ opam_sha ; env_sha ; pkg_sha ])) in
+     let input_id = Mirage_crypto.Hash.SHA256.digest (Cstruct.concat [ opam_sha ; env_sha ; pkg_sha ]) in
      Db.exec set_input_id (id, input_id))
     builds >>= fun () ->
   Db.exec (Grej.set_version new_version) ()

bin/migrations/m20210707a.ml

@@ -1,13 +1,13 @@
-open Grej.Infix
-
 let orb_left_in_builds =
-  Caqti_type.unit ->*
-  Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
-  {| SELECT id, localpath FROM build_artifact
-     WHERE filepath = 'orb.deb' OR filepath = 'orb.txz'
-  |}
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    (Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath)
+    {| SELECT id, localpath FROM build_artifact
+       WHERE filepath = 'orb.deb' OR filepath = 'orb.txz'
+    |}
 
 let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:12L (module Db) >>= fun () ->
   Db.rev_collect_list orb_left_in_builds () >>= fun leftover_orb ->
   Grej.list_iter_result

bin/migrations/m20210707b.ml

@@ -1,28 +1,30 @@
-open Grej.Infix
-
 let deb_debug_left_in_builds =
-  Caqti_type.unit ->*
-  Caqti_type.t4 (Builder_db.Rep.id `build_artifact) (Builder_db.Rep.id `build)
-    Builder_db.Rep.fpath Builder_db.Rep.fpath @@
-  {| SELECT id, build, localpath, filepath FROM build_artifact
-     WHERE filepath LIKE '%.deb.debug'
-  |}
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    (Caqti_type.tup4 (Builder_db.Rep.id `build_artifact) (Builder_db.Rep.id `build) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    {| SELECT id, build, localpath, filepath FROM build_artifact
+       WHERE filepath LIKE '%.deb.debug'
+    |}
 
 let get_main_binary =
-  Builder_db.Rep.id `build ->? Builder_db.Rep.id `build_artifact @@
-  "SELECT main_binary FROM build WHERE id = ?"
+  Caqti_request.find_opt
+    (Builder_db.Rep.id `build)
+    (Builder_db.Rep.id `build_artifact)
+    "SELECT main_binary FROM build WHERE id = ?"
 
 let get_localpath =
-  Builder_db.Rep.id `build_artifact ->! Builder_db.Rep.fpath @@
-  "SELECT localpath FROM build_artifact WHERE id = ?"
+  Caqti_request.find
+    (Builder_db.Rep.id `build_artifact)
+    Builder_db.Rep.fpath
+    "SELECT localpath FROM build_artifact WHERE id = ?"
 
 let update_paths =
-  Caqti_type.t3 (Builder_db.Rep.id `build_artifact)
-    Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
-  Caqti_type.unit @@
-  "UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1"
+  Caqti_request.exec
+    (Caqti_type.tup3 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    "UPDATE build_artifact SET localpath = ?2, filepath = ?3 WHERE id = ?1"
 
 let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:12L (module Db) >>= fun () ->
   Db.rev_collect_list deb_debug_left_in_builds () >>= fun leftover_debug ->
   Grej.list_iter_result

bin/migrations/m20210707c.ml

@@ -1,28 +1,28 @@
-open Grej.Infix
 
 let all_builds_with_binary : (unit, [`build] Builder_db.Rep.id * [`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t =
-  Caqti_type.unit ->*
-  Caqti_type.t4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact)
-    Builder_db.Rep.fpath Builder_db.Rep.fpath @@
-  "SELECT b.id, b.main_binary, a.filepath, a.localpath FROM build b, build_artifact a WHERE b.main_binary = a.id AND b.main_binary IS NOT NULL"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    (Caqti_type.tup4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    "SELECT b.id, b.main_binary, a.filepath, a.localpath FROM build b, build_artifact a WHERE b.main_binary = a.id AND b.main_binary IS NOT NULL"
 
-let build_not_stripped : ([`build] Builder_db.Rep.id, [`build_artifact] Builder_db.Rep.id, [ `Zero | `One ]) Caqti_request.t =
-  Builder_db.Rep.id `build ->? Builder_db.Rep.id `build_artifact @@
-  "SELECT id FROM build_artifact WHERE build = ? AND filepath LIKE '%.debug'"
+let build_not_stripped : ([`build] Builder_db.Rep.id, [`build_artifact] Builder_db.Rep.id, [< `Zero | `One | `Many > `Zero `One ]) Caqti_request.t =
+  Caqti_request.find_opt
+    (Builder_db.Rep.id `build)
+    (Builder_db.Rep.id `build_artifact)
+    {| SELECT id FROM build_artifact WHERE build = ? AND filepath LIKE '%.debug' |}
 
-let update_paths : ([`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, unit, [ `Zero ]) Caqti_request.t =
-  Caqti_type.t3 (Builder_db.Rep.id `build_artifact)
-    Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
-  Caqti_type.unit @@
-  "UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1"
+let update_paths : ([`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, unit, [< `Zero | `One | `Many > `Zero ]) Caqti_request.t =
+  Caqti_request.exec
+    (Caqti_type.tup3 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    "UPDATE build_artifact SET localpath = ?2, filepath = ?3 WHERE id = ?1"
 
-let add_artifact : ((Fpath.t * Fpath.t * string) * (int64 * [`build] Builder_db.Rep.id), unit, [ `Zero]) Caqti_request.t =
-  Caqti_type.(t2 (t3 Builder_db.Rep.fpath Builder_db.Rep.fpath Caqti_type.octets)
-                (t2 Caqti_type.int64 (Builder_db.Rep.id `build))) ->.
-  Caqti_type.unit @@
-  "INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?)"
+let add_artifact : ((Fpath.t * Fpath.t * Cstruct.t) * (int64 * [`build] Builder_db.Rep.id), unit, [< `Zero | `One | `Many > `Zero]) Caqti_request.t =
+  Caqti_request.exec
+    Caqti_type.(tup2 (tup3 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct) (tup2 Caqti_type.int64 (Builder_db.Rep.id `build)))
+    {| INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?) |}
 
 let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:12L (module Db) >>= fun () ->
   Db.rev_collect_list all_builds_with_binary () >>= fun builds ->
   Grej.list_iter_result
@@ -48,8 +48,7 @@ let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
            in
            assert (r = 0);
            Bos.OS.File.read (Fpath.append datadir artifact_lpath) >>= fun data ->
-           let size = Int64.of_int (String.length data)
-           and sha256 = Digestif.SHA256.(to_raw_string (digest_string data)) in
+           let size = Int64.of_int (String.length data) and sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
            Db.exec update_paths (artifact_id, new_artifact_lpath, path artifact_fpath) >>= fun () ->
            Db.exec add_artifact ((artifact_fpath, artifact_lpath, sha256), (size, build_id)) >>= fun () ->
            Db.find Builder_db.last_insert_rowid () >>= fun new_build_artifact_id ->

bin/migrations/m20210707d.ml

@@ -1,16 +1,17 @@
-open Grej.Infix
 
 let all_build_artifacts_with_dot_slash : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t =
-  Caqti_type.unit ->*
-  Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
-  "SELECT id, filepath FROM build_artifact WHERE filepath LIKE './%'"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    (Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath)
+    "SELECT id, filepath FROM build_artifact WHERE filepath LIKE './%'"
 
 let update_path : ([`build_artifact] Builder_db.Rep.id * Fpath.t, unit, [< `Zero | `One | `Many > `Zero ]) Caqti_request.t =
-  Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath ->.
-  Caqti_type.unit @@
-  "UPDATE build_artifact SET filepath = $2 WHERE id = $1"
+  Caqti_request.exec
+    (Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath)
+    "UPDATE build_artifact SET filepath = ?2 WHERE id = ?1"
 
 let fixup _datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:12L (module Db) >>= fun () ->
   Db.rev_collect_list all_build_artifacts_with_dot_slash () >>= fun build_artifacts ->
   Grej.list_iter_result

bin/migrations/m20210712a.ml

@@ -3,101 +3,108 @@ and identifier = "2021-07-12a"
 and migrate_doc = "remove result_kind from build, add indexes idx_build_failed and idx_build_artifact_sha256"
 and rollback_doc = "add result_kind to build, remove indexes idx_build_failed and idx_build_artifact_sha256"
 
-open Grej.Infix
-
 let new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_code INTEGER NOT NULL,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
-       input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_code INTEGER NOT NULL,
+         result_msg TEXT,
+         console BLOB NOT NULL,
+         script TEXT NOT NULL,
+         main_binary INTEGER,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
+         input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
-       FOREIGN KEY(user) REFERENCES user(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+         FOREIGN KEY(user) REFERENCES user(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
 
 let copy_old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
-       result_code, result_msg, console, script, main_binary, user, job, input_id)
-     SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg,
-       console, script, main_binary, user, job, input_id
-     FROM build
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_code, result_msg, console, script, main_binary, user, job, input_id)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg,
+         console, script, main_binary, user, job, input_id
+       FROM build
+    |}
 
 let old_build_execution_result =
-  Caqti_type.unit ->*
-  Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) @@
-  "SELECT id, result_kind, result_code FROM build"
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int))
+    "SELECT id, result_kind, result_code FROM build"
 
 let update_new_build_execution_result =
-  Caqti_type.(t2 (Builder_db.Rep.id (`build : [ `build ])) int) ->. Caqti_type.unit @@
-  "UPDATE new_build SET result_code = $2 WHERE id = $1"
+  Caqti_request.exec
+    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int)
+    "UPDATE new_build SET result_code = ?2 WHERE id = ?1"
 
 let old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_kind INTEGER NOT NULL,
-       result_code INTEGER,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
-       input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_kind INTEGER NOT NULL,
+         result_code INTEGER,
+         result_msg TEXT,
+         console BLOB NOT NULL,
+         script TEXT NOT NULL,
+         main_binary INTEGER,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
+         input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
-       FOREIGN KEY(user) REFERENCES user(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+         FOREIGN KEY(user) REFERENCES user(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
 
 let copy_new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
-       result_kind, result_msg, console, script, main_binary, user, job, input_id)
-     SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg,
-       console, script, main_binary, user, job, input_id
-     FROM build
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_kind, result_msg, console, script, main_binary, user, job, input_id)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg,
+         console, script, main_binary, user, job, input_id
+       FROM build
+    |}
 
 let new_build_execution_result =
-  Caqti_type.unit ->*
-  Caqti_type.(t2 (Builder_db.Rep.id (`build : [ `build ])) int) @@
-  "SELECT id, result_code FROM build"
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int)
+    "SELECT id, result_code FROM build"
 
 let update_old_build_execution_result =
-  Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) ->.
-  Caqti_type.unit @@
-  "UPDATE new_build SET result_kind = $2, result_code = $3 WHERE id = $1"
+  Caqti_request.exec
+    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int))
+    "UPDATE new_build SET result_kind = ?2, result_code = ?3 WHERE id = ?1"
 
 let drop_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "DROP TABLE build"
 
 let rename_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE new_build RENAME TO build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "ALTER TABLE new_build RENAME TO build"
 
 let execution_new_of_old kind code =
   match kind, code with
@@ -119,6 +126,7 @@ let execution_old_of_new code =
   else Error (`Msg "bad encoding")
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec new_build () >>= fun () ->
   Db.exec copy_old_build () >>= fun () ->
@@ -129,25 +137,25 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
     results >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
-            WHERE result_code <> 0")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_input_id ON build(input_id)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_input_id ON build(input_id)")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_main_binary ON build(main_binary)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_main_binary ON build(main_binary)")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_artifact_sha256 ON build_artifact(sha256)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_artifact_sha256 ON build_artifact(sha256)")
     () >>= fun () ->
   Db.exec (Grej.set_version new_version) ()
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
   Db.exec old_build () >>= fun () ->
   Db.exec copy_new_build () >>= fun () ->
@@ -158,9 +166,8 @@ let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
     results >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "DROP INDEX idx_build_artifact_sha256") () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+  Db.exec (Caqti_request.exec Caqti_type.unit "DROP INDEX idx_build_artifact_sha256") () >>= fun () ->
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
     () >>= fun () ->
   Db.exec (Grej.set_version old_version) ()

bin/migrations/m20210712b.ml

@@ -1,16 +1,18 @@
-open Grej.Infix
 
 let all_build_artifacts_like_hashes : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t =
-  Caqti_type.unit ->*
-  Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
-  "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%.build-hashes'"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    (Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath)
+    "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%.build-hashes'"
 
 let all_build_artifacts_like_readme : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t =
-  Caqti_type.unit ->*
-  Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
-  "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%README.md'"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    (Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath)
+    "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%README.md'"
 
 let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:13L (module Db) >>= fun () ->
   Db.rev_collect_list all_build_artifacts_like_hashes () >>= fun build_artifacts_build_hashes ->
   Db.rev_collect_list all_build_artifacts_like_readme () >>= fun build_artifacts_readme ->

bin/migrations/m20210712c.ml

@@ -8,8 +8,8 @@ open Grej.Infix
 module Asn = struct
   let decode_strict codec cs =
     match Asn.decode codec cs with
-    | Ok (a, rest) ->
-      if String.length rest = 0
+    | Ok (a, cs) ->
+      if Cstruct.length cs = 0
       then Ok a
       else Error "trailing bytes"
     | Error (`Parse msg) -> Error ("parse error: " ^ msg)
@@ -28,101 +28,107 @@ module Asn = struct
 end
 
 let new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_code INTEGER NOT NULL,
-       result_msg TEXT,
-       console TEXT NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
-       input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_code INTEGER NOT NULL,
+         result_msg TEXT,
+         console TEXT NOT NULL,
+         script TEXT NOT NULL,
+         main_binary INTEGER,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
+         input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
-       FOREIGN KEY(user) REFERENCES user(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+         FOREIGN KEY(user) REFERENCES user(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
 
 let old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_code INTEGER NOT NULL,
-       result_msg TEXT,
-       console BLOB NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
-       input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_code INTEGER NOT NULL,
+         result_msg TEXT,
+         console BLOB NOT NULL,
+         script TEXT NOT NULL,
+         main_binary INTEGER,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
+         input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
-       FOREIGN KEY(user) REFERENCES user(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+         FOREIGN KEY(user) REFERENCES user(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
 
 let copy_from_old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
-       result_code, result_msg, console, script, main_binary, user, job, input_id)
-     SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg,
-       '', '', main_binary, user, job, input_id
-     FROM build
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_code, result_msg, console, script, main_binary, user, job, input_id)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg,
+         '', '', main_binary, user, job, input_id
+       FROM build
+    |}
 
 let copy_from_new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
-       result_code, result_msg, console, script, main_binary, user, job, input_id)
-     SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg,
-       x'', '', main_binary, user, job, input_id
-     FROM build
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_code, result_msg, console, script, main_binary, user, job, input_id)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg,
+         x'', '', main_binary, user, job, input_id
+       FROM build
+    |}
 
 let old_build_console_script =
-  Caqti_type.unit ->*
-  Caqti_type.(t4 (Builder_db.Rep.id  (`build : [ `build ]))
-                (t2 string Builder_db.Rep.uuid) octets string) @@
-  "SELECT b.id, job.name, b.uuid, b.console, b.script FROM build b, job WHERE b.job = job.id"
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup4 (Builder_db.Rep.id  (`build : [ `build ]))
+                  (tup2 string Builder_db.Rep.uuid) Builder_db.Rep.cstruct string)
+    "SELECT b.id, job.name, b.uuid, b.console, b.script FROM build b, job WHERE b.job = job.id"
 
 let update_new_build_console_script =
-  Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ]))
-                Builder_db.Rep.fpath Builder_db.Rep.fpath) ->.
-  Caqti_type.unit @@
-  "UPDATE new_build SET console = $2, script = $3 WHERE id = $1"
+  Caqti_request.exec
+    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    "UPDATE new_build SET console = ?2, script = ?3 WHERE id = ?1"
 
 let new_build_console_script =
-  Caqti_type.unit ->*
-  Caqti_type.t3 (Builder_db.Rep.id (`build : [ `build ]))
-    Builder_db.Rep.fpath Builder_db.Rep.fpath @@
-  "SELECT id, console, script FROM build"
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    "SELECT id, console, script FROM build"
 
 let update_old_build_console_script =
-  Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ])) octets string) ->.
-  Caqti_type.unit @@
-  "UPDATE new_build SET console = $2, script = $3 WHERE id = $1"
+  Caqti_request.exec
+    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.cstruct string)
+    "UPDATE new_build SET console = ?2, script = ?3 WHERE id = ?1"
 
 let drop_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "DROP TABLE build"
 
 let rename_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE new_build RENAME TO build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "ALTER TABLE new_build RENAME TO build"
 
 let console_to_string console =
   Asn.console_of_cs console
@@ -181,18 +187,17 @@ let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
     console_scripts >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
-            WHERE result_code <> 0")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_input_id ON build(input_id)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_input_id ON build(input_id)")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_main_binary ON build(main_binary)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_main_binary ON build(main_binary)")
     () >>= fun () ->
   Db.exec (Grej.set_version new_version) ()
 
@@ -207,17 +212,16 @@ let rollback datadir (module Db : Caqti_blocking.CONNECTION) =
     console_scripts >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
-            WHERE result_code <> 0")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_input_id ON build(input_id)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_input_id ON build(input_id)")
     () >>= fun () ->
-  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-           "CREATE INDEX idx_build_main_binary ON build(main_binary)")
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_main_binary ON build(main_binary)")
     () >>= fun () ->
   Db.exec (Grej.set_version old_version) ()

bin/migrations/m20210910.ml

@@ -1,19 +1,16 @@
-open Grej.Infix
-
 let mixups =
-  Caqti_type.unit ->*
-  Caqti_type.t3 (Builder_db.Rep.id (`build : [`build]))
-    Builder_db.Rep.fpath Builder_db.Rep.fpath @@
-  "SELECT id, console, script FROM build \
-   WHERE console LIKE '%/script.txt' AND script LIKE '%/console.txt'"
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    (Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+"SELECT id, console, script FROM build WHERE console LIKE '%/script.txt' AND script LIKE '%/console.txt'"
 
 let fixup =
-  Caqti_type.t3 (Builder_db.Rep.id (`build : [`build]))
-    Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
-  Caqti_type.unit @@
-  "UPDATE build SET console = $2, script = $3 WHERE id = $1"
+  Caqti_request.exec ~oneshot:true
+    (Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    "UPDATE build SET console = ?2, script = ?3 WHERE id = ?1"
 
 let fixup _datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Grej.Infix in
   Grej.check_version ~user_version:14L (module Db) >>= fun () ->
   Db.collect_list mixups () >>= fun mixups ->
   Grej.list_iter_result (fun (id, console, script) ->

bin/migrations/m20211105.ml

@@ -6,87 +6,96 @@ and rollback_doc = "remove platform from build"
 open Grej.Syntax
 
 let new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_code INTEGER NOT NULL,
-       result_msg TEXT,
-       console TEXT NOT NULL,
-       script TEXT NOT NULL,
-       platform TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
-       input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_code INTEGER NOT NULL,
+         result_msg TEXT,
+         console TEXT NOT NULL,
+         script TEXT NOT NULL,
+         platform TEXT NOT NULL,
+         main_binary INTEGER,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
+         input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
-       FOREIGN KEY(user) REFERENCES user(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+         FOREIGN KEY(user) REFERENCES user(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
 
 let old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build (
-       id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       uuid VARCHAR(36) NOT NULL UNIQUE,
-       start_d INTEGER NOT NULL,
-       start_ps INTEGER NOT NULL,
-       finish_d INTEGER NOT NULL,
-       finish_ps INTEGER NOT NULL,
-       result_code INTEGER NOT NULL,
-       result_msg TEXT,
-       console TEXT NOT NULL,
-       script TEXT NOT NULL,
-       main_binary INTEGER,
-       user INTEGER NOT NULL,
-       job INTEGER NOT NULL,
-       input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE new_build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_code INTEGER NOT NULL,
+         result_msg TEXT,
+         console TEXT NOT NULL,
+         script TEXT NOT NULL,
+         main_binary INTEGER,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
+         input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
 
-       FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
-       FOREIGN KEY(user) REFERENCES user(id),
-       FOREIGN KEY(job) REFERENCES job(id)
-     )
-  |}
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+         FOREIGN KEY(user) REFERENCES user(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
 
 let copy_from_old_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
-       result_code, result_msg, console, script, platform, main_binary, user, job, input_id)
-     SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg,
-       console, script, 'PLACEHOLDER-PLATFORM', main_binary, user, job, input_id
-     FROM build
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_code, result_msg, console, script, platform, main_binary, user, job, input_id)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg,
+         console, script, 'PLACEHOLDER-PLATFORM', main_binary, user, job, input_id
+       FROM build
+    |}
 
 let copy_from_new_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
-       result_code, result_msg, console, script, main_binary, user, job, input_id)
-     SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg,
-       console, script, main_binary, user, job, input_id
-     FROM build
-  |}
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_code, result_msg, console, script, main_binary, user, job, input_id)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg,
+         console, script, main_binary, user, job, input_id
+       FROM build
+    |}
 
 let build_id_and_user =
-  Caqti_type.unit ->* Caqti_type.(t2 (Builder_db.Rep.id (`build : [ `build ])) int64) @@
-  "SELECT id, user FROM build"
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int64)
+    "SELECT id, user FROM build"
 
 let update_new_build_platform =
-  Caqti_type.(t2 (Builder_db.Rep.id (`build : [ `build ])) string) ->. Caqti_type.unit @@
-  "UPDATE new_build SET platform = $2 WHERE id = $1"
+  Caqti_request.exec
+    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) string)
+    "UPDATE new_build SET platform = ?2 WHERE id = ?1"
 
 let drop_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "DROP TABLE build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "DROP TABLE build"
 
 let rename_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "ALTER TABLE new_build RENAME TO build"
+  Caqti_request.exec
+    Caqti_type.unit
+    "ALTER TABLE new_build RENAME TO build"
 
 (*
 1|reynir
@@ -105,22 +114,6 @@ let platform_of_user_id = function
   | 7L -> "debian-11"
   | _ -> assert false
 
-let idx_build_job_start =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
-
-let idx_build_failed =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0"
-
-let idx_build_input_id =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_input_id ON build(input_id)"
-
-let idx_build_main_binary =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_main_binary ON build(main_binary)"
-
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let* () = Grej.check_version ~user_version:old_version (module Db) in
   let* () = Db.exec new_build () in
@@ -134,10 +127,26 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   in
   let* () = Db.exec drop_build () in
   let* () = Db.exec rename_build () in
-  let* () = Db.exec idx_build_job_start () in
-  let* () = Db.exec idx_build_failed () in
-  let* () = Db.exec idx_build_input_id () in
-  let* () = Db.exec idx_build_main_binary () in
+  let* () =
+    Db.exec (Caqti_request.exec Caqti_type.unit
+        "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+      ()
+  in
+  let* () =
+    Db.exec (Caqti_request.exec Caqti_type.unit
+        "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0")
+      ()
+  in
+  let* () =
+    Db.exec (Caqti_request.exec Caqti_type.unit
+        "CREATE INDEX idx_build_input_id ON build(input_id)")
+      ()
+  in
+  let* () =
+    Db.exec (Caqti_request.exec Caqti_type.unit
+        "CREATE INDEX idx_build_main_binary ON build(main_binary)")
+      ()
+  in
   Db.exec (Grej.set_version new_version) ()
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
@@ -146,9 +155,25 @@ let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let* () = Db.exec copy_from_new_build () in
   let* () = Db.exec drop_build () in
   let* () = Db.exec rename_build () in
-  let* () = Db.exec idx_build_job_start () in
-  let* () = Db.exec idx_build_failed () in
-  let* () = Db.exec idx_build_input_id () in
-  let* () = Db.exec idx_build_main_binary () in
+  let* () =
+    Db.exec (Caqti_request.exec Caqti_type.unit
+        "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+      ()
+  in
+  let* () =
+    Db.exec (Caqti_request.exec Caqti_type.unit
+        "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0")
+      ()
+  in
+  let* () =
+    Db.exec (Caqti_request.exec Caqti_type.unit
+        "CREATE INDEX idx_build_input_id ON build(input_id)")
+      ()
+  in
+  let* () =
+    Db.exec (Caqti_request.exec Caqti_type.unit
+        "CREATE INDEX idx_build_main_binary ON build(main_binary)")
+      ()
+  in
   Db.exec (Grej.set_version old_version) ()
 

bin/migrations/m20220509.ml

@@ -1,56 +0,0 @@
-let new_version = 16L and old_version = 15L
-and identifier = "2022-05-09"
-and migrate_doc = "switch uuid encoding to hex"
-and rollback_doc = "switch uuid encoding back to binary"
-
-open Grej.Infix
-
-let old_uuid_rep =
-  let encode uuid = Ok (Uuidm.to_bytes uuid) in
-  let decode s =
-    Uuidm.of_bytes s
-    |> Option.to_result ~none:"failed to decode uuid"
-  in
-  Caqti_type.custom ~encode ~decode Caqti_type.string
-
-let new_uuid_rep =
-  let encode uuid = Ok (Uuidm.to_string uuid) in
-  let decode s =
-    Uuidm.of_string s
-    |> Option.to_result ~none:"failed to decode uuid"
-  in
-  Caqti_type.custom ~encode ~decode Caqti_type.string
-
-let uuids_byte_encoded_q =
-  Caqti_type.unit ->*
-  Caqti_type.t2 (Builder_db.Rep.id (`build : [`build])) old_uuid_rep @@
-  "SELECT id, uuid FROM build"
-
-let uuids_hex_encoded_q =
-  Caqti_type.unit ->*
-  Caqti_type.t2 (Builder_db.Rep.id (`build : [`build])) new_uuid_rep @@
-  "SELECT id, uuid FROM build"
-
-let migrate_q =
-  Caqti_type.t2 (Builder_db.Rep.id (`build : [`build])) new_uuid_rep ->.
-  Caqti_type.unit @@
-  "UPDATE build SET uuid = $2 WHERE id = $1"
-
-let rollback_q =
-  Caqti_type.t2 (Builder_db.Rep.id (`build : [`build])) old_uuid_rep ->.
-  Caqti_type.unit @@
-  "UPDATE build SET uuid = $2 WHERE id = $1"
-
-let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
-  let open Grej.Infix in
-  Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
-  Db.collect_list uuids_byte_encoded_q () >>= fun old_uuids ->
-  Grej.list_iter_result (Db.exec migrate_q) old_uuids >>= fun () ->
-  Db.exec (Grej.set_version new_version) ()
-
-let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
-  let open Grej.Infix in
-  Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
-  Db.collect_list uuids_hex_encoded_q () >>= fun new_uuids ->
-  Grej.list_iter_result (Db.exec rollback_q) new_uuids >>= fun () ->
-  Db.exec (Grej.set_version old_version) ()

bin/migrations/m20230911.ml

@@ -1,32 +0,0 @@
-let new_version = 17L and old_version = 16L
-and identifier = "2023-09-11"
-and migrate_doc = "index failed builds on main binary is null"
-and rollback_doc = "index failed builds on exit code"
-
-open Grej.Syntax
-
-let drop_idx_build_failed =
-  Caqti_type.(unit ->. unit) @@
-  "DROP INDEX idx_build_failed"
-
-let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
-  let* () = Grej.check_version ~user_version:old_version (module Db) in
-  let* () = Db.exec drop_idx_build_failed () in
-  let* () =
-    Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-             "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
-             WHERE main_binary IS NULL")
-      ()
-  in
-  Db.exec (Grej.set_version new_version) ()
-
-let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
-  let* () = Grej.check_version ~user_version:new_version (module Db) in
-  let* () = Db.exec drop_idx_build_failed () in
-  let* () =
-    Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-             "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
-              WHERE result_code <> 0")
-      ()
-  in
-  Db.exec (Grej.set_version old_version) ()

bin/migrations/m20230914.ml

@@ -1,162 +0,0 @@
-let new_version = 18L and old_version = 17L
-and identifier = "2023-09-14"
-and migrate_doc = "Artifacts are stored content-addressed in the filesystem"
-and rollback_doc = "Artifacts are stored under their build's job name and uuid"
-
-open Grej.Syntax
-
-let new_build_artifact =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  {| CREATE TABLE new_build_artifact (
-         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-         filepath TEXT NOT NULL,
-         sha256 BLOB NOT NULL,
-         size INTEGER NOT NULL,
-         build INTEGER NOT NULL,
-
-         FOREIGN KEY(build) REFERENCES build(id),
-         UNIQUE(build, filepath)
-       )
-  |}
-
-let old_build_artifact =
-  Caqti_type.unit ->.  Caqti_type.unit @@
-  {| CREATE TABLE new_build_artifact (
-         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-         filepath TEXT NOT NULL, -- the path as in the build
-         localpath TEXT NOT NULL, -- local path to the file on disk
-         sha256 BLOB NOT NULL,
-         size INTEGER NOT NULL,
-         build INTEGER NOT NULL,
-
-         FOREIGN KEY(build) REFERENCES build(id),
-         UNIQUE(build, filepath)
-       )
-  |}
-
-let idx_build_artifact_sha256 =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_artifact_sha256 ON build_artifact(sha256)"
-
-let idx_build_artifact_build =
-  Caqti_type.unit ->. Caqti_type.unit @@
-  "CREATE INDEX idx_build_artifact_build ON build_artifact(build)"
-
-let copy_new_build_artifact =
-  Caqti_type.(unit ->. unit) @@
-  {| INSERT INTO new_build_artifact(id, filepath, sha256, size, build)
-     SELECT id, filepath, sha256, size, build
-     FROM build_artifact
-  |}
-
-let copy_old_build_artifact =
-  Caqti_type.(unit ->. unit) @@
-  {| INSERT INTO new_build_artifact(id, filepath, localpath, sha256, size, build)
-     SELECT a.id, a.filepath,
-       j.name || '/' || b.uuid || '/output/' || a.filepath,
-       a.sha256, a.size, a.build
-     FROM build_artifact a, job j, build b
-     WHERE b.id = a.build AND j.id = b.job
-  |}
-
-let new_build_artifact_paths =
-  Caqti_type.unit ->* Caqti_type.(t2 string string) @@
-  {| SELECT localpath, '_artifacts/' || substr(lower(hex(sha256)), 1, 2) || '/' || lower(hex(sha256))
-     FROM build_artifact
-  |}
-
-let old_build_artifact_paths =
-  Caqti_type.unit ->* Caqti_type.(t2 string string) @@
-  {| SELECT '_artifacts/' || substr(lower(hex(a.sha256)), 1, 2) || '/' || lower(hex(a.sha256)),
-       j.name || '/' || b.uuid || '/output/' || a.filepath
-     FROM build_artifact a, job j, build b
-     WHERE b.id = a.build AND j.id = b.job
-  |}
-
-let drop_build_artifact =
-  Caqti_type.(unit ->. unit) @@
-  "DROP TABLE build_artifact"
-
-let rename_build_artifact =
-  Caqti_type.(unit ->. unit) @@
-  "ALTER TABLE new_build_artifact RENAME TO build_artifact"
-
-let move_paths ?force datadir (old_path, new_path) =
-  let old_path = Fpath.(datadir // v old_path) and new_path = Fpath.(datadir // v new_path) in
-  let* _created = Bos.OS.Dir.create (Fpath.parent new_path) in
-  Bos.OS.Path.move ?force old_path new_path
-
-let copy_paths datadir (old_path, new_path) =
-  let old_path = Fpath.(datadir // v old_path) and new_path = Fpath.(datadir // v new_path) in
-  let new_path_tmp = Fpath.(new_path + "tmp") in
-  let* _created = Bos.OS.Dir.create (Fpath.parent new_path) in
-  let cmd = Bos.Cmd.(v "cp" % p old_path % p new_path_tmp) in
-  let* () =
-    match Bos.OS.Cmd.run_status cmd with
-    | Ok `Exited 0 ->
-      Ok ()
-    | Ok status ->
-      let _ = Bos.OS.Path.delete new_path_tmp in
-      Error (`Msg (Fmt.str "cp failed: %a" Bos.OS.Cmd.pp_status status))
-    | Error _ as e ->
-      let _ = Bos.OS.Path.delete new_path_tmp in
-      e
-  in
-  Bos.OS.Path.move ~force:true new_path_tmp new_path
-
-let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
-  let* () = Grej.check_version ~user_version:old_version (module Db) in
-  let* () = Db.exec new_build_artifact () in
-  let* () = Db.exec copy_new_build_artifact () in
-  let* () = Db.iter_s new_build_artifact_paths (move_paths ~force:true datadir) () in
-  let* () = Db.exec drop_build_artifact () in
-  let* () = Db.exec rename_build_artifact () in
-  let* () = Db.exec idx_build_artifact_sha256 () in
-  let* () = Db.exec idx_build_artifact_build () in
-  Db.exec (Grej.set_version new_version) ()
-
-let rollback datadir (module Db : Caqti_blocking.CONNECTION) =
-  let* () = Grej.check_version ~user_version:new_version (module Db) in
-  let* () = Db.exec old_build_artifact () in
-  let* () = Db.exec copy_old_build_artifact () in
-  let* () = Db.iter_s old_build_artifact_paths (copy_paths datadir) () in
-  let* () =
-    Db.iter_s old_build_artifact_paths
-      (fun (old_path, _new_path) ->
-         Bos.OS.Path.delete Fpath.(datadir // v old_path))
-      ()
-  in
-  let* () = Db.exec drop_build_artifact () in
-  let* () = Db.exec rename_build_artifact () in
-  let* () = Db.exec idx_build_artifact_sha256 () in
-  Db.exec (Grej.set_version old_version) ()
-
-(* migration failed but managed to move *some* files *)
-let fixup_migrate datadir (module Db : Caqti_blocking.CONNECTION) =
-  let* () = Grej.check_version ~user_version:old_version (module Db) in
-  let* () =
-    Db.iter_s new_build_artifact_paths
-      (fun (old_path, new_path) ->
-         let* old_exists = Bos.OS.Path.exists Fpath.(datadir // v old_path) in
-         let* new_exists = Bos.OS.Path.exists Fpath.(datadir // v new_path) in
-         if new_exists && not old_exists then
-           copy_paths datadir (new_path, old_path)
-         else Ok ())
-      ()
-  in
-  Db.iter_s new_build_artifact_paths
-    (fun (_old_path, new_path) ->
-       Bos.OS.Path.delete Fpath.(datadir // v new_path))
-    ()
-
-(* rollback failed but some or all artifacts were copied *)
-let fixup_rollback datadir (module Db : Caqti_blocking.CONNECTION) =
-  let* () = Grej.check_version ~user_version:new_version (module Db) in
-  Db.iter_s old_build_artifact_paths
-    (fun (old_path, new_path) ->
-       let* old_exists = Bos.OS.Path.exists Fpath.(datadir // v old_path) in
-       if old_exists then
-         Bos.OS.Path.delete Fpath.(datadir // v new_path)
-       else
-         move_paths datadir (new_path, old_path))
-    ()

builder-web.opam

@@ -1,9 +1,9 @@
 opam-version: "2.0"
 maintainer: "Reynir Björnsson <reynir@reynir.dk>"
 authors: ["Reynir Björnsson <reynir@reynir.dk>"]
-homepage: "https://github.com/robur-coop/builder-web"
-dev-repo: "git+https://github.com/robur-coop/builder-web.git"
-bug-reports: "https://github.com/robur-coop/builder-web/issues"
+homepage: "https://github.com/roburio/builder-web"
+dev-repo: "git+https://github.com/roburio/builder-web.git"
+bug-reports: "https://github.com/roburio/builder-web/issues"
 license: "ISC"
 
 build: [
@@ -15,49 +15,35 @@ build: [
 ]
 
 depends: [
-  "ocaml" {>= "4.13.0"}
-  "dune" {>= "2.7.0"}
-  "builder" {>= "0.4.0"}
-  "dream" {>= "1.0.0~alpha7"}
+  "builder"
+  "dream" {>= "1.0.0~alpha2"}
+  "cstruct" {>= "6.0.0"}
   "bos"
-  "ohex" {>= "0.2.0"}
-  "lwt" {>= "5.7.0"}
-  "caqti" {>= "2.1.2"}
+  "hex"
+  "caqti"
   "caqti-lwt"
   "caqti-driver-sqlite3"
-  "mirage-crypto-rng" {>= "0.11.0"}
-  "kdf"
+  "pbkdf"
+  "mirage-crypto-rng"
+  "scrypt-kdf"
+  "alcotest" {with-test}
   "opam-core"
-  "opam-format" {>= "2.1.0"}
-  "metrics" {>= "0.3.0"}
-  "metrics-lwt" {>= "0.3.0"}
-  "metrics-influx" {>= "0.3.0"}
-  "metrics-rusage" {>= "0.3.0"}
+  "opam-format"
+  "metrics"
+  "metrics-lwt"
+  "metrics-influx"
+  "metrics-rusage"
   "ipaddr"
-  "tyxml" {>= "4.3.0"}
+  "tyxml"
   "ptime"
   "duration"
-  "asn1-combinators" {>= "0.3.0"}
+  "mirage-crypto"
+  "asn1-combinators"
   "logs"
-  "cmdliner" {>= "1.1.0"}
+  "cmdliner"
   "uri"
   "fmt" {>= "0.8.7"}
-  "cmarkit" {>= "0.3.0"}
-  "tar" {>= "3.0.0"}
-  "tar-unix" {>= "3.0.0"}
-  "owee"
-  "solo5-elftool" {>= "0.3.0"}
-  "decompress" {>= "1.5.0"}
-  "digestif" {>= "1.2.0"}
-  "alcotest" {>= "1.2.0" & with-test}
-  "ppx_deriving" {with-test}
-  "ppx_deriving_yojson" {with-test}
-  "yojson" {with-test}
+  "omd"
 ]
 
 synopsis: "Web interface for builder"
-description: """
-Builder-web takes in submissions of builds, typically from [builder](https://github.com/robur-coop/builder/), and displays the produced artifacts in a way that makes it easy to compare checksums and build status.
-Produced binaries can be downloaded and executed.
-[builds.robur.coop](https://builds.robur.coop/) itself runs builder-web.
-"""

db/builder_db.mli

@@ -3,16 +3,17 @@ module Rep : sig
   type 'a id
   type file = {
     filepath : Fpath.t;
-    sha256 : string;
+    localpath : Fpath.t;
+    sha256 : Cstruct.t;
     size : int;
   }
 
-  val id_to_int64 : 'a id -> int64
   val untyped_id : untyped_id Caqti_type.t
   val id : 'a -> 'a id Caqti_type.t
   val uuid : Uuidm.t Caqti_type.t
   val ptime : Ptime.t Caqti_type.t
   val fpath : Fpath.t Caqti_type.t
+  val cstruct : Cstruct.t Caqti_type.t
   val file : file Caqti_type.t
   val execution_result : Builder.execution_result Caqti_type.t
   val console : (int * string) list Caqti_type.t
@@ -21,7 +22,8 @@ type 'a id = 'a Rep.id
 
 type file = Rep.file = {
   filepath : Fpath.t;
-  sha256 : string;
+  localpath : Fpath.t;
+  sha256 : Cstruct.t;
   size : int;
 }
 
@@ -30,67 +32,64 @@ val application_id : int32
 val current_version : int64
 
 val get_application_id :
-  (unit, int32, [ `One ]) Caqti_request.t
+  (unit, int32, [< `Many | `One | `Zero > `One ]) Caqti_request.t
 
 val set_application_id :
-  (unit, unit, [ `Zero ]) Caqti_request.t
+  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
 
 val get_version :
-  (unit, int64, [ `One ]) Caqti_request.t
+  (unit, int64, [< `Many | `One | `Zero > `One ]) Caqti_request.t
 
 val set_current_version :
-  (unit, unit, [ `Zero ]) Caqti_request.t
+  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
 
 val last_insert_rowid :
-  (unit, 'a id, [ `One ]) Caqti_request.t
+  (unit, 'a id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
 
 module Job : sig
   val get :
-    ([`job] id, string, [ `One ])
+    ([`job] id, string, [< `Many | `One | `Zero > `One ])
       Caqti_request.t
   val get_id_by_name :
-    (string, [`job] id, [ `One | `Zero ]) Caqti_request.t
+    (string, [`job] id, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t
   val get_all_with_section_synopsis :
     (unit, [`job] id * string * string option * string option, [ `Many | `One | `Zero ]) Caqti_request.t
   val try_add :
-    (string, unit, [ `Zero ]) Caqti_request.t
+    (string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val remove :
-    ([`job] id, unit, [ `Zero ]) Caqti_request.t
+    ([`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
 end
 
 module Tag : sig
   val get_id_by_name :
-    (string, [`tag] id, [ `One ]) Caqti_request.t
+    (string, [`tag] id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
   val try_add :
-    (string, unit, [ `Zero ]) Caqti_request.t
+    (string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
 end
 
 module Job_tag : sig
   val add :
-    ([`tag] id * string * [`job] id, unit, [ `Zero ]) Caqti_request.t
+    ([`tag] id * string * [`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val update :
-    ([`tag] id * string * [`job] id, unit, [ `Zero ]) Caqti_request.t
+    ([`tag] id * string * [`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val get_value :
-    ([`tag] id * [`job] id, string, [ `One | `Zero ]) Caqti_request.t
-  val remove_by_job :
-    ([`job] id, unit, [ `Zero ]) Caqti_request.t
+    ([`tag] id * [`job] id, string, [< `Many | `One | `Zero > `Zero `One ]) Caqti_request.t
 end
 
 module Build_artifact : sig
-  val get : ([`build_artifact] id, file, [ `One]) Caqti_request.t
+  val get : ([`build_artifact] id, file, [< `Many | `One | `Zero > `One]) Caqti_request.t
   val get_by_build_uuid :
     (Uuidm.t * Fpath.t, [`build_artifact] id * file,
-     [ `One | `Zero ])
+     [< `Many | `One | `Zero > `One `Zero ])
       Caqti_request.t
   val get_all_by_build :
     ([`build] id, [`build_artifact] id * file, [ `Many | `One | `Zero ]) Caqti_request.t
-  val exists : (string, bool, [ `One ]) Caqti_request.t
   val add :
-    (file * [`build] id, unit, [ `Zero ]) Caqti_request.t
+    (file * [`build] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val remove_by_build :
-    ([`build] id, unit, [ `Zero ]) Caqti_request.t
+    ([`build] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val remove :
-    ([`build_artifact] id, unit, [ `Zero ]) Caqti_request.t
+    ([`build_artifact] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
 end
 
 module Build :
@@ -104,94 +103,91 @@ sig
     script : Fpath.t;
     platform : string;
     main_binary : [`build_artifact] id option;
-    input_id : string option;
+    input_id : Cstruct.t option;
     user_id : [`user] id;
     job_id : [`job] id;
   }
 
-  val pp : t Fmt.t
-
   val get_by_uuid :
-    (Uuidm.t, [`build] id * t, [ `One | `Zero ])
+    (Uuidm.t, [`build] id * t, [< `Many | `One | `Zero > `One `Zero ])
       Caqti_request.t
   val get_all :
     ([`job] id, [`build] id * t, [ `Many | `One | `Zero ]) Caqti_request.t
-  val get_all_failed :
-    (int * int * string option, string * t, [ `Many | `One | `Zero ]) Caqti_request.t
   val get_all_artifact_sha :
-    ([`job] id * string option, string, [ `Many | `One | `Zero ]) Caqti_request.t
-  val get_latest_successful_with_binary :
-    ([`job] id * string, [`build] id * t * file, [ `One | `Zero ])
+    ([`job] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
+  val get_all_artifact_sha_by_platform :
+    ([`job] id * string, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
+  val get_latest :
+    ([`job] id * string, [`build] id * t * file option, [< `Many | `One | `Zero > `One `Zero ])
       Caqti_request.t
-  val get_failed_builds :
-    ([`job] id * string option, t, [ `Many | `One | `Zero ]) Caqti_request.t
-  val get_latest_successful :
-    ([`job] id * string option, t, [ `One | `Zero ])
+  val get_latest_failed :
+    ([`job] id, t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t
+  val get_latest_failed_by_platform :
+    ([`job] id * string, t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t
+  val get_latest_successful_uuid :
+    ([`job] id, Uuidm.t, [< `Many | `One | `Zero > `One `Zero ])
       Caqti_request.t
-  val get_builds_older_than :
-    ([`job] id * string option * Ptime.t, [`build] id * t, [ `Many | `One | `Zero ]) Caqti_request.t
-  val get_builds_excluding_latest_n :
-    ([`job] id * string option * int, [`build] id * t, [ `Many | `One | `Zero ]) Caqti_request.t
-  val get_nth_latest_successful :
-    ([`job] id * string option * int, [`build] id * t, [ `One | `Zero ]) Caqti_request.t
-  val get_previous_successful_different_output :
-    ([`build] id, t, [ `One | `Zero ])
+  val get_latest_successful_uuid_by_platform :
+    ([`job] id * string, Uuidm.t, [< `Many | `One | `Zero > `One `Zero ])
       Caqti_request.t
-  val get_next_successful_different_output :
-    ([`build] id, t, [ `One | `Zero ])
+  val get_previous_successful_uuid :
+    ([`build] id, Uuidm.t, [< `Many | `One | `Zero > `One `Zero ])
+      Caqti_request.t
+  val get_next_successful_uuid :
+    ([`build] id, Uuidm.t, [< `Many | `One | `Zero > `One `Zero ])
       Caqti_request.t
   val get_same_input_same_output_builds :
     ([`build] id, t, [ `Many | `One | `Zero ]) Caqti_request.t
   val get_same_input_different_output_hashes :
-    ([`build] id, string, [ `Many | `One | `Zero ]) Caqti_request.t
+    ([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
   val get_different_input_same_output_input_ids :
-    ([`build] id, string, [ `Many | `One | `Zero ]) Caqti_request.t
+    ([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
   val get_one_by_input_id :
-    (string, t, [ `One ]) Caqti_request.t
+    (Cstruct.t, t, [< `Many | `One | `Zero > `One ]) Caqti_request.t
   val get_platforms_for_job :
     ([`job] id, string, [ `Many | `One | `Zero ]) Caqti_request.t
-  val add : (t, unit, [ `Zero ]) Caqti_request.t
+  val add : (t, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val get_by_hash :
-    (string, t, [ `One]) Caqti_request.t
+    (Cstruct.t, t, [< `Many | `One | `Zero > `One]) Caqti_request.t
   val get_with_main_binary_by_hash :
-    (string, t * file option, [ `One]) Caqti_request.t
+    (Cstruct.t, t * file option, [< `Many | `One | `Zero > `One]) Caqti_request.t
   val get_with_jobname_by_hash :
-    (string, string * t, [ `One | `Zero]) Caqti_request.t
-  val set_main_binary : ([`build] id * [`build_artifact] id, unit, [ `Zero ]) Caqti_request.t
-  val remove : ([`build] id, unit, [ `Zero]) Caqti_request.t
+    (Cstruct.t, string * t, [< `Many | `One | `Zero > `One `Zero]) Caqti_request.t
+  val set_main_binary : ([`build] id * [`build_artifact] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+  val remove : ([`build] id, unit, [< `Many | `One | `Zero > `Zero]) Caqti_request.t
 end
 
 module User : sig
   val get_user :
     (string, [`user] id * Builder_web_auth.scrypt Builder_web_auth.user_info,
-     [ `One | `Zero ])
+     [< `Many | `One | `Zero > `One `Zero ])
     Caqti_request.t
   val get_all :
-    (unit, string, [ `Many | `One | `Zero ]) Caqti_request.t
+    (unit, [`user] id * string, [ `Many | `One | `Zero ]) Caqti_request.t
   val add :
-    (Builder_web_auth.scrypt Builder_web_auth.user_info, unit, [ `Zero ])
+    (Builder_web_auth.scrypt Builder_web_auth.user_info, unit, [< `Many | `One | `Zero > `Zero ])
     Caqti_request.t
   val remove_user :
-    (string, unit, [ `Zero ]) Caqti_request.t
+    (string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val update_user :
-    (Builder_web_auth.scrypt Builder_web_auth.user_info, unit, [ `Zero ])
+    (Builder_web_auth.scrypt Builder_web_auth.user_info, unit, [< `Many | `One | `Zero > `Zero ])
     Caqti_request.t
 end
 
 module Access_list : sig
   val get :
-    ([`user] id * [`job] id, [`access_list] id, [ `One ]) Caqti_request.t
+    ([`user] id * [`job] id, [`access_list] id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
+  val get_all_names :
+    (unit, string * string, [ `Many | `One | `Zero ]) Caqti_request.t
   val add :
-    ([`user] id * [`job] id, unit, [ `Zero ]) Caqti_request.t
+    ([`user] id * [`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val remove :
-    ([`user] id * [`job] id, unit, [ `Zero ]) Caqti_request.t
-  val remove_by_job :
-    ([`job] id, unit, [ `Zero ]) Caqti_request.t
+    ([`user] id * [`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val remove_all_by_username :
-    (string, unit, [ `Zero ]) Caqti_request.t
+    (string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
 end
 
 val migrate :
-  (unit, unit, [ `Zero ]) Caqti_request.t list
+  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t list
 val rollback :
-  (unit, unit, [ `Zero ]) Caqti_request.t list
+  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t list

db/dune

@@ -1,3 +1,3 @@
 (library
  (name builder_db)
- (libraries builder caqti caqti-driver-sqlite3 asn1-combinators builder_web_auth))
+ (libraries builder caqti caqti-driver-sqlite3 asn1-combinators mirage-crypto builder_web_auth))

db/representation.ml

@@ -1,8 +1,8 @@
 module Asn = struct
   let decode_strict codec cs =
     match Asn.decode codec cs with
-    | Ok (a, rest) ->
-      if String.length rest = 0
+    | Ok (a, cs) ->
+      if Cstruct.length cs = 0
       then Ok a
       else Error "trailing bytes"
     | Error (`Parse msg) -> Error ("parse error: " ^ msg)
@@ -17,7 +17,7 @@ module Asn = struct
                 (required ~label:"delta" int)
                 (required ~label:"data" utf8_string)))
 
-  let console_of_str, console_to_str = projections_of console
+  let console_of_cs, console_to_cs = projections_of console
 end
 
 type untyped_id = int64
@@ -26,18 +26,17 @@ type 'a id = untyped_id
 let id (_ : 'a) : 'a id Caqti_type.t = untyped_id
 let any_id : 'a id Caqti_type.t = untyped_id
 
-let id_to_int64 (id : 'a id) : int64 = id
-
 type file = {
   filepath : Fpath.t;
-  sha256 : string;
+  localpath : Fpath.t;
+  sha256 : Cstruct.t;
   size : int;
 }
 
 let uuid =
-  let encode uuid = Ok (Uuidm.to_string uuid) in
+  let encode uuid = Ok (Uuidm.to_bytes uuid) in
   let decode s =
-    Uuidm.of_string s
+    Uuidm.of_bytes s
     |> Option.to_result ~none:"failed to decode uuid"
   in
   Caqti_type.custom ~encode ~decode Caqti_type.string
@@ -47,7 +46,7 @@ let ptime =
   let encode t = Ok (Ptime.Span.to_d_ps (Ptime.to_span t)) in
   let decode (d, ps) = Ok (Ptime.v (d, ps))
   in
-  let rep = Caqti_type.(t2 int int64) in
+  let rep = Caqti_type.(tup2 int int64) in
   Caqti_type.custom ~encode ~decode rep
 
 let fpath =
@@ -56,25 +55,30 @@ let fpath =
                  |> Result.map_error (fun (`Msg s) -> s) in
   Caqti_type.custom ~encode ~decode Caqti_type.string
 
+let cstruct =
+  let encode t = Ok (Cstruct.to_string t) in
+  let decode s = Ok (Cstruct.of_string s) in
+  Caqti_type.custom ~encode ~decode Caqti_type.octets
+
 let file =
-  let encode { filepath; sha256; size } =
-    Ok (filepath, sha256, size) in
-  let decode (filepath, sha256, size) =
-    Ok { filepath; sha256; size } in
-  Caqti_type.custom ~encode ~decode Caqti_type.(t3 fpath octets int)
+  let encode { filepath; localpath; sha256; size } =
+    Ok (filepath, localpath, sha256, size) in
+  let decode (filepath, localpath, sha256, size) =
+    Ok { filepath; localpath; sha256; size } in
+  Caqti_type.custom ~encode ~decode Caqti_type.(tup4 fpath fpath cstruct int)
 
 let file_opt =
-  let rep = Caqti_type.(t3 (option fpath) (option octets) (option int)) in
+  let rep = Caqti_type.(tup4 (option fpath) (option fpath) (option cstruct) (option int)) in
   let encode = function
-    | Some { filepath; sha256; size } ->
-      Ok (Some filepath, Some sha256, Some size)
+    | Some { filepath; localpath; sha256; size } ->
+      Ok (Some filepath, Some localpath, Some sha256, Some size)
     | None ->
-      Ok (None, None, None)
+      Ok (None, None, None, None)
   in
   let decode = function
-    | (Some filepath, Some sha256, Some size) ->
-      Ok (Some { filepath; sha256; size })
-    | (None, None, None) ->
+    | (Some filepath, Some localpath, Some sha256, Some size) ->
+      Ok (Some { filepath; localpath; sha256; size })
+    | (None, None, None, None) ->
       Ok None
     | _ ->
       (* This should not happen if the database is well-formed *)
@@ -103,25 +107,25 @@ let execution_result =
     else
       Error "bad encoding (unknown number)"
   in
-  let rep = Caqti_type.(t2 int (option string)) in
+  let rep = Caqti_type.(tup2 int (option string)) in
   Caqti_type.custom ~encode ~decode rep
 
 let console =
-  let encode console = Ok (Asn.console_to_str console) in
-  let decode data = Asn.console_of_str data in
-  Caqti_type.(custom ~encode ~decode octets)
+  let encode console = Ok (Asn.console_to_cs console) in
+  let decode data = Asn.console_of_cs data in
+  Caqti_type.custom ~encode ~decode cstruct
 
 let user_info =
-  let rep = Caqti_type.(t7 string octets octets int int int bool) in
+  let rep = Caqti_type.(tup4 string cstruct cstruct (tup4 int int int bool)) in
   let encode { Builder_web_auth.username;
                password_hash = `Scrypt (password_hash, password_salt, {
                    Builder_web_auth.scrypt_n; scrypt_r; scrypt_p
                });
                restricted; }
     =
-    Ok (username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted)
+    Ok (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p, restricted))
   in
-  let decode (username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) =
+  let decode (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p, restricted)) =
     Ok { Builder_web_auth.username;
          password_hash =
            `Scrypt (password_hash, password_salt,
@@ -132,6 +136,7 @@ let user_info =
 
 (* this doesn't really belong in this module, but we need access to the type of [id] *)
 let last_insert_rowid =
-  let open Caqti_request.Infix in
-  Caqti_type.unit ->! any_id @@
+  Caqti_request.find
+    Caqti_type.unit
+    any_id
     "SELECT last_insert_rowid()"

dune-project

@@ -1,3 +1,2 @@
 (lang dune 2.7)
 (name builder-web)
-(formatting disabled)

lib/authorization.ml

@@ -6,14 +6,14 @@ open Lwt.Syntax
 
 let realm = "builder-web"
 
-let user_info_field = Dream.new_field ~name:"user_info" ()
+let user_info_local = Dream.new_local ~name:"user_info" ()
 
 let authenticate handler = fun req ->
   let unauthorized () =
     let headers = ["WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" realm] in
     Dream.respond ~headers ~status:`Unauthorized "Forbidden!"
   in
-  match Dream.header req "Authorization" with
+  match Dream.header "Authorization" req with
   | None -> unauthorized ()
   | Some data -> match String.split_on_char ' ' data with
      | [ "Basic" ; user_pass ] ->
@@ -31,7 +31,7 @@ let authenticate handler = fun req ->
            match user_info with
            | Ok (Some (id, user_info)) ->
              if Builder_web_auth.verify_password pass user_info
-             then (Dream.set_field req user_info_field (id, user_info); handler req)
+             then handler (Dream.with_local user_info_local (id, user_info) req)
              else unauthorized ()
            | Ok None ->
              let _ : _ Builder_web_auth.user_info =
@@ -45,7 +45,7 @@ let authenticate handler = fun req ->
        Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
 
 let authorized req job_name =
-  match Dream.field req user_info_field with
+  match Dream.local user_info_local req with
   | None -> Lwt.return (Error (`Msg "not authenticated"))
   | Some (id, user) ->
      if user.restricted then

lib/builder_web.ml

@@ -9,8 +9,8 @@ let pp_error ppf = function
   | #Model.error as e -> Model.pp_error ppf e
   | `Wrong_version (application_id, version) ->
     if application_id = Builder_db.application_id
-    then Format.fprintf ppf "Wrong database version: %Ld, expected %Ld" version Builder_db.current_version
-    else Format.fprintf ppf "Wrong database application id: %ld, expected %ld" application_id Builder_db.application_id
+    then Format.fprintf ppf "Wrong database version: %Ld" version
+    else Format.fprintf ppf "Wrong database application id: %ld" application_id
 
 let init_datadir datadir =
   let ( let* ) = Result.bind and ( let+ ) x f = Result.map f x in
@@ -26,7 +26,7 @@ let init_datadir datadir =
 let init dbpath datadir =
   Result.bind (init_datadir datadir) @@ fun () ->
   Lwt_main.run (
-    Caqti_lwt_unix.connect
+    Caqti_lwt.connect
       (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
     >>= fun (module Db : Caqti_lwt.CONNECTION) ->
     Db.find Builder_db.get_application_id () >>= fun application_id ->
@@ -46,29 +46,16 @@ let safe_seg path =
   else Fmt.kstr (fun s -> Error (`Msg s)) "unsafe path %S" path
 
 (* mime lookup with orb knowledge *)
-let append_charset = function
-  (* mime types from nginx:
-     http://nginx.org/en/docs/http/ngx_http_charset_module.html#charset_types *)
-  | "text/html" | "text/xml" | "text/plain" | "text/vnd.wap.wml"
-  | "application/javascript" | "application/rss+xml" | "application/atom+xml"
-  as content_type ->
-    content_type ^ "; charset=utf-8" (* default to utf-8 *)
-  | content_type -> content_type
-
 let mime_lookup path =
-  append_charset
-    (match Fpath.to_string path with
-     | "build-environment" | "opam-switch" | "system-packages" ->
-       "text/plain"
-     | _ ->
-       if Fpath.has_ext "build-hashes" path
-       then "text/plain"
-       else if Fpath.is_prefix Fpath.(v "bin/") path
-       then "application/octet-stream"
-       else Magic_mime.lookup (Fpath.to_string path))
-
-let string_of_html =
-  Format.asprintf "%a" (Tyxml.Html.pp ())
+  match Fpath.to_string path with
+  | "build-environment" | "opam-switch" | "system-packages" ->
+    "text/plain"
+  | _ ->
+    if Fpath.has_ext "build-hashes" path
+    then "text/plain"
+    else if Fpath.is_prefix Fpath.(v "bin/") path
+    then "application/octet-stream"
+    else Magic_mime.lookup (Fpath.to_string path)
 
 let or_error_response r =
   let* r = r in
@@ -76,13 +63,7 @@ let or_error_response r =
   | Ok response -> Lwt.return response
   | Error (text, status) -> Dream.respond ~status text
 
-let default_log_warn ~status e =
-  Log.warn (fun m -> m "%s: %a" (Dream.status_to_string status) pp_error e)
-
-let if_error
-    ?(status = `Internal_Server_Error)
-    ?(log = default_log_warn ~status)
-    message r =
+let if_error ?(status  = `Internal_Server_Error) ?(log=(fun e -> Log.warn (fun m -> m "%s: %a" (Dream.status_to_string status) pp_error e))) message r =
   let* r = r in
   match r with
   | Error `Not_found ->
@@ -92,12 +73,8 @@ let if_error
     Lwt_result.fail (message, status)
   | Ok _ as r -> Lwt.return r
 
-let not_found_error r =
-  let* r = r in
-  match r with
-  | Error `Not_found ->
-    Lwt_result.fail ("Resource not found", `Not_Found)
-  | Ok _ as r -> Lwt.return r
+let string_of_html =
+  Format.asprintf "%a" (Tyxml.Html.pp ())
 
 let get_uuid s =
   Lwt.return
@@ -107,164 +84,11 @@ let get_uuid s =
        | None -> Error ("Bad uuid", `Bad_Request)
      else Error ("Bad uuid", `Bad_Request))
 
+let add_routes datadir =
+  let datadir_global = Dream.new_global ~name:"datadir" (fun () -> datadir) in
 
-let main_binary_of_uuid uuid db =
-  Model.build uuid db
-  |> if_error "Error getting job build"
-    ~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
-  >>= fun (_id, build) ->
-  Model.not_found build.Builder_db.Build.main_binary
-  |> not_found_error
-  >>= fun main_binary ->
-  Model.build_artifact_by_id main_binary db
-  |> if_error "Error getting main binary"
-
-module Viz_aux = struct
-
-  let viz_type_to_string = function
-    | `Treemap -> "treemap"
-    | `Dependencies -> "dependencies"
-
-  let viz_dir ~cachedir ~viz_typ ~version =
-    let typ_str = viz_type_to_string viz_typ in
-    Fpath.(cachedir / Fmt.str "%s_%d" typ_str version)
-
-  let viz_path ~cachedir ~viz_typ ~version ~input_hash =
-    Fpath.(
-      viz_dir ~cachedir ~viz_typ ~version
-      / input_hash + "html"
-    )
-
-  let choose_versioned_viz_path
-      ~cachedir
-      ~viz_typ
-      ~viz_input_hash
-      ~current_version =
-    let ( >>= ) = Result.bind in
-    let rec aux current_version =
-      let path =
-        viz_path ~cachedir
-          ~viz_typ
-          ~version:current_version
-          ~input_hash:viz_input_hash in
-      Bos.OS.File.exists path >>= fun path_exists ->
-      if path_exists then Ok path else (
-        if current_version = 1 then
-          Error (`Msg (Fmt.str "viz '%s': There exist no version of the requested \
-                                visualization"
-                         (viz_type_to_string viz_typ)))
-        else
-          aux @@ pred current_version
-      )
-    in
-    aux current_version
-
-  let get_viz_version_from_dirs ~cachedir ~viz_typ =
-    let ( >>= ) = Result.bind in
-    Bos.OS.Dir.contents cachedir >>= fun versioned_dirs ->
-    let max_cached_version =
-      let viz_typ_str = viz_type_to_string viz_typ ^ "_" in
-      versioned_dirs
-      |> List.filter_map (fun versioned_dir ->
-          match Bos.OS.Dir.exists versioned_dir with
-          | Error (`Msg err) ->
-            Logs.warn (fun m -> m "%s" err);
-            None
-          | Ok false -> None
-          | Ok true ->
-            let dir_str = Fpath.filename versioned_dir in
-            if not (String.starts_with ~prefix:viz_typ_str dir_str) then
-              None
-            else
-              try
-                String.(sub dir_str
-                          (length viz_typ_str)
-                          (length dir_str - length viz_typ_str))
-                |> int_of_string
-                |> Option.some
-              with Failure _ ->
-                Logs.warn (fun m ->
-                    m "Failed to read visualization-version from directory: '%s'"
-                      (Fpath.to_string versioned_dir));
-                None
-        )
-      |> List.fold_left Int.max (-1)
-    in
-    if max_cached_version = -1 then
-      Result.error @@
-      `Msg (Fmt.str "Couldn't find any visualization-version of %s"
-              (viz_type_to_string viz_typ))
-    else
-      Result.ok max_cached_version
-
-  let hash_viz_input ~uuid typ db =
-    let open Builder_db in
-    main_binary_of_uuid uuid db >>= fun main_binary ->
-    Model.build uuid db
-    |> if_error "Error getting build" >>= fun (build_id, _build) ->
-    Model.build_artifacts build_id db
-    |> if_error "Error getting build artifacts" >>= fun artifacts ->
-    match typ with
-    | `Treemap ->
-      let debug_binary =
-        let bin = Fpath.base main_binary.filepath in
-        List.find_opt
-          (fun p -> Fpath.(equal (bin + "debug") (base p.filepath)))
-          artifacts
-      in
-      begin
-        Model.not_found debug_binary
-        |> not_found_error >>= fun debug_binary ->
-        debug_binary.sha256
-        |> Ohex.encode
-        |> Lwt_result.return
-      end
-    | `Dependencies ->
-      let opam_switch =
-        List.find_opt
-          (fun p -> Fpath.(equal (v "opam-switch") (base p.filepath)))
-          artifacts
-      in
-      Model.not_found opam_switch
-      |> not_found_error >>= fun opam_switch ->
-      opam_switch.sha256
-      |> Ohex.encode
-      |> Lwt_result.return
-
-  let try_load_cached_visualization ~cachedir ~uuid viz_typ db =
-    Lwt.return (get_viz_version_from_dirs ~cachedir ~viz_typ)
-    |> if_error "Error getting visualization version" >>= fun latest_viz_version ->
-    hash_viz_input ~uuid viz_typ db >>= fun viz_input_hash ->
-    (choose_versioned_viz_path
-       ~cachedir
-       ~current_version:latest_viz_version
-       ~viz_typ
-       ~viz_input_hash
-     |> Lwt.return
-     |> if_error "Error finding a version of the requested visualization")
-    >>= fun viz_path ->
-    Lwt_result.catch (fun () ->
-      Lwt_io.with_file ~mode:Lwt_io.Input
-        (Fpath.to_string viz_path)
-        Lwt_io.read
-    )
-    |> Lwt_result.map_error (fun exn -> `Msg (Printexc.to_string exn))
-    |> if_error "Error getting cached visualization"
-
-end
-
-
-let routes ~datadir ~cachedir ~configdir ~expired_jobs =
-  let builds ~all ?(filter_builds_later_than = 0) req =
-    let than =
-      if filter_builds_later_than = 0 then
-        Ptime.epoch
-      else
-        let n = Ptime.Span.v (filter_builds_later_than, 0L) in
-        let now = Ptime_clock.now () in
-        Ptime.Span.sub (Ptime.to_span now) n |> Ptime.of_span |>
-        Option.fold ~none:Ptime.epoch ~some:Fun.id
-    in
+  let builder req =
+    (* TODO filter unsuccessful builds, ?failed=true *)
     Dream.sql req Model.jobs_with_section_synopsis
     |> if_error "Error getting jobs"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e))
@@ -277,145 +101,93 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
            r >>= fun acc ->
            Dream.sql req (Model.build_with_main_binary job_id platform) >>= function
            | Some (build, artifact) ->
-             if Ptime.is_later ~than build.finish then
-               Lwt_result.return ((platform, build, artifact) :: acc)
-             else
-               Lwt_result.return acc
+             Lwt_result.return ((platform, build, artifact) :: acc)
            | None ->
              Log.warn (fun m -> m "Job without builds: %s" job_name);
              Lwt_result.return acc)
            ps (Lwt_result.return []) >>= fun platform_builds ->
-         if platform_builds = [] then
-           Lwt_result.return acc
-         else
-           let v = (job_name, synopsis, platform_builds) in
-           let section = Option.value ~default:"Uncategorized" section in
-           Lwt_result.return (Utils.String_map.add_or_create section v acc))
+         let v = (job_name, synopsis, platform_builds) in
+         let section = Option.value ~default:"Uncategorized" section in
+         Lwt_result.return (Utils.String_map.add_or_create section v acc))
       jobs
       (Lwt_result.return Utils.String_map.empty)
     |> if_error "Error getting jobs"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e))
     >>= fun jobs ->
-    Views.Builds.make ~all jobs |> string_of_html |> Dream.html |> Lwt_result.ok
+    Views.builder jobs |> string_of_html |> Dream.html |> Lwt_result.ok
   in
 
   let job req =
-    let job_name = Dream.param req "job" in
-    let platform = Dream.query req "platform" in
+    let job_name = Dream.param "job" req in
+    let platform = Dream.query "platform" req in
     (Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) ->
      Dream.sql req (Model.builds_grouped_by_output job_id platform) >|= fun builds ->
      (readme, builds))
     |> if_error "Error getting job"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
     >>= fun (readme, builds) ->
-    Views.Job.make ~failed:false ~job_name ~platform ~readme builds
-    |> string_of_html |> Dream.html |> Lwt_result.ok
+    Views.job job_name readme builds |> string_of_html |> Dream.html |> Lwt_result.ok
   in
 
-  let job_with_failed req =
-    let job_name = Dream.param req "job" in
-    let platform = Dream.query req "platform" in
-    (Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) ->
-     Dream.sql req (Model.builds_grouped_by_output_with_failed job_id platform) >|= fun builds ->
-     (readme, builds))
-    |> if_error "Error getting job"
-      ~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
-    >>= fun (readme, builds) ->
-    Views.Job.make ~failed:true ~job_name ~platform ~readme builds
-    |> string_of_html |> Dream.html |> Lwt_result.ok
-  in
-
-  let redirect_latest req ~job_name ~platform ~artifact =
+  let redirect_latest req =
+    let job_name = Dream.param "job" req in
+    let platform = Dream.query "platform" req in
+    let path = Dream.path req |> String.concat "/" in
     (Dream.sql req (Model.job_id job_name) >>= Model.not_found >>= fun job_id ->
      Dream.sql req (Model.latest_successful_build_uuid job_id platform))
     >>= Model.not_found
     |> if_error "Error getting job" >>= fun build ->
     Dream.redirect req
-      (Link.Job_build_artifact.make_from_string ~job_name ~build ~artifact ())
+      (Fmt.str "/job/%s/build/%a/%s" job_name Uuidm.pp build path)
     |> Lwt_result.ok
   in
 
-  let redirect_latest req =
-    let job_name = Dream.param req "job" in
-    let platform = Dream.query req "platform" in
-    let artifact =
-      (* FIXME Dream.path deprecated *)
-      let path = begin[@alert "-deprecated"] Dream.path req end in
-      if path = [] then
-        "" (* redirect without trailing slash *)
-      else
-        "/" ^ (List.map Uri.pct_encode path |> String.concat "/")
-    in
-    redirect_latest req ~job_name ~platform ~artifact
-
-  and redirect_latest_no_slash req =
-    let job_name = Dream.param req "job" in
-    let platform = Dream.query req "platform" in
-    redirect_latest req ~job_name ~platform ~artifact:""
-  in
-
   let redirect_main_binary req =
-    let job_name = Dream.param req "job"
-    and build = Dream.param req "build" in
+    let job_name = Dream.param "job" req
+    and build = Dream.param "build" req in
     get_uuid build >>= fun uuid ->
-    Dream.sql req (main_binary_of_uuid uuid) >>= fun main_binary ->
-    let artifact = `File main_binary.Builder_db.filepath in
-    Link.Job_build_artifact.make ~job_name ~build:uuid ~artifact ()
-    |> Dream.redirect req
-    |> Lwt_result.ok
-  in
-
-  let job_build_viz viz_typ req =
-    let _job_name = Dream.param req "job"
-    and build = Dream.param req "build" in
-    get_uuid build >>= fun uuid ->
-    Dream.sql req (Viz_aux.try_load_cached_visualization ~cachedir ~uuid viz_typ)
-    >>= fun svg_html ->
-    Lwt_result.ok (Dream.html svg_html)
+    Dream.sql req (Model.build uuid)
+    |> if_error "Error getting job build"
+     ~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
+    >>= fun (_id, build) ->
+    match build.Builder_db.Build.main_binary with
+    | None -> Lwt_result.fail ("Resource not found", `Not_Found)
+    | Some main_binary ->
+      Dream.sql req (Model.build_artifact_by_id main_binary)
+      |> if_error "Error getting main binary" >>= fun main_binary ->
+      Dream.redirect req
+        (Fmt.str "/job/%s/build/%a/f/%a" job_name Uuidm.pp uuid
+          Fpath.pp main_binary.Builder_db.filepath)
+      |> Lwt_result.ok
   in
 
   let job_build req =
-    let job_name = Dream.param req "job"
-    and build = Dream.param req "build" in
+    let job_name = Dream.param "job" req
+    and build = Dream.param "build" req in
     get_uuid build >>= fun uuid ->
-    Dream.sql req (fun conn ->
-        Model.build uuid conn >>= fun (build_id, build) ->
-        (match build.Builder_db.Build.main_binary with
-         | Some main_binary ->
-           Model.build_artifact_by_id main_binary conn |> Lwt_result.map Option.some
-         | None -> Lwt_result.return None) >>= fun main_binary ->
-        Model.build_artifacts build_id conn >>= fun artifacts ->
-        Model.builds_with_same_input_and_same_main_binary build_id conn >>= fun same_input_same_output ->
-        Model.builds_with_different_input_and_same_main_binary build_id conn >>= fun different_input_same_output ->
-        Model.builds_with_same_input_and_different_main_binary build_id conn >>= fun same_input_different_output ->
-        Model.latest_successful_build build.job_id (Some build.Builder_db.Build.platform) conn >>= fun latest ->
-        Model.next_successful_build_different_output build_id conn >>= fun next ->
-        Model.previous_successful_build_different_output build_id conn >|= fun previous ->
-        (build, main_binary, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest, next, previous)
-      )
+    (Dream.sql req (Model.readme job_name) >>= fun readme ->
+     Dream.sql req (Model.build uuid) >>= fun (build_id, build) ->
+     Dream.sql req (Model.build_artifacts build_id) >>= fun artifacts ->
+     Dream.sql req (Model.builds_with_same_input_and_same_main_binary build_id) >>= fun same_input_same_output ->
+     Dream.sql req (Model.builds_with_different_input_and_same_main_binary build_id) >>= fun different_input_same_output ->
+     Dream.sql req (Model.builds_with_same_input_and_different_main_binary build_id) >>= fun same_input_different_output ->
+     Dream.sql req (Model.latest_successful_build_uuid build.job_id (Some build.Builder_db.Build.platform)) >>= fun latest_uuid ->
+     Dream.sql req (Model.next_successful_build_uuid build_id) >>= fun next_uuid ->
+     Dream.sql req (Model.previous_successful_build_uuid build_id) >|= fun previous_uuid ->
+         (readme, build, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest_uuid, next_uuid, previous_uuid))
     |> if_error "Error getting job build"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
-    >>= fun (build, main_binary, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest, next, previous) ->
-    let solo5_manifest = Option.bind main_binary (Model.solo5_manifest datadir) in
-    Views.Job_build.make
-      ~job_name
-      ~build
-      ~artifacts
-      ~main_binary
-      ~solo5_manifest
-      ~same_input_same_output
-      ~different_input_same_output
-      ~same_input_different_output
-      ~latest ~next ~previous
+    >>= fun (readme, build, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest_uuid, next_uuid, previous_uuid) ->
+    Views.job_build job_name readme build artifacts same_input_same_output different_input_same_output same_input_different_output latest_uuid next_uuid previous_uuid
     |> string_of_html |> Dream.html |> Lwt_result.ok
   in
 
   let job_build_file req =
-    let _job_name = Dream.param req "job"
-    and build = Dream.param req "build"
-    (* FIXME *)
-    and filepath = begin[@alert "-deprecated"] Dream.path req |> String.concat "/" end in
-    let if_none_match = Dream.header req "if-none-match" in
+    let datadir = Dream.global datadir_global req in
+    let _job_name = Dream.param "job" req
+    and build = Dream.param "build" req
+    and filepath = Dream.path req |> String.concat "/" in
+    let if_none_match = Dream.header "if-none-match" req in
     (* XXX: We don't check safety of [file]. This should be fine however since
      * we don't use [file] for the filesystem but is instead used as a key for
      * lookup in the data table of the 'full' file. *)
@@ -424,15 +196,15 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
     |> if_error ~status:`Not_Found "File not found" >>= fun filepath ->
     Dream.sql req (Model.build_artifact build filepath)
     |> if_error "Error getting build artifact" >>= fun file ->
-    let etag = Base64.encode_string file.Builder_db.sha256 in
+    let etag = Base64.encode_string (Cstruct.to_string file.Builder_db.sha256) in
     match if_none_match with
     | Some etag' when etag = etag' ->
       Dream.empty `Not_Modified |> Lwt_result.ok
     | _ ->
       Model.build_artifact_data datadir file
       |> if_error "Error getting build artifact"
-          ~log:(fun e -> Log.warn (fun m -> m "Error getting build artifact data for file %a: %a"
-                           Fpath.pp file.Builder_db.filepath
+          ~log:(fun e -> Log.warn (fun m -> m "Error getting build artifact data for file %a in %a: %a"
+                           Fpath.pp file.Builder_db.filepath Fpath.pp file.Builder_db.localpath
                            pp_error e)) >>= fun data ->
       let headers = [
         "Content-Type", mime_lookup file.Builder_db.filepath;
@@ -442,8 +214,9 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
   in
 
   let job_build_static_file (file : [< `Console | `Script ]) req =
-    let _job_name = Dream.param req "job"
-    and build = Dream.param req "build" in
+    let datadir = Dream.global datadir_global req in
+    let _job_name = Dream.param "job" req
+    and build = Dream.param "build" req in
     get_uuid build >>= fun build ->
     (match file with
     | `Console ->
@@ -453,52 +226,16 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
     |> if_error "Error getting data"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting script or console data for build %a: %a"
                                   Uuidm.pp build pp_error e)) >>= fun data ->
-    let headers = [ "Content-Type", "text/plain; charset=utf-8" ] in
+    let headers = [ "Content-Type", "text/plain" ] in
     Dream.respond ~headers data |> Lwt_result.ok
   in
 
-  let failed_builds req =
-    let platform = Dream.query req "platform" in
-    let to_int default s = Option.(value ~default (bind s int_of_string_opt)) in
-    let start = to_int 0 (Dream.query req "start") in
-    let count = to_int 10 (Dream.query req "count") in
-    Dream.sql req (Model.failed_builds ~start ~count platform)
-    |> if_error "Error getting data"
-       ~log:(fun e -> Log.warn (fun m -> m "Error getting failed builds: %a"
-                                  pp_error e)) >>= fun builds ->
-    Views.failed_builds ~start ~count builds
-    |> string_of_html |> Dream.html |> Lwt_result.ok
-  in
-
-  let job_build_targz req =
-    let _job_name = Dream.param req "job"
-    and build = Dream.param req "build" in
-    get_uuid build >>= fun build ->
-    Dream.sql req (Model.build build)
-    |> if_error "Error getting build" >>= fun (build_id, build) ->
-    Dream.sql req (Model.build_artifacts build_id)
-    |> if_error "Error getting artifacts" >>= fun artifacts ->
-    Ptime.diff build.finish Ptime.epoch |> Ptime.Span.to_int_s
-    |> Option.to_result ~none:(`Msg "bad finish time") |> Result.map Int64.of_int
-    |> Lwt.return |> if_error "Internal server error" >>= fun finish ->
-    Dream.stream ~headers:["Content-Type", "application/tar+gzip"]
-      (fun stream ->
-         let+ r = Dream_tar.targz_response datadir finish artifacts stream in
-         match r with
-         | Ok () -> ()
-         | Error _ ->
-           Log.warn (fun m -> m "error assembling gzipped tar archive");
-           ())
-    |> Lwt_result.ok
-  in
-
   let upload req =
     let* body = Dream.body req in
-    Builder.Asn.exec_of_str body |> Lwt.return
+    Builder.Asn.exec_of_cs (Cstruct.of_string body) |> Lwt.return
     |> if_error ~status:`Bad_Request "Bad request"
       ~log:(fun e ->
-          Log.warn (fun m -> m "Received bad builder ASN.1");
-          Log.debug (fun m -> m "Bad builder ASN.1: %a" pp_error e))
+        Log.warn (fun m -> m "Received bad builder ASN.1: %a" pp_error e))
     >>= fun ((({ name ; _ } : Builder.script_job), uuid, _, _, _, _, _) as exec) ->
     Log.debug (fun m -> m "Received build %a" pp_exec exec);
     Authorization.authorized req name
@@ -514,54 +251,54 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
         (Fmt.str "Build with same uuid exists: %a\n" Uuidm.pp uuid)
       |> Lwt_result.ok
     | false ->
-      (Lwt.return (Dream.field req Authorization.user_info_field |>
+      let datadir = Dream.global datadir_global req in
+      (Lwt.return (Dream.local Authorization.user_info_local req |>
                    Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) ->
-       Dream.sql req (Model.add_build ~datadir ~cachedir ~configdir user_id exec))
+       Dream.sql req (Model.add_build datadir user_id exec))
       |> if_error "Internal server error"
         ~log:(fun e -> Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e))
       >>= fun () -> Dream.respond "" |> Lwt_result.ok
   in
 
   let hash req =
-    Dream.query req "sha256" |> Option.to_result ~none:(`Msg "Missing sha256 query parameter")
-    |> Lwt.return
+    Dream.query "sha256" req |> Option.to_result ~none:(`Msg "Missing sha256 query parameter") |> Lwt.return
     |> if_error ~status:`Bad_Request "Bad request" >>= fun hash_hex ->
-    begin try Ohex.decode hash_hex |> Lwt_result.return
+    begin try Hex.to_cstruct (`Hex hash_hex) |> Lwt_result.return
       with Invalid_argument e -> Lwt_result.fail (`Msg ("Bad hex: " ^ e))
     end
     |> if_error ~status:`Bad_Request "Bad request" >>= fun hash ->
     Dream.sql req (Model.build_hash hash) >>= Model.not_found
     |> if_error "Internal server error" >>= fun (job_name, build) ->
     Dream.redirect req
-      (Link.Job_build.make ~job_name ~build:build.Builder_db.Build.uuid ())
+      (Fmt.str "/job/%s/build/%a/" job_name Uuidm.pp build.Builder_db.Build.uuid)
     |> Lwt_result.ok
   in
 
-  let compare_builds req =
-    let build_left = Dream.param req "build_left" in
-    let build_right = Dream.param req "build_right" in
+  let compare_opam req =
+    let datadir = Dream.global datadir_global req in
+    let build_left = Dream.param "build_left" req in
+    let build_right = Dream.param "build_right" req in
     get_uuid build_left >>= fun build_left ->
     get_uuid build_right >>= fun build_right ->
-    Dream.sql req (fun conn ->
-        Model.build build_left conn >>= fun (_id, build_left) ->
-        Model.build build_right conn >>= fun (_id, build_right) ->
-        Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "opam-switch") conn >>=
-        Model.build_artifact_data datadir >>= fun switch_left ->
-        Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "build-environment") conn >>=
-        Model.build_artifact_data datadir >>= fun build_env_left ->
-        Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "system-packages") conn >>=
-        Model.build_artifact_data datadir >>= fun system_packages_left ->
-        Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "opam-switch") conn >>=
-        Model.build_artifact_data datadir >>= fun switch_right ->
-        Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "build-environment") conn >>=
-        Model.build_artifact_data datadir >>= fun build_env_right ->
-        Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "system-packages") conn >>=
-        Model.build_artifact_data datadir >>= fun system_packages_right ->
-        Model.job_name build_left.job_id conn >>= fun job_left ->
-        Model.job_name build_right.job_id conn >|= fun job_right ->
-        (job_left, job_right, build_left, build_right,
-         switch_left, build_env_left, system_packages_left,
-         switch_right, build_env_right, system_packages_right))
+    (Dream.sql req (Model.build build_left) >>= fun (_id, build_left) ->
+     Dream.sql req (Model.build build_right) >>= fun (_id, build_right) ->
+     Dream.sql req (Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "opam-switch")) >>=
+     Model.build_artifact_data datadir >>= fun switch_left ->
+     Dream.sql req (Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "build-environment")) >>=
+     Model.build_artifact_data datadir >>= fun build_env_left ->
+     Dream.sql req (Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "system-packages")) >>=
+     Model.build_artifact_data datadir >>= fun system_packages_left ->
+     Dream.sql req (Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "opam-switch")) >>=
+     Model.build_artifact_data datadir >>= fun switch_right ->
+     Dream.sql req (Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "build-environment")) >>=
+     Model.build_artifact_data datadir >>= fun build_env_right ->
+     Dream.sql req (Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "system-packages")) >>=
+     Model.build_artifact_data datadir >>= fun system_packages_right ->
+     Dream.sql req (Model.job_name build_left.job_id) >>= fun job_left ->
+     Dream.sql req (Model.job_name build_right.job_id) >|= fun job_right ->
+     (job_left, job_right, build_left, build_right,
+      switch_left, build_env_left, system_packages_left,
+      switch_right, build_env_right, system_packages_right))
     |> if_error "Internal server error"
     >>= fun (job_left, job_right, build_left, build_right,
              switch_left, build_env_left, system_packages_left,
@@ -571,21 +308,16 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
     in
     let switch_left = OpamFile.SwitchExport.read_from_string switch_left
     and switch_right = OpamFile.SwitchExport.read_from_string switch_right in
-    let opam_diff = Opamdiff.compare switch_left switch_right in
-    Views.compare_builds
-      ~job_left ~job_right
-      ~build_left ~build_right
-      ~env_diff
-      ~pkg_diff
-      ~opam_diff
+    Opamdiff.compare switch_left switch_right
+    |> Views.compare_opam job_left job_right build_left build_right env_diff pkg_diff
     |> string_of_html |> Dream.html |> Lwt_result.ok
   in
 
   let upload_binary req =
-    let job = Dream.param req "job" in
-    let platform = Dream.param req "platform" in
+    let job = Dream.param "job" req in
+    let platform = Dream.param "platform" req in
     let binary_name =
-      Dream.query req "binary_name"
+      Dream.query "binary_name" req
       |> Option.map Fpath.of_string
       |> Option.value ~default:(Ok Fpath.(v job + "bin"))
     in
@@ -606,14 +338,15 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
         (Fmt.str "Build with same uuid exists: %a\n" Uuidm.pp uuid)
       |> Lwt_result.ok
     | false ->
+      let datadir = Dream.global datadir_global req in
       let exec =
         let now = Ptime_clock.now () in
         ({ Builder.name = job ; platform ; script = "" }, uuid, [], now, now, Builder.Exited 0,
          [ (Fpath.(v "bin" // binary_name), body) ])
       in
-      (Lwt.return (Dream.field req Authorization.user_info_field |>
+      (Lwt.return (Dream.local Authorization.user_info_local req |>
                    Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) ->
-       Dream.sql req (Model.add_build ~datadir ~cachedir ~configdir user_id exec))
+       Dream.sql req (Model.add_build datadir user_id exec))
       |> if_error "Internal server error"
         ~log:(fun e -> Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e))
       >>= fun () -> Dream.respond "" |> Lwt_result.ok
@@ -621,87 +354,23 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
 
   let w f req = or_error_response (f req) in
 
-  [
-    `Get, "/", (w (builds ~all:false ~filter_builds_later_than:expired_jobs));
-    `Get, "/job/:job", (w job);
-    `Get, "/job/:job/failed", (w job_with_failed);
-    `Get, "/job/:job/build/latest/**", (w redirect_latest);
-    `Get, "/job/:job/build/latest", (w redirect_latest_no_slash);
-    `Get, "/job/:job/build/:build", (w job_build);
-    `Get, "/job/:job/build/:build/f/**", (w job_build_file);
-    `Get, "/job/:job/build/:build/main-binary", (w redirect_main_binary);
-    `Get, "/job/:job/build/:build/viztreemap", (w @@ job_build_viz `Treemap);
-    `Get, "/job/:job/build/:build/vizdependencies", (w @@ job_build_viz `Dependencies);
-    `Get, "/job/:job/build/:build/script", (w (job_build_static_file `Script));
-    `Get, "/job/:job/build/:build/console", (w (job_build_static_file `Console));
-    `Get, "/job/:job/build/:build/all.tar.gz", (w job_build_targz);
-    `Get, "/failed-builds", (w failed_builds);
-    `Get, "/all-builds", (w (builds ~all:true));
-    `Get, "/hash", (w hash);
-    `Get, "/compare/:build_left/:build_right", (w compare_builds);
-    `Post, "/upload", (Authorization.authenticate (w upload));
-    `Post, "/job/:job/platform/:platform/upload", (Authorization.authenticate (w upload_binary));
+  (*
+  /developer <- front page with failed builds (indication)
+  /job/:job/developer(?platform=XX) <- job list with failed builds
+  /failed-builds(?platform=XX) <- all failed builds across all jobs (limit by the most recent 10)
+  *)
+
+  Dream.router [
+    Dream.get "/" (w builder);
+    Dream.get "/job/:job/" (w job);
+    Dream.get "/job/:job/build/latest/**" (w redirect_latest);
+    Dream.get "/job/:job/build/:build/" (w job_build);
+    Dream.get "/job/:job/build/:build/f/**" (w job_build_file);
+    Dream.get "/job/:job/build/:build/main-binary" (w redirect_main_binary);
+    Dream.get "/job/:job/build/:build/script" (w (job_build_static_file `Script));
+    Dream.get "/job/:job/build/:build/console" (w (job_build_static_file `Console));
+    Dream.get "/hash" (w hash);
+    Dream.get "/compare/:build_left/:build_right/opam-switch" (w compare_opam);
+    Dream.post "/upload" (Authorization.authenticate (w upload));
+    Dream.post "/job/:job/platform/:platform/upload" (Authorization.authenticate (w upload_binary));
   ]
-
-let to_dream_route = function
-  | `Get, path, handler -> Dream.get path handler
-  | `Post, path, handler -> Dream.post path handler
-
-let to_dream_routes l = List.map to_dream_route l
-
-let routeprefix_ignorelist_when_removing_trailing_slash = [
-  "/job/:job/build/:build/f";
-  "/job/:job/build/latest";
-]
-
-module Middleware = struct
-
-  let remove_trailing_url_slash : Dream.middleware =
-    fun handler req ->
-      let path = Dream.target req |> Utils.Path.of_url in
-      let is_ignored =
-        routeprefix_ignorelist_when_removing_trailing_slash
-        |> List.exists (Utils.Path.matches_dreamroute ~path)
-      in
-      if not (List.mem (Dream.method_ req) [`GET; `HEAD]) || is_ignored then
-        handler req
-      else match List.rev path with
-        | "" :: [] (* / *) -> handler req
-        | "" :: path (* /.../ *) ->
-          let path = List.rev path in
-          let queries = Dream.all_queries req in
-          let url = Utils.Path.to_url ~path ~queries in
-          (*> Note: See https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Location*)
-          Dream.redirect ~status:`Moved_Permanently req url
-        | _ (* /... *) -> handler req
-
-end
-
-let is_iframe_page ~req =
-  match Option.bind req (fun r -> Dream.header r "Sec-Fetch-Dest") with
-  | Some "iframe" -> true
-  | _ -> false
-
-let error_template error _debug_info suggested_response =
-  let target =
-    match error.Dream.request with
-    | None -> "?"
-    | Some req -> Dream.target req in
-  let referer =
-    Option.bind error.Dream.request (fun req -> Dream.header req "referer")
-  in
-  match Dream.status suggested_response with
-  | `Not_Found ->
-    let html =
-      if is_iframe_page ~req:error.Dream.request then
-        Views.viz_not_found
-      else
-        Views.page_not_found ~target ~referer
-    in
-    Dream.set_header suggested_response "Content-Type" Dream.text_html;
-    Dream.set_body suggested_response @@ string_of_html html;
-    Lwt.return suggested_response
-  | _ ->
-    Lwt.return suggested_response
-
-module Link = Link

lib/dream_tar.ml

@@ -1,92 +0,0 @@
-module High : sig
-  type t
-  type 'a s = 'a Lwt.t
-
-  external inj : 'a s -> ('a, t) Tar.io = "%identity"
-  external prj : ('a, t) Tar.io -> 'a s = "%identity"
-end = struct
-  type t
-  type 'a s = 'a Lwt.t
-
-  external inj : 'a -> 'b = "%identity"
-  external prj : 'a -> 'b = "%identity"
-end
-
-let value v = Tar.High (High.inj v)
-
-let ok_value v = value (Lwt_result.ok v)
-
-let run t stream =
-  let rec run : type a. (a, 'err, High.t) Tar.t -> (a, 'err) result Lwt.t =
-    function
-    | Tar.Write str ->
-      (* Can this not fail?!? Obviously, it can, but we never know?? *)
-      Lwt_result.ok (Dream.write stream str)
-    | Tar.Seek _ | Tar.Read _ | Tar.Really_read _ -> assert false
-    | Tar.Return value -> Lwt.return value
-    | Tar.High value -> High.prj value
-    | Tar.Bind (x, f) ->
-      let open Lwt_result.Syntax in
-      let* v = run x in
-      run (f v)
-  in
-  run t
-
-let header_of_file mod_time (file : Builder_db.file) =
-  let file_mode = if Fpath.is_prefix Fpath.(v "bin/") file.filepath then
-      0o755
-    else
-      0o644
-  in
-  Tar.Header.make ~file_mode ~mod_time (Fpath.to_string file.filepath) (Int64.of_int file.size)
-
-let contents datadir file : unit -> (string option, _, _) Tar.t =
-  let state = ref `Initial in
-  let dispenser () =
-    let ( let* ) = Tar.( let* ) in
-    let src = Fpath.append datadir (Model.artifact_path file) in
-    let* state' =
-      match !state with
-      | `Initial ->
-        let* fd = ok_value (Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string src)) in
-        let s = `Active fd in
-        state := s; Tar.return (Ok s)
-      | `Active _ | `Closed as s -> Tar.return (Ok s)
-    in
-    match state' with
-    | `Closed -> Tar.return (Ok None)
-    | `Active fd ->
-      let* data = ok_value (Lwt_io.read ~count:65536 fd) in
-      if String.length data = 0 then begin
-        state := `Closed;
-        let* () = ok_value (Lwt_io.close fd) in
-        Tar.return (Ok None)
-      end else
-        Tar.return (Ok (Some data))
-  in
-  dispenser
-
-let entries datadir finish files =
-  let files =
-    List.map (fun file ->
-        let hdr = header_of_file finish file in
-        let level = Some Tar.Header.Posix in
-        (level, hdr, contents datadir file)
-      )
-      files
-  in
-  let files = ref files in
-  fun () -> match !files with
-    | [] -> Tar.return (Ok None)
-    | f :: fs -> files := fs; Tar.return (Ok (Some f))
-
-let targz_response datadir finish files stream =
-  let entries : (_, _) Tar.entries = entries datadir finish files in
-  let global_hdr =
-    Tar.Header.Extended.make
-      ~comment:"Tar file produced by builder-web.%%VERSION_NUM%%"
-      ()
-  in
-  let finish32 = Int64.to_int32 finish in
-  Logs.err (fun m -> m "finished at %ld (%Ld)" finish32 finish);
-  run (Tar_gz.out_gzipped ~level:9 ~mtime:finish32 Gz.Unix (Tar.out ~global_hdr entries)) stream

lib/dune

@@ -1,5 +1,3 @@
 (library
  (name builder_web)
- (libraries builder builder_db dream tyxml bos duration ohex caqti-lwt
-   opamdiff ptime.clock.os cmarkit tar tar.gz tar-unix owee solo5-elftool decompress.de
-   decompress.gz uri digestif))
+ (libraries builder builder_db dream tyxml bos duration hex caqti-lwt opamdiff ptime.clock.os omd))

lib/link.ml

@@ -1,89 +0,0 @@
-let fpath_url_pp ppf f =
-  Fpath.segs f
-  |> List.map Uri.pct_encode
-  |> Fmt.(list ~sep:(any "/") string) ppf
-
-module Queries_aux = struct
-
-  let flatten = Option.value ~default:[]
-  
-  let add_raw url_str queries =
-    let uri = Uri.of_string url_str in
-    let uri = Uri.add_query_params uri queries in
-    Uri.to_string uri
-
-  let add ~encode_query queries url_str =
-    queries |> flatten |> List.map encode_query |> add_raw url_str
-  
-end
-
-let pctencode fmt str = Format.fprintf fmt "%s" (Uri.pct_encode str)
-
-module Root = struct
-
-  let make () = "/"
-
-end
-
-module Job = struct
-
-  let encode_query = function
-    | `Platform p -> "platform", [ p ]
-
-  let make ?queries ~job_name () =
-    Fmt.str "/job/%a" pctencode job_name
-    |> Queries_aux.add ~encode_query queries
-
-  let make_failed ?queries ~job_name () =
-    Fmt.str "/job/%a/failed" pctencode job_name
-    |> Queries_aux.add ~encode_query queries
-  
-end
-
-module Job_build = struct
-
-  let make ~job_name ~build () =
-    Fmt.str "/job/%a/build/%a"
-      pctencode job_name
-      Uuidm.pp build
-
-end
-
-module Job_build_artifact = struct
-
-  let encode_artifact = function
-    | `Main_binary -> "/main-binary"
-    | `Viz_treemap -> "/viztreemap"
-    | `Viz_dependencies -> "/vizdependencies"
-    | `Script -> "/script"
-    | `Console -> "/console"
-    | `All_targz -> "/all.tar.gz"
-    | `File f -> "/f/" ^ Fmt.to_to_string fpath_url_pp f
-
-  let make_from_string ~job_name ~build ~artifact () =
-    Fmt.str "/job/%a/build/%a%s"
-      pctencode job_name
-      Uuidm.pp build
-      artifact
-  
-  let make ~job_name ~build ~artifact () =
-    let artifact = encode_artifact artifact in
-    make_from_string ~job_name ~build ~artifact ()
-
-end
-
-module Compare_builds = struct
-
-  let make ~left ~right () =
-    Fmt.str "/compare/%a/%a"
-      Uuidm.pp left
-      Uuidm.pp right
-  
-end
-
-module Failed_builds = struct
-
-  let make ~count ~start () =
-    Fmt.str "/failed-builds?count=%d&start=%d" count start
-
-end

lib/model.ml

@@ -15,18 +15,10 @@ let pp_error ppf = function
     Caqti_error.pp ppf e
 
 let not_found = function
-  | None -> Lwt_result.fail `Not_found
+  | None -> Lwt.return (Error `Not_found :> (_, [> error ]) result)
   | Some v -> Lwt_result.return v
 
 let staging datadir = Fpath.(datadir / "_staging")
-let artifact_path artifact =
-  let sha256 = Ohex.encode artifact.Builder_db.sha256 in
-  (* NOTE: [sha256] is 64 characters when it's a hex sha256 checksum *)
-  (* NOTE: We add the prefix to reduce the number of files in a directory - a
-     workaround for inferior filesystems. We can easily revert this by changing
-     this function and adding a migration. *)
-  let prefix = String.sub sha256 0 2 in
-  Fpath.(v "_artifacts" / prefix / sha256)
 
 let read_file datadir filepath =
   let filepath = Fpath.(datadir // filepath) in
@@ -39,10 +31,10 @@ let read_file datadir filepath =
        Lwt_result.return data)
     (function
       | Unix.Unix_error (e, _, _) ->
-        Log.warn (fun m -> m "Error reading local file %a: %s"
+        Logs.warn (fun m -> m "Error reading local file %a: %s"
                       Fpath.pp filepath (Unix.error_message e));
         Lwt.return_error (`File_error filepath)
-      | e -> Lwt.reraise e)
+      | e -> Lwt.fail e)
 
 let build_artifact build filepath (module Db : CONN) =
   Db.find_opt Builder_db.Build_artifact.get_by_build_uuid (build, filepath)
@@ -52,16 +44,12 @@ let build_artifact_by_id id (module Db : CONN) =
   Db.find Builder_db.Build_artifact.get id
 
 let build_artifact_data datadir file =
-  read_file datadir (artifact_path file)
+  read_file datadir file.Builder_db.localpath
 
 let build_artifacts build (module Db : CONN) =
   Db.collect_list Builder_db.Build_artifact.get_all_by_build build >|=
   List.map snd
 
-let solo5_manifest datadir file =
-  let buf = Owee_buf.map_binary Fpath.(to_string (datadir // artifact_path file)) in
-  Solo5_elftool.query_manifest buf |> Result.to_option
-
 let platforms_of_job id (module Db : CONN) =
   Db.collect_list Builder_db.Build.get_platforms_for_job id
 
@@ -70,7 +58,7 @@ let build uuid (module Db : CONN) =
   not_found
 
 let build_with_main_binary job platform (module Db : CONN) =
-  Db.find_opt Builder_db.Build.get_latest_successful_with_binary (job, platform) >|=
+  Db.find_opt Builder_db.Build.get_latest (job, platform) >|=
   Option.map (fun (_id, build, file) -> (build, file))
 
 let build_hash hash (module Db : CONN) =
@@ -80,21 +68,18 @@ let build_exists uuid (module Db : CONN) =
   Db.find_opt Builder_db.Build.get_by_uuid uuid >|=
   Option.is_some
 
-let latest_successful_build job_id platform (module Db : CONN) =
-  Db.find_opt Builder_db.Build.get_latest_successful (job_id, platform)
+let latest_successful_build_uuid job_id platform (module Db : CONN) =
+  match platform with
+  | None ->
+    Db.find_opt Builder_db.Build.get_latest_successful_uuid job_id
+  | Some platform ->
+    Db.find_opt Builder_db.Build.get_latest_successful_uuid_by_platform (job_id, platform)
 
-let latest_successful_build_uuid job_id platform db =
-  latest_successful_build job_id platform db >|= fun build ->
-  Option.map (fun build -> build.Builder_db.Build.uuid) build
+let previous_successful_build_uuid id (module Db : CONN) =
+  Db.find_opt Builder_db.Build.get_previous_successful_uuid id
 
-let previous_successful_build_different_output id (module Db : CONN) =
-  Db.find_opt Builder_db.Build.get_previous_successful_different_output id
-
-let next_successful_build_different_output id (module Db : CONN) =
-  Db.find_opt Builder_db.Build.get_next_successful_different_output id
-
-let failed_builds ~start ~count platform (module Db : CONN) =
-  Db.collect_list Builder_db.Build.get_all_failed (start, count, platform)
+let next_successful_build_uuid id (module Db : CONN) =
+  Db.find_opt Builder_db.Build.get_next_successful_uuid id
 
 let builds_with_different_input_and_same_main_binary id (module Db : CONN) =
   Db.collect_list Builder_db.Build.get_different_input_same_output_input_ids id >>= fun ids ->
@@ -142,21 +127,25 @@ let job_and_readme job (module Db : CONN) =
   job_id, readme
 
 let builds_grouped_by_output job_id platform (module Db : CONN) =
-  Db.collect_list Builder_db.Build.get_all_artifact_sha (job_id, platform) >>= fun sha ->
+  (match platform with
+   | None ->
+     Db.find_opt Builder_db.Build.get_latest_failed job_id >>= fun failed ->
+     Db.collect_list Builder_db.Build.get_all_artifact_sha job_id >|= fun sha ->
+     (failed, sha)
+   | Some p ->
+     Db.find_opt Builder_db.Build.get_latest_failed_by_platform (job_id, p) >>= fun failed ->
+     Db.collect_list Builder_db.Build.get_all_artifact_sha_by_platform (job_id, p) >|= fun sha ->
+     (failed, sha)) >>= fun (failed, sha) ->
   Lwt_list.fold_left_s (fun acc hash ->
-    match acc with
-    | Error _ as e -> Lwt.return e
-    | Ok builds ->
-      Db.find Builder_db.Build.get_with_main_binary_by_hash hash >|= fun b ->
-      b :: builds)
-    (Ok []) sha >|= List.rev
-
-let builds_grouped_by_output_with_failed job_id platform ((module Db : CONN) as db) =
-  builds_grouped_by_output job_id platform db >>= fun builds ->
-  Db.collect_list Builder_db.Build.get_failed_builds (job_id, platform) >|= fun failed ->
-  let failed = List.map (fun b -> b, None) failed in
-  let cmp (a, _) (b, _) = Ptime.compare b.Builder_db.Build.start a.Builder_db.Build.start in
-  List.merge cmp builds failed
+     match acc with
+     | Error _ as e -> Lwt.return e
+     | Ok (fail, builds) ->
+       Db.find Builder_db.Build.get_with_main_binary_by_hash hash >|= fun (build, file) ->
+       match fail with
+       | Some f when Ptime.is_later ~than:build.Builder_db.Build.start f.Builder_db.Build.start -> None, (build, file) :: (f, None) :: builds
+       | x -> x, (build, file) :: builds)
+    (Ok (failed, [])) sha >|= fun (x, builds) ->
+  (match x with None -> builds | Some f -> (f, None) :: builds) |> List.rev
 
 let jobs_with_section_synopsis (module Db : CONN) =
   Db.collect_list Builder_db.Job.get_all_with_section_synopsis ()
@@ -204,42 +193,46 @@ let cleanup_staging datadir (module Db : Caqti_lwt.CONNECTION) =
        (cleanup_staged staged))
     stageds
 
-let save path data =
+let save file data =
   let open Lwt.Infix in
   Lwt.catch
     (fun () ->
-       Lwt_io.open_file ~mode:Lwt_io.Output (Fpath.to_string path) >>= fun oc ->
+       Lwt_io.open_file ~mode:Lwt_io.Output (Fpath.to_string file) >>= fun oc ->
        Lwt_io.write oc data >>= fun () ->
        Lwt_io.close oc
        |> Lwt_result.ok)
     (function
       | Unix.Unix_error (e, _, _) ->
           Lwt_result.fail (`Msg (Unix.error_message e))
-      | e -> Lwt.reraise e)
+      | e -> Lwt.fail e)
 
-let save_artifacts staging artifacts =
-  List.fold_left
-    (fun r (file, data) ->
-       r >>= fun () ->
-       let sha256 = Ohex.encode file.Builder_db.sha256 in
-       let destpath = Fpath.(staging / sha256) in
-       save destpath data)
-    (Lwt_result.return ())
-    artifacts
+let save_file dir staging (filepath, data) =
+  let size = String.length data in
+  let sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
+  let localpath = Fpath.append dir filepath in
+  let destpath = Fpath.append staging filepath in
+  Lwt_result.lift (Bos.OS.Dir.create (Fpath.parent destpath)) >>= fun _ ->
+  save destpath data >|= fun () ->
+  { Builder_db.filepath; localpath; sha256; size }
 
-let commit_files datadir staging_dir job_name uuid artifacts =
-  (* First we move the artifacts *)
+let save_files dir staging files =
   List.fold_left
-    (fun r artifact ->
-       r >>= fun () ->
-       let sha256 = Ohex.encode artifact.Builder_db.sha256 in
-       let src = Fpath.(staging_dir / sha256) in
-       let dest = Fpath.(datadir // artifact_path artifact) in
-       Lwt.return (Bos.OS.Dir.create (Fpath.parent dest)) >>= fun _created ->
-       Lwt.return (Bos.OS.Path.move ~force:true src dest))
-    (Lwt_result.return ())
-    artifacts >>= fun () ->
-  (* Now the staging dir only contains script & console *)
+    (fun r file ->
+       r >>= fun acc ->
+       save_file dir staging file >>= fun file ->
+       Lwt_result.return (file :: acc))
+    (Lwt_result.return [])
+    files
+
+let save_all staging_dir (job : Builder.script_job) uuid artifacts =
+  let build_dir = Fpath.(v job.Builder.name / Uuidm.to_string uuid) in
+  let output_dir = Fpath.(build_dir / "output")
+  and staging_output_dir = Fpath.(staging_dir / "output") in
+  Lwt.return (Bos.OS.Dir.create staging_output_dir) >>= fun _ ->
+  save_files output_dir staging_output_dir artifacts >>= fun artifacts ->
+  Lwt_result.return artifacts
+
+let commit_files datadir staging_dir job_name uuid =
   let job_dir = Fpath.(datadir / job_name) in
   let dest = Fpath.(job_dir / Uuidm.to_string uuid) in
   Lwt.return (Bos.OS.Dir.create job_dir) >>= fun _ ->
@@ -252,32 +245,12 @@ let infer_section_and_synopsis artifacts =
     | Some opam -> OpamFile.OPAM.synopsis opam, OpamFile.OPAM.descr_body opam
   in
   let infer_section switch root =
-    let root_pkg = root.OpamPackage.name in
-    let is_unikernel =
-      (* since mirage 4.2.0, the x-mirage-opam-lock-location is emitted *)
-      Option.value ~default:false
-        (Option.map (fun opam ->
-             Option.is_some (OpamFile.OPAM.extended opam "x-mirage-opam-lock-location" Fun.id))
-            (OpamPackage.Name.Map.find_opt root_pkg switch.OpamFile.SwitchExport.overlays))
-    in
-    let root_pkg_name = OpamPackage.Name.to_string root_pkg in
-    if is_unikernel || Astring.String.is_prefix ~affix:"mirage-unikernel-" root_pkg_name then
-      let metrics_influx =
-        let influx = OpamPackage.Name.of_string "metrics-influx" in
-        OpamPackage.Set.exists (fun p -> OpamPackage.Name.equal p.OpamPackage.name influx)
-          switch.OpamFile.SwitchExport.selections.OpamTypes.sel_installed
-      in
-      let mirage_monitoring =
-        let monitoring = OpamPackage.Name.of_string "mirage-monitoring" in
-        match OpamPackage.Name.Map.find_opt root_pkg switch.OpamFile.SwitchExport.overlays with
-        | None -> false
-        | Some opam ->
-          let depends = OpamFile.OPAM.depends opam in
-          OpamFormula.fold_left (fun acc (n', _) ->
-              acc || OpamPackage.Name.equal n' monitoring)
-            false depends
-      in
-      if metrics_influx || mirage_monitoring then
+    let root_pkg_name = OpamPackage.Name.to_string root.OpamPackage.name in
+    if Astring.String.is_prefix ~affix:"mirage-unikernel-" root_pkg_name then
+      let influx = OpamPackage.Name.of_string "metrics-influx" in
+      if OpamPackage.Set.exists (fun p -> OpamPackage.Name.equal p.OpamPackage.name influx)
+           switch.OpamFile.SwitchExport.selections.OpamTypes.sel_installed
+      then
         "Unikernels (with metrics reported to Influx)"
       else
         "Unikernels"
@@ -306,8 +279,7 @@ let compute_input_id artifacts =
     get_hash (Fpath.v "build-environment"),
     get_hash (Fpath.v "system-packages")
   with
-  | Some a, Some b, Some c ->
-    Some Digestif.SHA256.(to_raw_string (digestv_string [a;b;c]))
+  | Some a, Some b, Some c -> Some (Mirage_crypto.Hash.SHA256.digest (Cstruct.concat [a;b;c]))
   | _ -> None
 
 let save_console_and_script staging_dir job_name uuid console script =
@@ -329,29 +301,8 @@ let prepare_staging staging_dir =
   then Lwt_result.fail (`Msg "build directory already exists")
   else Lwt_result.return ()
 
-(* saving:
-   - for each artifact compute its sha256 checksum -- calling Lwt.pause in
-     between
-   - lookup artifact sha256 in the database and filter them out of the list: not_in_db
-   - mkdir -p _staging/uuid/
-   - save console & script to _staging/uuid/
-   - save each artifact in not_in_db as _staging/uuid/sha256
-   committing:
-   - for each artifact mv _staging/uuid/sha256 _artifacts/sha256
-     (or _artifacts/prefix(sha256)/sha256 where prefix(sha256) is the first two hex digits in sha256)
-   - now _staging/uuid only contains console & script so we mv _staging/uuid _staging/job/uuid
-   potential issues:
-   - race condition in uploading same artifact:
-     * if the artifact already exists in the database and thus filesystem then nothing is done
-     * if the artifact is added to the database and/or filesystem we atomically overwrite it
-   - input_id depends on a sort order?
-   *)
-
-
 let add_build
-    ~datadir
-    ~cachedir
-    ~configdir
+    datadir
     user_id
     ((job : Builder.script_job), uuid, console, start, finish, result, raw_artifacts)
     (module Db : CONN) =
@@ -359,7 +310,7 @@ let add_build
   let job_name = job.Builder.name in
   let staging_dir = Fpath.(staging datadir / Uuidm.to_string uuid) in
   let or_cleanup x =
-    Lwt_result.map_error (fun e ->
+    Lwt_result.map_err (fun e ->
         Bos.OS.Dir.delete ~recurse:true staging_dir
         |> Result.iter_error (fun e ->
             Log.err (fun m -> m "Failed to remove staging dir %a: %a"
@@ -368,35 +319,16 @@ let add_build
         e)
       x
   in
-  let not_interesting p =
-    String.equal (Fpath.basename p) "README.md" || String.equal (Fpath.get_ext p) ".build-hashes"
+  let artifacts_to_preserve =
+    let not_interesting p =
+      String.equal (Fpath.basename p) "README.md" || String.equal (Fpath.get_ext p) ".build-hashes"
+    in
+    List.filter (fun (p, _) -> not (not_interesting p)) raw_artifacts
   in
-  begin
-    List.fold_left
-      (fun r (filepath, data) ->
-         r >>= fun acc ->
-         if not_interesting filepath then
-           Lwt_result.return acc
-         else
-           let sha256 = Digestif.SHA256.(to_raw_string (digest_string data))
-           and size = String.length data in
-           Lwt_result.ok (Lwt.pause ()) >|= fun () ->
-           ({ filepath; sha256; size }, data) :: acc)
-      (Lwt_result.return [])
-      raw_artifacts
-  end >>= fun artifacts ->
   or_cleanup (prepare_staging staging_dir) >>= fun () ->
   or_cleanup (save_console_and_script staging_dir job_name uuid console job.Builder.script)
   >>= fun (console, script) ->
-  List.fold_left
-    (fun r ((f, _) as artifact) ->
-       r >>= fun acc ->
-       Db.find Builder_db.Build_artifact.exists f.sha256 >|= fun exists ->
-       if exists then acc else artifact :: acc)
-    (Lwt_result.return [])
-    artifacts >>= fun artifacts_to_save ->
-  or_cleanup (save_artifacts staging_dir artifacts_to_save) >>= fun () ->
-  let artifacts = List.map fst artifacts in
+  or_cleanup (save_all staging_dir job uuid artifacts_to_preserve) >>= fun artifacts ->
   let r =
     Db.start () >>= fun () ->
     Db.exec Job.try_add job_name >>= fun () ->
@@ -444,82 +376,31 @@ let add_build
      match readme, readme_anywhere with
      | None, None -> Lwt_result.return ()
      | Some (_, data), _ | None, Some (_, data) -> add_or_update readme_id data) >>= fun () ->
-    (match List.partition (fun p -> Fpath.(is_prefix (v "bin/") p.filepath)) artifacts with
-     | [ main_binary ], other_artifacts ->
-       Db.exec Build_artifact.add (main_binary, id) >>= fun () ->
-       Db.find Builder_db.last_insert_rowid () >>= fun main_binary_id ->
-       Db.exec Build.set_main_binary (id, main_binary_id) >|= fun () ->
-       Some main_binary, other_artifacts
-     | [], _ ->
-       Log.debug (fun m -> m "Zero binaries for build %a" Uuidm.pp uuid);
-       Lwt_result.return (None, artifacts)
-     | xs, _ ->
-       Log.warn (fun m -> m "Multiple binaries for build %a: %a" Uuidm.pp uuid
-                    Fmt.(list ~sep:(any ",") Fpath.pp)
-                    (List.map (fun a -> a.filepath) xs));
-       Lwt_result.return (None, artifacts)) >>= fun (main_binary, remaining_artifacts_to_add) ->
     List.fold_left
       (fun r file ->
          r >>= fun () ->
          Db.exec Build_artifact.add (file, id))
       (Lwt_result.return ())
-      remaining_artifacts_to_add >>= fun () ->
-    commit_files datadir staging_dir job_name uuid (List.map fst artifacts_to_save) >>= fun () ->
-    Db.commit () >|= fun () ->
-    main_binary
+      artifacts >>= fun () ->
+    Db.collect_list Build_artifact.get_all_by_build id >>= fun artifacts ->
+    (match List.filter (fun (_, p) -> Fpath.(is_prefix (v "bin/") p.filepath)) artifacts with
+     | [ (build_artifact_id, _) ] -> Db.exec Build.set_main_binary (id, build_artifact_id)
+     | [] ->
+       Log.debug (fun m -> m "Zero binaries for build %a" Uuidm.pp uuid);
+       Lwt_result.return ()
+     | xs ->
+       Log.warn (fun m -> m "Multiple binaries for build %a: %a" Uuidm.pp uuid
+                    Fmt.(list ~sep:(any ",") Fpath.pp)
+                    (List.map (fun (_, a) -> a.filepath) xs));
+       Lwt_result.return ()) >>= fun () ->
+    Db.commit () >>= fun () ->
+    commit_files datadir staging_dir job_name uuid
   in
-  Lwt_result.bind_lwt_error (or_cleanup r)
+  Lwt_result.bind_lwt_err (or_cleanup r)
     (fun e ->
        Db.rollback ()
        |> Lwt.map (fun r ->
            Result.iter_error
              (fun e' -> Log.err (fun m -> m "Failed rollback: %a" Caqti_error.pp e'))
              r;
-           e)) >>= function
-  | None -> Lwt.return (Ok ())
-  | Some main_binary ->
-    let time =
-      let (y, m, d), ((hh, mm, ss), _) = Ptime.to_date_time start in
-      Printf.sprintf "%04d%02d%02d%02d%02d%02d" y m d hh mm ss
-    and uuid = Uuidm.to_string uuid
-    and job = job.name
-    and platform = job.platform
-    and sha256 = Ohex.encode main_binary.sha256
-    in
-    let fp_str p = Fpath.(to_string (datadir // p)) in
-    let args =
-      String.concat " "
-        (List.map (fun s -> "\"" ^ String.escaped s ^ "\"")
-           [ "--build-time=" ^ time ; "--sha256=" ^ sha256 ; "--job=" ^ job ;
-             "--uuid=" ^ uuid ; "--platform=" ^ platform ;
-             "--cache-dir=" ^ Fpath.to_string cachedir ;
-             "--data-dir=" ^ Fpath.to_string datadir ;
-             "--main-binary-filepath=" ^ Fpath.to_string main_binary.filepath ;
-             fp_str Fpath.(datadir // artifact_path main_binary) ])
-    in
-    Log.debug (fun m -> m "executing hooks with %s" args);
-    let dir = Fpath.(configdir / "upload-hooks") in
-    (try
-       Lwt.return (Ok (Some (Unix.opendir (Fpath.to_string dir))))
-     with
-       Unix.Unix_error _ -> Lwt.return (Ok None)) >>= function
-    | None -> Lwt.return (Ok ())
-    | Some dh ->
-      try
-        let is_executable file =
-          let st = Unix.stat (Fpath.to_string file) in
-          st.Unix.st_perm land 0o111 = 0o111 &&
-          st.Unix.st_kind = Unix.S_REG
-        in
-        let rec go () =
-          let next_file = Unix.readdir dh in
-          let file = Fpath.(dir / next_file) in
-          if is_executable file && Fpath.has_ext ".sh" file then
-            ignore (Sys.command (Fpath.to_string file ^ " " ^ args ^ " &"));
-          go ()
-        in
-        go ()
-      with
-      | End_of_file ->
-        Unix.closedir dh;
-        Lwt.return (Ok ())
+           e))

lib/model.mli

@@ -2,10 +2,9 @@ type error = [ Caqti_error.call_or_retrieve | `Not_found | `File_error of Fpath.
 
 val pp_error : Format.formatter -> error -> unit
 
-val not_found : 'a option -> ('a, [> `Not_found ]) result Lwt.t
+val not_found : 'a option -> ('a, [> error ]) result Lwt.t
 
 val staging : Fpath.t -> Fpath.t
-val artifact_path : Builder_db.file -> Fpath.t
 
 val cleanup_staging : Fpath.t -> Caqti_lwt.connection ->
   (unit, [> `Msg of string ]) result Lwt.t
@@ -22,8 +21,6 @@ val build_artifact_data : Fpath.t -> Builder_db.file ->
 val build_artifacts : [`build] Builder_db.id -> Caqti_lwt.connection ->
   (Builder_db.file list, [> Caqti_error.call_or_retrieve ]) result Lwt.t
 
-val solo5_manifest : Fpath.t -> Builder_db.file -> Solo5_elftool.mft option
-
 val platforms_of_job : [`job] Builder_db.id -> Caqti_lwt.connection ->
   (string list, [> Caqti_error.call_or_retrieve ]) result Lwt.t
 
@@ -31,9 +28,9 @@ val build : Uuidm.t -> Caqti_lwt.connection ->
   ([`build] Builder_db.id * Builder_db.Build.t, [> error ]) result Lwt.t
 
 val build_with_main_binary : [`job] Builder_db.id -> string -> Caqti_lwt.connection ->
-  ((Builder_db.Build.t * Builder_db.file) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
+  ((Builder_db.Build.t * Builder_db.file option) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
 
-val build_hash : string -> Caqti_lwt.connection ->
+val build_hash : Cstruct.t -> Caqti_lwt.connection ->
   ((string * Builder_db.Build.t) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
 
 val build_exists : Uuidm.t -> Caqti_lwt.connection ->
@@ -42,17 +39,11 @@ val build_exists : Uuidm.t -> Caqti_lwt.connection ->
 val latest_successful_build_uuid : [`job] Builder_db.id -> string option -> Caqti_lwt.connection ->
   (Uuidm.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
 
-val latest_successful_build : [`job] Builder_db.id -> string option -> Caqti_lwt.connection ->
-  (Builder_db.Build.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
+val previous_successful_build_uuid : [`build] Builder_db.id -> Caqti_lwt.connection ->
+  (Uuidm.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
 
-val previous_successful_build_different_output : [`build] Builder_db.id -> Caqti_lwt.connection ->
-  (Builder_db.Build.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
-
-val next_successful_build_different_output : [`build] Builder_db.id -> Caqti_lwt.connection ->
-  (Builder_db.Build.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
-
-val failed_builds : start:int -> count:int -> string option -> Caqti_lwt.connection ->
-  ((string * Builder_db.Build.t) list, [> Caqti_error.call_or_retrieve ]) result Lwt.t
+val next_successful_build_uuid : [`build] Builder_db.id -> Caqti_lwt.connection ->
+  (Uuidm.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
 
 val builds_with_different_input_and_same_main_binary : [`build] Builder_db.id -> Caqti_lwt.connection ->
   (Builder_db.Build.t list, [> Caqti_error.call_or_retrieve ]) result Lwt.t
@@ -78,9 +69,6 @@ val job_and_readme : string -> Caqti_lwt.connection ->
 val builds_grouped_by_output : [`job] Builder_db.id -> string option -> Caqti_lwt.connection ->
   ((Builder_db.Build.t * Builder_db.file option) list, [> error ]) result Lwt.t
 
-val builds_grouped_by_output_with_failed : [`job] Builder_db.id -> string option -> Caqti_lwt.connection ->
-  ((Builder_db.Build.t * Builder_db.file option) list, [> error ]) result Lwt.t
-
 val job_id : string -> Caqti_lwt.connection ->
   ([`job] Builder_db.id option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
 
@@ -96,9 +84,7 @@ val user : string -> Caqti_lwt.connection ->
 val authorized : [`user] Builder_db.id -> string -> Caqti_lwt.connection -> (unit, [> Caqti_error.call_or_retrieve | `Msg of string ]) result Lwt.t
 
 val add_build :
-  datadir:Fpath.t ->
-  cachedir:Fpath.t ->
-  configdir:Fpath.t ->
+  Fpath.t ->
   [`user] Builder_db.id ->
   (Builder.script_job * Uuidm.t * (int * string) list * Ptime.t * Ptime.t *
    Builder.execution_result * (Fpath.t * string) list) ->

lib/utils.ml

@@ -10,7 +10,7 @@ let diff_map a b =
   let diff a b =
     String_map.fold (fun k v acc ->
       if not (String_map.mem k b) then (k, v) :: acc else acc)
-      a [] |> List.rev
+      a []
   in
   let added = diff b a
   and removed = diff a b
@@ -19,7 +19,7 @@ let diff_map a b =
       match String_map.find_opt k b with
       | None -> acc
       | Some v' -> if String.equal v v' then acc else (k, v, v') :: acc)
-    a [] |> List.rev
+    a []
   in
   (added, removed, changed)
 
@@ -44,64 +44,3 @@ let compare_pkgs p1 p2 =
     String_map.empty (Astring.String.cuts ~sep:"\n" p)
   in
   diff_map (parse_pkgs p1) (parse_pkgs p2)
-
-let md_to_html ?adjust_heading ?(safe = true) data =
-  let open Cmarkit in
-  let doc = Doc.of_string ~strict:false ~heading_auto_ids:true data in
-  let doc =
-    Option.fold ~none:doc
-      ~some:(fun lvl ->
-          let block _m = function
-            | Block.Heading (h, meta) ->
-              let open Block.Heading in
-              let level = level h
-              and id = id h
-              and layout = layout h
-              and inline = inline h
-              in
-              let h' = make ?id ~layout ~level:(level + lvl) inline in
-              Mapper.ret (Block.Heading (h', meta))
-            | Block.Blocks _ -> Mapper.default
-            | x -> Mapper.ret x
-          in
-          let mapper = Mapper.make ~block () in
-          Mapper.map_doc mapper doc)
-      adjust_heading
-  in
-  Cmarkit_html.of_doc ~safe doc
-
-module Path = struct
-
-  let to_url ~path ~queries =
-    let path = match path with
-      | "" :: [] -> "/"
-      | path -> "/" ^ String.concat "/" path
-    in
-    let query = queries |> List.map (fun (k, v) -> k, [v]) in
-    Uri.make ~path ~query () |> Uri.to_string
-
-  (* Like Dream.path in 1.0.0~alpha2 but on Dream.target *)
-  let of_url uri_str =
-    let path_str = uri_str |> Uri.of_string |> Uri.path in
-    match String.split_on_char '/' path_str with
-    | "" :: (_ :: _ as tail) -> tail
-    | path -> path
-
-  let matches_dreamroute ~path dreamroute =
-    let is_match path_elem dpath_elem =
-      (dpath_elem |> String.starts_with ~prefix:":")
-      || path_elem = dpath_elem
-    in
-    let rec aux path dreampath =
-      match path, dreampath with
-      | []     , _ :: _   -> false   (*length path < length dreampath*)
-      | _      , []       -> true    (*length path >= length dreampath *)
-      | _ :: _ , "" :: [] -> true    (*dreampath ends in '/'*)
-      | p_elem :: path, dp_elem :: dreampath ->
-        is_match p_elem dp_elem
-        && aux path dreampath
-    in
-    let dreampath = dreamroute |> of_url in
-    aux path dreampath
-
-end

opamdiff/opamdiff.ml

@@ -1,156 +1,13 @@
 module Set = OpamPackage.Set
 
+type package = OpamPackage.t
+
 let packages (switch : OpamFile.SwitchExport.t) =
   assert (Set.cardinal switch.selections.sel_pinned = 0);
   assert (Set.cardinal switch.selections.sel_compiler = 0);
   assert (Set.subset switch.selections.sel_roots switch.selections.sel_installed);
   switch.selections.sel_installed
 
-let duniverse_dir = "x-opam-monorepo-duniverse-dirs"
-
-module M = Map.Make(String)
-
-let duniverse_dirs_data =
-  (* the representation in the file is [ URL DIR [ HASH* ] ] *)
-  let open OpamParserTypes.FullPos in
-  let ( let* ) = Result.bind in
-  let string ~ctx = function
-    | { pelem = String s ; _ } -> Ok s
-    | _ -> Error (`Msg ("couldn't find a string " ^ ctx))
-  in
-  let extract_data = function
-    | { pelem = List { pelem = [ url ; dir ; hashes ] ; _ } ; _ } ->
-      let* url = string ~ctx:"url" url in
-      let* hashes =
-        match hashes with
-        | { pelem = List { pelem = hashes ; _ } ; _ } ->
-          List.fold_left (fun acc hash ->
-              let* acc = acc in
-              let* hash = string ~ctx:"hash" hash in
-              let* h = match OpamHash.of_string_opt hash with
-                | Some h -> Ok OpamHash.(kind h, contents h)
-                | None -> Error (`Msg ("couldn't decode opam hash in " ^ hash))
-              in
-              Ok (h :: acc))
-            (Ok []) hashes
-        | _ -> Error (`Msg "couldn't decode hashes")
-      in
-      let* dir = string ~ctx:"directory" dir in
-      Ok (url, dir, List.rev hashes)
-    | { pelem = List { pelem = [ url ; dir ] ; _ } ; _ } ->
-      let* url = string ~ctx:"url" url in
-      let* dir = string ~ctx:"directory" dir in
-      Ok (url, dir, [])
-    | _ -> Error (`Msg "expected a list of URL, DIR, [HASHES]")
-  in
-  function
-  | { pelem = List { pelem = lbody ; _ } ; _ } ->
-    List.fold_left (fun acc v ->
-        let* acc = acc in
-        let* (url, dir, hashes) = extract_data v in
-        Ok (M.add dir (url, hashes) acc))
-      (Ok M.empty) lbody
-  | _ -> Error (`Msg "expected a list or a nested list")
-
-let duniverse (switch : OpamFile.SwitchExport.t) =
-  let root = switch.OpamFile.SwitchExport.selections.OpamTypes.sel_roots in
-  if OpamPackage.Set.cardinal root = 1 then
-    let root = OpamPackage.Set.choose root in
-    match OpamPackage.(Name.Map.find_opt root.name switch.OpamFile.SwitchExport.overlays) with
-    | None -> Error (`Msg "opam switch export doesn't contain the main package")
-    | Some opam ->
-      match OpamFile.OPAM.extended opam duniverse_dir duniverse_dirs_data with
-      | None -> Ok None
-      | Some Error e -> Error e
-      | Some Ok v -> Ok (Some v)
-  else
-    Error (`Msg "not a single root package found in opam switch export")
-
-type duniverse_diff = {
-  name : string ;
-  urls : string * string option ;
-  hash : (OpamHash.kind * string option * string option) list ;
-}
-
-let pp_duniverse_diff ppf { name ; urls ; hash } =
-  let opt_hash = Option.value ~default:"NONE" in
-  Format.fprintf ppf "%s (%s%s) %s"
-    name
-    (fst urls)
-    (Option.fold ~none:"" ~some:(fun url -> "->" ^ url) (snd urls))
-    (String.concat ", " (List.map (fun (h, l, r) ->
-         OpamHash.string_of_kind h ^ " " ^ opt_hash l ^ "->" ^ opt_hash r) hash))
-
-let pp_duniverse_dir ppf (dir, url) =
-  Format.fprintf ppf "%s (%s)" dir url
-
-let duniverse_diff l r =
-  let l = Option.value l ~default:M.empty
-  and r = Option.value r ~default:M.empty
-  in
-  let keys_l_only = ref [] and keys_r_only = ref [] and diff = ref [] in
-  let equal_hashes l r =
-    (* l and r are lists of pairs, with the hash kind and its value *)
-    (* for a git remote, the hashes are empty lists *)
-    (match l with [] -> false | _ -> true) &&
-    (match r with [] -> false | _ -> true) &&
-    List.for_all (fun (h, v) ->
-        match List.assoc_opt h r with
-        | None -> false
-        | Some v' -> String.equal v v')
-      l &&
-    List.for_all (fun (h, v) ->
-        match List.assoc_opt h l with
-        | None -> false
-        | Some v' -> String.equal v v')
-      r
-  in
-  let _ =
-    M.merge (fun key l r ->
-        match l, r with
-        | None, Some _ -> keys_r_only := key :: !keys_r_only; None
-        | Some _, None -> keys_l_only := key :: !keys_l_only; None
-        | None, None -> None
-        | Some (_, l), Some (_, r) when equal_hashes l r -> None
-        | Some (url1, []), Some (url2, []) when String.equal url1 url2 -> None
-        | Some l, Some r -> diff := (key, l, r) :: !diff; None)
-      l r
-  in
-  let dir_only keys map =
-    let only =
-      M.filter (fun k _ -> List.mem k keys) map |> M.bindings
-    in
-    List.map (fun (key, (url, _)) -> key, url) only
-  in
-  let l_only = dir_only !keys_l_only l
-  and r_only = dir_only !keys_r_only r
-  and diff =
-    List.map (fun (name, (url_l, hashes_l), (url_r, hashes_r)) ->
-        let urls =
-          if String.equal url_l url_r then url_l, None else url_l, Some url_r
-        in
-        let hash =
-          List.fold_left (fun acc (h, v) ->
-              match List.assoc_opt h hashes_r with
-              | None -> (h, Some v, None) :: acc
-              | Some v' ->
-                if String.equal v v' then
-                  acc
-                else
-                  (h, Some v, Some v') :: acc)
-            [] hashes_l
-        in
-        let hash = List.fold_left (fun acc (h', v') ->
-            match List.assoc_opt h' hashes_l with
-            | None -> (h', None, Some v') :: acc
-            | Some _ -> acc)
-            hash hashes_r
-        in
-        { name ; urls ; hash })
-      !diff
-  in
-  l_only, r_only, diff
-
 type version_diff = {
   name : OpamPackage.Name.t;
   version_left : OpamPackage.Version.t;
@@ -245,12 +102,12 @@ let compare left right =
       l
   in
   let same_version = Set.inter packages_left packages_right in
-  let opam_diff =
-    Set.filter
+  let (same, opam_diff) =
+    Set.partition
       (fun p ->
          let find = OpamPackage.Name.Map.find p.name in
          let opam_left = find left.overlays and opam_right = find right.overlays in
-         not (OpamFile.OPAM.effectively_equal opam_left opam_right))
+         OpamFile.OPAM.effectively_equal opam_left opam_right)
       same_version
   and version_diff =
     List.filter_map (fun p1 ->
@@ -269,9 +126,4 @@ let compare left right =
   and right_pkgs = diff packages_right packages_left
   in
   let opam_diff = detailed_opam_diffs left right opam_diff in
-  let duniverse_ret =
-    match duniverse left, duniverse right with
-    | Ok l, Ok r -> Ok (duniverse_diff l r)
-    | Error _ as e, _ | _, (Error _ as e) -> e
-  in
-  (opam_diff, version_diff, left_pkgs, right_pkgs, duniverse_ret)
+  (same, opam_diff, version_diff, left_pkgs, right_pkgs)

opamdiff/opamdiff.mli

@@ -1,39 +0,0 @@
-type opam_diff = {
-  pkg : OpamPackage.t ;
-  build : (OpamTypes.command list * OpamTypes.command list) option ;
-  install : (OpamTypes.command list * OpamTypes.command list) option ;
-  url : (OpamFile.URL.t option * OpamFile.URL.t option) option ;
-  otherwise_equal : bool ;
-}
-
-type version_diff = {
-  name : OpamPackage.Name.t;
-  version_left : OpamPackage.Version.t;
-  version_right : OpamPackage.Version.t;
-}
-
-type duniverse_diff = {
-  name : string ;
-  urls : string * string option ;
-  hash : (OpamHash.kind * string option * string option) list ;
-}
-
-val pp_opampackage : Format.formatter -> OpamPackage.t -> unit
-
-val pp_version_diff : Format.formatter -> version_diff -> unit
-
-val pp_duniverse_diff : Format.formatter -> duniverse_diff -> unit
-
-val pp_duniverse_dir : Format.formatter -> string * string -> unit
-
-val pp_opam_diff : Format.formatter -> opam_diff -> unit
-
-val commands_to_strings : OpamTypes.command list * OpamTypes.command list -> string list * string list
-
-val opt_url_to_string : OpamFile.URL.t option * OpamFile.URL.t option -> string * string
-
-
-val compare: OpamFile.SwitchExport.t ->
-  OpamFile.SwitchExport.t ->
-  opam_diff list * version_diff list * OpamPackage.Set.t * OpamPackage.Set.t * ((string * string) list * (string * string) list * duniverse_diff list, [> `Msg of string ]) result
-

packaging/FreeBSD-repo.sh

@@ -1,137 +0,0 @@
-#!/bin/sh
-
-set -ex
-
-prog_NAME=$(basename "${0}")
-
-warn()
-{
-    echo "${prog_NAME}: WARN: $*"
-}
-
-err()
-{
-    echo "${prog_NAME}: ERROR: $*" 1>&2
-}
-
-die()
-{
-    echo "${prog_NAME}: ERROR: $*" 1>&2
-    exit 1
-}
-
-usage()
-{
-    cat <<EOM 1>&2
-usage: ${prog_NAME} [ OPTIONS ] FILE
-Updates a FreeBSD package repository
-Options:
-    --build-time=STRING
-        Build timestamp (used for the version of the package).
-    --sha256=STRING
-        Hex encoded SHA256 digest of the main binary.
-    --job=STRING
-        Job name that was built.
-    --main-binary-filepath=STRING
-        The file path of the main binary.
-EOM
-    exit 1
-}
-
-BUILD_TIME=
-SHA=
-JOB=
-FILEPATH=
-
-while [ $# -gt 1 ]; do
-    OPT="$1"
-
-    case "${OPT}" in
-        --build-time=*)
-            BUILD_TIME="${OPT##*=}"
-            ;;
-        --sha256=*)
-            SHA="${OPT##*=}"
-            ;;
-        --job=*)
-            JOB="${OPT##*=}"
-            ;;
-        --main-binary-filepath=*)
-            FILEPATH="${OPT##*=}"
-            ;;
-        --*)
-            warn "Ignoring unknown option: '${OPT}'"
-            ;;
-        *)
-            err "Unknown option: '${OPT}'"
-            usage
-            ;;
-    esac
-    shift
-done
-
-[ -z "${BUILD_TIME}" ] && die "The --build-time option must be specified"
-[ -z "${SHA}" ] && die "The --sha256 option must be specified"
-[ -z "${JOB}" ] && die "The --job option must be specified"
-[ -z "${FILEPATH}" ] && die "The --main-binary-filepath option must be specified"
-
-FILENAME="${1}"
-
-: "${REPO:="/usr/local/www/pkg"}"
-: "${REPO_KEY:="/usr/local/etc/builder-web/repo.key"}"
-
-if [ "$(basename "${FILEPATH}" .pkg)" = "$(basename "${FILEPATH}")" ]; then
-    echo "Not a FreeBSD package"
-    exit 0
-fi
-
-if ls "${REPO}"/*/All/"${JOB}"-*."${SHA}".pkg > /dev/null; then
-    echo "Same hash already present, nothing to do"
-    exit 0
-fi
-
-TMP=$(mktemp -d -t repak)
-MANIFEST="${TMP}/+MANIFEST"
-TMPMANIFEST="${MANIFEST}.tmp"
-
-cleanup () {
-    rm -rf "${TMP}"
-}
-
-trap cleanup EXIT
-
-PKG_ROOT="${TMP}/pkg"
-
-tar x -C "${TMP}" -f "${FILENAME}"
-mkdir "${PKG_ROOT}"
-mv "${TMP}/usr" "${PKG_ROOT}"
-
-VERSION=$(jq -r '.version' "${MANIFEST}")
-# if we've a tagged version (1.5.0), append the number of commits and a dummy hash
-VERSION_GOOD=$(echo $VERSION | grep -c '^[0-9]\+\.[0-9]\+\.[0-9]\+$') || true
-VERSION_WITH_COMMIT=$(echo $VERSION | grep -c '^[0-9]\+\.[0-9]\+\.[0-9]\+\.[0-9]\+\.g[0-9a-fA-f]\+$') || true
-if [ $VERSION_GOOD -eq 0 -a $VERSION_WITH_COMMIT -eq 0 ]; then
-    die "version does not conform to (MAJOR.MINOR.PATCH[.#NUM_COMMITS.g<HASH>])"
-fi
-if [ $VERSION_WITH_COMMIT -eq 0 ]; then
-    VERSION="${VERSION}.0.g0000000"
-fi
-
-NAME=$(jq -r '.name' "${MANIFEST}")
-FULL_VERSION="${VERSION}.${BUILD_TIME}.${SHA}"
-
-jq -ca ".version=\"$FULL_VERSION\"" "${MANIFEST}" > "${TMPMANIFEST}"
-mv "${TMPMANIFEST}" "${MANIFEST}"
-
-ABI=$(jq -r '.abi' "${MANIFEST}")
-REPO_DIR="${REPO}/${ABI}"
-PKG_DIR="${REPO_DIR}/All"
-
-# to avoid races, first create the package in temporary directory
-# and then move it before recreating the index
-pkg create -r "${PKG_ROOT}" -m "${MANIFEST}" -o "${TMP}"
-mkdir -p "${PKG_DIR}"
-rm -f "${PKG_DIR}"/"${NAME}"-*.pkg
-mv "${TMP}/${NAME}-${FULL_VERSION}.pkg" "${PKG_DIR}"
-
-pkg repo "${REPO_DIR}" "${REPO_KEY}"

packaging/FreeBSD/MANIFEST

@@ -1,8 +1,8 @@
-name:         builder-web
+name:         builder_web
 version:      %%VERSION_NUM%%
-origin:	      local/builder-web
+origin:	      local/builder_web
 comment:      Builder web service
-www:	      https://git.robur.coop/robur/builder-web
+www:	      https://git.robur.io/robur/builder-web
 maintainer:   Robur <team@robur.coop>
 prefix:	      /usr/local
 licenselogic: single
@@ -18,56 +18,9 @@ deps {
     },
     sqlite3 {
         origin = "databases/sqlite3";
-    },
-    opam-graph {
-        origin = "local/opam-graph";
-    },
-    modulectomy {
-        origin = "local/modulectomy";
     }
 }
-scripts : {
-    pre-install = <<EOD
-if [ -n "${PKG_ROOTDIR}" ] && [ "${PKG_ROOTDIR}" != "/" ]; then
-  PW="/usr/sbin/pw -R ${PKG_ROOTDIR}"
-else
-  PW=/usr/sbin/pw
-fi
-echo "===> Creating groups."
-if ! ${PW} groupshow builder >/dev/null 2>&1; then
-  echo "Creating group 'builder' with gid '497'."
-  ${PW} groupadd builder -g 497
-else
-  echo "Using existing group 'builder'."
-fi
-echo "===> Creating users"
-if ! ${PW} usershow builder >/dev/null 2>&1; then
-  echo "Creating user 'builder' with uid '497'."
-  ${PW} useradd builder -u 497 -g 497  -c "builder daemon" -d /nonexistent -s /usr/sbin/nologin
-else
-  echo "Using existing user 'builder'."
-fi
-EOD;
-    post-install = <<EOD
-mkdir -p -m 700 /var/db/builder-web
-chown builder:builder /var/db/builder-web
 
-EOD;
-    post-deinstall = <<EOD
-if [ -n "${PKG_ROOTDIR}" ] && [ "${PKG_ROOTDIR}" != "/" ]; then
-  PW="/usr/sbin/pw -R ${PKG_ROOTDIR}"
-else
-  PW=/usr/sbin/pw
-fi
-if ${PW} usershow builder >/dev/null 2>&1; then
-  echo "==> You should manually remove the \"builder\" user. "
-fi
-if ${PW} groupshow builder >/dev/null 2>&1; then
-  echo "==> You should manually remove the \"builder\" group "
-fi
-EOD;
-
-}
 desc = <<EOD
 A web server serving and accepting reproducible builds
 

packaging/FreeBSD/create_package.sh

@@ -18,35 +18,25 @@ rootdir=$tmpd/rootdir
 sbindir=$rootdir/usr/local/sbin
 rcdir=$rootdir/usr/local/etc/rc.d
 libexecdir=$rootdir/usr/local/libexec
-sharedir=$rootdir/usr/local/share/builder-web
-confdir=$rootdir/usr/local/etc/builder-web
 
 trap 'rm -rf $tmpd' 0 INT EXIT
 
-mkdir -p "$sbindir" "$libexecdir" "$rcdir" "$sharedir" "$confdir/upload-hooks"
+mkdir -p "$sbindir" "$libexecdir" "$rcdir"
 
 # stage service scripts
-install -U "$pdir/rc.d/builder_web" "$rcdir/builder_web"
+install -U $pdir/rc.d/builder_web $rcdir/builder_web
 
 # stage app binaries
-install -U "$bdir/builder-web" "$libexecdir/builder-web"
+install -U $bdir/builder-web $libexecdir/builder-web
 
-install -U "$bdir/builder-migrations" "$sbindir/builder-migrations"
-install -U "$bdir/builder-db" "$sbindir/builder-db"
-
-# stage visualization scripts
-install -U "$basedir/packaging/batch-viz.sh" "$confdir/batch-viz.sh.sample"
-install -U "$basedir/packaging/visualizations.sh" "$confdir/upload-hooks/visualizations.sh.sample"
-
-# example repo scripts
-install -U "$basedir/packaging/dpkg-repo.sh" "$sharedir/dpkg-repo.sh"
-install -U "$basedir/packaging/FreeBSD-repo.sh" "$sharedir/FreeBSD-repo.sh"
+install -U $bdir/builder-migrations $sbindir/builder-migrations
+install -U $bdir/builder-db $sbindir/builder-db
 
 # create +MANIFEST
 flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + |
                awk 'BEGIN {s=0} {s+=$1} END {print s}')
 
-sed -e "s:%%FLATSIZE%%:${flatsize}:" -e "/^[Vv]ersion:/s/-/./g" "$pdir/MANIFEST" > "$manifest"
+sed -e "s:%%FLATSIZE%%:${flatsize}:" "$pdir/MANIFEST" > "$manifest"
 
 {
     printf '\nfiles {\n'
@@ -58,7 +48,7 @@ sed -e "s:%%FLATSIZE%%:${flatsize}:" -e "/^[Vv]ersion:/s/-/./g" "$pdir/MANIFEST"
 } | sed -e "s:${rootdir}::" >> "$manifest"
 
 export SOURCE_DATE_EPOCH=$(git log -1 --pretty=format:%ct)
-pkg create -r "$rootdir" -M "$manifest" -o "$basedir/"
-mv "$basedir"/builder-web-*.pkg "$basedir/builder-web.pkg"
-echo 'bin: [ "builder-web.pkg" ]' > "$basedir/builder-web.install"
-echo 'doc: [ "README.md" ]' >> "$basedir/builder-web.install"
+pkg create -r "$rootdir" -M "$manifest" -o $basedir/
+mv $basedir/builder_web-*.pkg $basedir/builder_web.pkg
+echo 'bin: [ "builder_web.pkg" ]' > $basedir/builder-web.install
+echo 'doc: [ "README.md" ]' >> $basedir/builder-web.install

packaging/FreeBSD/rc.d/builder_web

@@ -33,7 +33,7 @@ procname="/usr/local/libexec/builder-web"
 
 builder_web_start () {
     echo "Starting ${name}."
-    /usr/sbin/daemon -S -r -P "${pidfile}" -u "${builder_web_user}" \
+    /usr/sbin/daemon -S -p "${pidfile}" -u "${builder_web_user}" \
 		     "${procname}" ${builder_web_flags}
 }
 

packaging/README.md

@@ -1,78 +0,0 @@
-# Package repository creation and update
-
-Builder-web calls hooks when an upload of a successful build finished. These
-shell scripts automatically push builds to deb repositories (using aptly) and
-FreeBSD package repositories (using pkg).
-
-Thus, as a client of the infrastructure, system packages can be easily
-installed using the package repositories (and updates are straightforward).
-
-The tricky part is verioning: different input may result in the same output
-(i.e. if the build system is updated, it is unlikely this will result in change
-of output, and clients do not need to update their packages), and also due to
-the nature of opam, if a dependency (opam package) is released, the output may
-differ (although the final package version is not increased). We solve the
-latter by adapting the version number of packages: package version 1.5.2 becomes
-1.5.2-TIMESTAMP-SHA256 (on FreeBSD using '.' instead of '-'). The timestamp is
-of the form YYYYMMDDhhmmss. The SHA256 is the hex-encoded SHA256 checksum of
-the original binary package and can be used for lookup in the database.
-
-## DPKG package repository
-
-The dependencies are aptly and dpkg.
-
-For the initial setup, a GPG private key is needed:
-```
-$ gpg --full-generate-key
-$ gpg --export --armor > gpg.pub
-```
-
-Set `REPO_KEYID` in the shell script to the key identifier generated
-(`gpg --list-keys`), and make the gpg.pub available to clients
-(`cp gpg.pub ~/.aptly/public/`).
-
-On clients, when the `~/.aptly/public` is served via http(s), add it to your
-/etc/apt/source.list and import the gpg public key (`apt-key add <gpg.pub>`):
-
-```
-deb https://apt.robur.coop/ debian-10 main
-```
-
-The `debian-10` can be exchanged with any platform you're building debian
-packages for.
-
-Currently, the `dpkg-repo.sh` sets the HOME to `/home/builder` (where aptly
-expects its configuration), and uses the platform (from builder) as
-distribution.
-
-## FreeBSD package repository
-
-The dependency is FreeBSD's pkg utility.
-
-For the initial setup, a RSA private key is needed:
-```
-$ openssl genrsa -out repo.key 4096
-$ chmod 0400 repo.key
-$ openssl rsa -in repo.key -out repo.pub -pubout
-```
-
-And a directory that acts as package repository (`mkdir /usr/local/www/pkg`).
-Copy the public key to the package repository
-(`cp repo.pub /usr/local/www/pkg`) to make it available for clients.
-
-Both can be configured in the shell script itself (`REPO` and `REPO_KEY`). The
-public key needs to be distributed to clients - e.g. put it at the root of the
-repository.
-
-On clients, when that directory is served via http(s), it can be added to
-/usr/local/etc/pkg/repos/robur.conf:
-
-```
-robur: {
-  url: "https://pkg.robur.coop/${ABI}",
-  mirror_type: "srv",
-  signature_type: "pubkey",
-  pubkey: "/path/to/repo.pub",
-  enabled: yes
-}
-```

packaging/batch-viz.sh

@@ -1,189 +0,0 @@
-#!/bin/sh
-
-prog_NAME=$(basename "${0}")
-
-warn()
-{
-    echo "${prog_NAME}: WARN: $*"
-}
-
-info()
-{
-    echo "${prog_NAME}: INFO: $*"
-}
-
-err()
-{
-    echo "${prog_NAME}: ERROR: $*" 1>&2
-}
-
-die()
-{
-    echo "${prog_NAME}: ERROR: $*" 1>&2
-    exit 1
-}
-
-usage()
-{
-    cat <<EOM 1>&2
-usage: ${prog_NAME} [ OPTIONS ]
-Generates visualizations of all things
-    --data-dir=STRING
-        Path to the data directory.
-    --cache-dir=STRING
-        Optional path to the cache directory. Defaults to DATA_DIR/_cache
-    --viz-script=STRING
-        Optional path to the visualizations.sh script. Defaults to ./visualizations.sh
-    --ignore-done
-        Optional flag to force script to ignore '.done' files
-EOM
-    exit 1
-}
-
-CACHE_DIR=
-DATA_DIR=
-VISUALIZATIONS_CMD="./visualizations.sh"
-IGNORE_DONE="false"
-
-while [ $# -gt 0 ]; do
-    OPT="$1"
-
-    case "${OPT}" in
-        --cache-dir=*)
-            CACHE_DIR="${OPT##*=}"
-            ;;
-        --data-dir=*)
-            DATA_DIR="${OPT##*=}"
-            ;;
-        --viz-script=*)
-            VISUALIZATIONS_CMD="${OPT##*=}"
-            ;;
-        --ignore-done)
-            IGNORE_DONE="true"
-            ;;
-        --*)
-            warn "Ignoring unknown option: '${OPT}'"
-            ;;
-        *)
-            err "Unknown option: '${OPT}'"
-            usage
-            ;;
-    esac
-    shift
-done
-
-[ -z "$DATA_DIR" ] && die "The --data-dir option must be specified"
-
-DB="${DATA_DIR}/builder.sqlite3"
-[ ! -e "$DB" ] && die "The database doesn't exist: '$DB'"
-
-# Let's be somewhat lenient with the database version.
-# In visualizations.sh we can be more strict.
-DB_VERSION="$(sqlite3 "$DB" "PRAGMA user_version;")"
-[ -z "$DB_VERSION" ] && die "Couldn't read database version from '$DB'"
-[ "$DB_VERSION" -lt 16 ] && die "The database version should be >= 16. It is '$DB_VERSION'"
-
-APP_ID="$(sqlite3 "$DB" "PRAGMA application_id;")"
-[ -z "$APP_ID" ] && die "Couldn't read application-id from '$DB'"
-[ "$APP_ID" -ne 1234839235 ] && die "The application-id should be = 1234839235. It is '$APP_ID'"
-
-echo
-echo "-----------------------------------------------------------------------------"
-info "Starting batch creation of visualizations: $(date)"
-
-if [ -z "$CACHE_DIR" ]; then
-    CACHE_DIR="${DATA_DIR}/_cache"
-    info "Defaulting --cache-dir to '$CACHE_DIR'"
-fi
-if [ ! -d "${CACHE_DIR}" ]; then
-    info "Cache directory '$CACHE_DIR' doesn't exist, so it will be made"
-    if ! mkdir "${CACHE_DIR}"; then
-        die "Couldn't make cache directory: '$CACHE_DIR'"
-    fi
-fi
-
-[ ! -e "${VISUALIZATIONS_CMD}" ] && die "'$VISUALIZATIONS_CMD' doesn't exist"
-if [ -f "${VISUALIZATIONS_CMD}" ] && [ -x "${VISUALIZATIONS_CMD}" ]; then :; else
-	die "'$VISUALIZATIONS_CMD' is not an executable"
-fi
-
-OPAM_GRAPH="opam-graph"
-MODULECTOMY="modulectomy"
-
-LATEST_TREEMAPVIZ_VERSION="$($MODULECTOMY --version)"
-[ $? -ne 0 ] && die "Couldn't get modulectomy version"
-LATEST_DEPENDENCIESVIZ_VERSION="$($OPAM_GRAPH --version)"
-[ $? -ne 0 ] && die "Couldn't get opam-graph version"
-
-TREEMAP_CACHE_DIR="${CACHE_DIR}/treemap_${LATEST_TREEMAPVIZ_VERSION}"
-DEPENDENCIES_CACHE_DIR="${CACHE_DIR}/dependencies_${LATEST_DEPENDENCIESVIZ_VERSION}"
-
-if
-    [ "${IGNORE_DONE}" = "false" ] && \
-    [ -f "${TREEMAP_CACHE_DIR}/.done" ] && \
-    [ -f "${DEPENDENCIES_CACHE_DIR}/.done" ]; then
-    info "Nothing to do"
-    exit 0
-fi
-
-ATTEMPTED_VIZS=0
-FAILED_VIZS=0
-
-distinct-input () {
-    {
-        sqlite3 "${DATA_DIR}/builder.sqlite3" "SELECT b.uuid
-            FROM build b
-            JOIN build_artifact opam ON opam.build = b.id
-            WHERE opam.filepath = 'opam-switch' AND b.main_binary NOT NULL
-            GROUP BY opam.sha256;"
-        sqlite3 "${DATA_DIR}/builder.sqlite3" "SELECT b.uuid
-            FROM build b
-            JOIN build_artifact debug ON debug.build = b.id
-            WHERE debug.filepath LIKE '%.debug' AND b.main_binary NOT NULL
-            GROUP BY debug.sha256;"
-    } | sort -u
-}
-
-for UUID in $(distinct-input); do
-    if ! "$VISUALIZATIONS_CMD" \
-         --data-dir="${DATA_DIR}" \
-         --cache-dir="${CACHE_DIR}" \
-         --uuid="${UUID}"
-    then
-        FAILED_VIZS=$((FAILED_VIZS + 1))
-    fi
-    ATTEMPTED_VIZS=$((ATTEMPTED_VIZS + 1))
-done
-
-if [ -n "$(ls -A "${TREEMAP_CACHE_DIR}")" ]; then
-    touch "${TREEMAP_CACHE_DIR}/.done"
-
-    V=1
-    while [ "$V" -lt "$LATEST_TREEMAPVIZ_VERSION" ]; do
-        DIR_REMOVE="${CACHE_DIR}/treemap_${V}"
-        if test -d "$DIR_REMOVE" && rm -r "$DIR_REMOVE"; then
-            info "Removed old cache-directory: '$DIR_REMOVE'"
-        fi
-        V=$((V+1))
-    done
-else
-    warn "Treemap-viz cache-directory is still empty - problem?"
-fi
-
-if [ -n "$(ls -A "${DEPENDENCIES_CACHE_DIR}")" ]; then
-    touch "${DEPENDENCIES_CACHE_DIR}/.done"
-
-    V=1
-    while [ "$V" -lt "$LATEST_DEPENDENCIESVIZ_VERSION" ]; do
-        DIR_REMOVE="${CACHE_DIR}/dependencies_${V}"
-        if test -d "$DIR_REMOVE" && rm -r "$DIR_REMOVE"; then
-            info "Removed old cache-directory: '$DIR_REMOVE'"
-        fi
-        V=$((V+1))
-    done
-else
-    warn "Dependencies-viz cache-directory is still empty - problem?"
-fi
-
-info "Batch creation of visualizations for $ATTEMPTED_VIZS binaries, finished with $FAILED_VIZS failures: $(date)"
-

packaging/check_versions.sh

@@ -1,60 +0,0 @@
-#!/bin/sh
-
-# input in versions.txt is <v1> <v2> with v1 < v2.
-# v1 and v2 are of the form <version>-<date>-<hash>, where <version> includes:
-# - 2.0.0
-# - 2.0.0-10-gabcdef
-
-freebsd_sanitize_version () {
-    post=$(echo $1 | rev | cut -d '-' -f 1-2 | rev | sed -e 's/-/./g')
-    v=$(echo $1 | rev | cut -d '-' -f 3- | rev | sed -e 's/-/./g')
-    version_good=$(echo $v | grep -c '^[0-9]\+\.[0-9]\+\.[0-9]\+$')
-    version_with_commit=$(echo $v | grep -c '^[0-9]\+\.[0-9]\+\.[0-9]\+\.[0-9]\+\.g[0-9a-fA-f]\+$')
-    if [ $version_good -eq 0 -a $version_with_commit -eq 0 ]; then
-        echo "invalid version $v";
-        exit 1;
-    fi
-    if [ $version_with_commit -eq 0 ]; then
-        v="${v}.0.g0000000.${post}"
-    else
-        v="${v}.${post}"
-    fi
-    echo $v
-}
-
-echo "using FreeBSD pkg to compare versions now:"
-while read version_a version_b; do
-	version_a=$(freebsd_sanitize_version $version_a)
-	version_b=$(freebsd_sanitize_version $version_b)
-	result=$(pkg version -t "$version_a" "$version_b")
-	printf "%s %s %s\n" "$version_a" "$result" "$version_b"
-done < versions.txt
-
-debian_sanitize_version () {
-    post=$(echo $1 | rev | cut -d '-' -f 1-2 | rev)
-    v=$(echo $1 | rev | cut -d '-' -f 3- | rev)
-    version_good=$(echo $v | grep -c '^[0-9]\+\.[0-9]\+\.[0-9]\+$')
-    version_with_commit=$(echo $v | grep -c '^[0-9]\+\.[0-9]\+\.[0-9]\+\-[0-9]\+\-g[0-9a-fA-f]\+$')
-    if [ $version_good -eq 0 -a $version_with_commit -eq 0 ]; then
-        echo "invalid version $v";
-        exit 1;
-    fi
-    if [ $version_with_commit -eq 0 ]; then
-        v="${v}-0-g0000000-${post}"
-    else
-        v="${v}-${post}"
-    fi
-    echo $v
-}
-
-echo ""
-echo "using Debian dpkg to compare versions now:"
-while read version_a version_b; do
-	version_a=$(debian_sanitize_version $version_a)
-	version_b=$(debian_sanitize_version $version_b)
-	if dpkg --compare-versions "$version_a" lt "$version_b"; then
-		echo "$version_a < $version_b"
-	else
-		echo "$version_a >= $version_b"
-	fi
-done < versions.txt

packaging/debian/builder-web.service

@@ -6,7 +6,7 @@ After=syslog.target network.target
 Type=simple
 User=builder
 Group=builder
-ExecStart=/usr/libexec/builder-web
+ExecStart=/usr/bin/builder-web --datadir /var/lib/builder-web/
 
 [Install]
 WantedBy=multi-user.target

packaging/debian/conffiles

@@ -1 +0,0 @@
-/etc/builder-web/upload-hooks/visualizations.sh

packaging/debian/control

@@ -1,13 +1,13 @@
 Package: builder-web
-Version: %%VERSION_NUM%%
+Version: 0.0.1-%%VERSION_NUM%%
 Section: unknown
 Priority: optional
 Maintainer: Robur Team <team@robur.coop>
 Standards-Version: 4.4.1
-Homepage: https://git.robur.coop/robur/builder-web
-Vcs-Browser: https://git.robur.coop/robur/builder-web
-Vcs-Git: https://git.robur.coop/robur/builder-web.git
+Homepage: https://git.robur.io/robur/builder-web
+Vcs-Browser: https://git.robur.io/robur/builder-web
+Vcs-Git: https://git.robur.io/robur/builder-web.git
 Architecture: all
-Depends: libgmp10, libsqlite3-0, libev4, opam-graph, modulectomy
+Depends: libgmp10, libsqlite3-0, libev4
 Description: Web service for storing and presenting builds.
   Builder-web stores builds in a sqlite database and serves them via HTTP.

packaging/debian/copyright

@@ -1,8 +1,8 @@
 Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
 Upstream-Name: builder-web
 Upstream-Contact: Robur Team <team@robur.coop>
-Source: https://git.robur.coop/robur/builder-web
+Source: https://git.robur.io/robur/builder-web
 
 Files: *
-Copyright: "Reynir Björnsson <reynir@reynir.dk>" "Hannes Mehnert <hannes@mehnert.org>"
+Copyright: "Reynir Björnsson <reynir@reynir.dk" "Hannes Mehnert <hannes@mehnert.org>"
 License: ISC

packaging/debian/create_package.sh

@@ -11,44 +11,27 @@ basedir=$(realpath "$(dirname "$0")"/../..)
 bdir=$basedir/_build/install/default/bin
 tmpd=$basedir/_build/stage
 rootdir=$tmpd/rootdir
-sbindir=$rootdir/usr/sbin
+bindir=$rootdir/usr/bin
 systemddir=$rootdir/usr/lib/systemd/system
 debiandir=$rootdir/DEBIAN
-libexecdir=$rootdir/usr/libexec
-sharedir=$rootdir/usr/share/builder-web
-confdir=$rootdir/etc/builder-web
 
 trap 'rm -rf $tmpd' 0 INT EXIT
 
-mkdir -p "$sbindir" "$debiandir" "$systemddir" "$libexecdir" "$sharedir" \
-	"$confdir" "$confdir/upload-hooks"
+mkdir -p "$bindir" "$debiandir" "$systemddir"
 
 # stage app binaries
-install "$bdir/builder-web" "$libexecdir/builder-web"
-install "$bdir/builder-migrations" "$sbindir/builder-migrations"
-install "$bdir/builder-db" "$sbindir/builder-db"
+install $bdir/builder-web $bindir/builder-web
+install $bdir/builder-migrations $bindir/builder-migrations
+install $bdir/builder-db $bindir/builder-db
 
 # service script
-install -m 0644 "$basedir/packaging/debian/builder-web.service" "$systemddir/builder-web.service"
-
-# visualizations scripts
-install "$basedir/packaging/batch-viz.sh" "$confdir/batch-viz.sh"
-install "$basedir/packaging/visualizations.sh" "$confdir/upload-hooks/visualizations.sh"
-
-# example repo scripts
-install "$basedir/packaging/dpkg-repo.sh" "$sharedir/dpkg-repo.sh"
-install "$basedir/packaging/FreeBSD-repo.sh" "$sharedir/FreeBSD-repo.sh"
+install -m 0644 $basedir/packaging/debian/builder-web.service $systemddir/builder-web.service
 
 # install debian metadata
-install -m 0644 "$basedir/packaging/debian/control" "$debiandir/control"
-install -m 0644 "$basedir/packaging/debian/changelog" "$debiandir/changelog"
-install -m 0644 "$basedir/packaging/debian/copyright" "$debiandir/copyright"
-install -m 0644 "$basedir/packaging/debian/conffiles" "$debiandir/conffiles"
-install "$basedir/packaging/debian/postinst" "$debiandir/postinst"
+install -m 0644 $basedir/packaging/debian/control $debiandir/control
+install -m 0644 $basedir/packaging/debian/changelog $debiandir/changelog
+install -m 0644 $basedir/packaging/debian/copyright $debiandir/copyright
 
-ARCH=$(dpkg-architecture -q DEB_TARGET_ARCH)
-sed -i -e "s/^Architecture:.*/Architecture: ${ARCH}/" "$debiandir/control"
-
-dpkg-deb --build "$rootdir" "$basedir/builder-web.deb"
-echo 'bin: [ "builder-web.deb" ]' > "$basedir/builder-web.install"
-echo 'doc: [ "README.md" ]' >> "$basedir/builder-web.install"
+dpkg-deb --build $rootdir $basedir/builder-web.deb
+echo 'bin: [ "builder-web.deb" ]' > $basedir/builder-web.install
+echo 'doc: [ "README.md" ]' >> $basedir/builder-web.install

packaging/debian/postinst

@@ -1,17 +0,0 @@
-#!/bin/sh
-set -e
-BUILDER_WEB_USER=builder
-
-if ! getent group "$BUILDER_WEB_USER" >/dev/null; then
-	groupadd -g 497 $BUILDER_WEB_USER
-fi
-if ! getent passwd "$BUILDER_WEB_USER" >/dev/null; then
-	useradd -g 497 -u 497 -d /nonexistent -s /usr/sbin/nologin $BUILDER_WEB_USER
-fi
-
-mkdir -p /var/lib/builder-web
-chown "$BUILDER_WEB_USER:$BUILDER_WEB_USER" /var/lib/builder-web
-
-if [ -d /run/systemd/system ]; then
-	systemctl --system daemon-reload >/dev/null || true
-fi

packaging/dpkg-repo.sh

@@ -1,144 +0,0 @@
-#!/bin/sh
-
-set -ex
-
-export HOME="/home/builder"
-
-prog_NAME=$(basename "${0}")
-
-warn()
-{
-    echo "${prog_NAME}: WARN: $*"
-}
-
-err()
-{
-    echo "${prog_NAME}: ERROR: $*" 1>&2
-}
-
-die()
-{
-    echo "${prog_NAME}: ERROR: $*" 1>&2
-    exit 1
-}
-
-usage()
-{
-    cat <<EOM 1>&2
-usage: ${prog_NAME} [ OPTIONS ] FILE
-Updates an aptly package repository
-Options:
-    --build-time=STRING
-        Build timestamp (used for the version of the package).
-    --sha256=STRING
-        Hex encoded SHA256 digest of the main binary.
-    --job=STRING
-        Job name that was built.
-    --platform=STRING
-        Platform name on which the build was performed.
-    --main-binary-filepath=STRING
-        The file path of the main binary.
-EOM
-    exit 1
-}
-
-BUILD_TIME=
-SHA=
-JOB=
-PLATFORM=
-FILEPATH=
-
-while [ $# -gt 1 ]; do
-    OPT="$1"
-
-    case "${OPT}" in
-        --build-time=*)
-            BUILD_TIME="${OPT##*=}"
-            ;;
-        --sha256=*)
-            SHA="${OPT##*=}"
-            ;;
-        --job=*)
-            JOB="${OPT##*=}"
-            ;;
-        --platform=*)
-            PLATFORM="${OPT##*=}"
-            ;;
-        --main-binary-filepath=*)
-            FILEPATH="${OPT##*=}"
-            ;;
-        --*)
-            warn "Ignoring unknown option: '${OPT}'"
-            ;;
-        *)
-            err "Unknown option: '${OPT}'"
-            usage
-            ;;
-    esac
-    shift
-done
-
-[ -z "${BUILD_TIME}" ] && die "The --build-time option must be specified"
-[ -z "${SHA}" ] && die "The --sha256 option must be specified"
-[ -z "${JOB}" ] && die "The --job option must be specified"
-[ -z "${PLATFORM}" ] && die "The --platform option must be specified"
-[ -z "${FILEPATH}" ] && die "The --main-binary-filepath option must be specified"
-
-FILENAME="${1}"
-
-if [ $(basename "${FILEPATH}" .deb) = $(basename "${FILEPATH}") ]; then
-  echo "Not a Debian package"
-  exit 0
-fi
-
-if aptly repo show -with-packages "${PLATFORM}" | grep "${SHA}" > /dev/null; then
-  echo "Package with same SHA256 already in repository"
-  exit 0
-fi
-
-TMP=$(mktemp -d -t debrep)
-
-cleanup () {
-  rm -rf "${TMP}"
-}
-
-trap cleanup EXIT
-
-PKG_ROOT="${TMP}/pkg"
-
-mkdir "${PKG_ROOT}"
-
-dpkg-deb -R "${FILENAME}" "${PKG_ROOT}"
-
-VERSION=$(dpkg-deb -f "${FILENAME}" Version)
-# if we've a tagged version (1.5.0), append the number of commits and a dummy hash
-VERSION_GOOD=$(echo $VERSION | grep -c '^[0-9]\+\.[0-9]\+\.[0-9]\+$') || true
-VERSION_WITH_COMMIT=$(echo $VERSION | grep -c '^[0-9]\+\.[0-9]\+\.[0-9]\+\-[0-9]\+\-g[0-9a-fA-f]\+$') || true
-if [ $VERSION_GOOD -eq 0 -a $VERSION_WITH_COMMIT -eq 0 ]; then
-    die "version does not conform to (MAJOR.MINOR.PATCH[-#NUM_COMMITS-g<HASH>])"
-fi
-if [ $VERSION_WITH_COMMIT -eq 0 ]; then
-    VERSION="${VERSION}-0-g0000000"
-fi
-
-NEW_VERSION="${VERSION}"-"${BUILD_TIME}"-"${SHA}"
-
-sed -i "" -e "s/Version:.*/Version: ${NEW_VERSION}/g" "${PKG_ROOT}/DEBIAN/control"
-
-dpkg-deb --build "${PKG_ROOT}" "${TMP}"
-
-if ! aptly repo show "${PLATFORM}" > /dev/null 2>&1; then
-  aptly repo create --distribution="${PLATFORM}" "${PLATFORM}"
-fi
-
-PACKAGE=$(dpkg-deb -f "${FILENAME}" Package)
-aptly repo remove "${PLATFORM}" "${PACKAGE}"
-aptly repo add "${PLATFORM}" "${TMP}"
-
-: "${REPO_KEYID:="D5E2DC92617877EDF7D4FD4345EA05FB7E26053D"}"
-
-if ! aptly publish show "${PLATFORM}" > /dev/null 2>&1; then
-  aptly publish repo -gpg-key="${REPO_KEYID}" "${PLATFORM}"
-else
-  aptly publish update -gpg-key="${REPO_KEYID}" "${PLATFORM}"
-fi

packaging/versions.txt

@@ -1,9 +0,0 @@
-2.0.0-20220202-abcdef 2.0.1-20220203-123456
-2.0.0-10-gabcdef-20220202-hahh 2.0.0-10-gabcdef-20220203-hahh
-2.0.0-10-gabcdef-20220202-hahh 2.0.0-11-g123456-20220201-abcd
-2.0.0-10-gabcdef-20220202-hahh 2.0.0-110-g123456-20220201-abcd
-2.0.0-11-g123456-20220201-abcd 2.0.1-20220120-abcd
-3.0.0-20230101-abcd 3.0.1-20230204-bdbd
-1.5.0-20220516-a0d5a2 1.5.0-3-g26b5a59-20220527-0bc180
-1.5.0-3-g26b5a59-20220527-0bc180 1.5.1-20220527-0bc180
-0.1.0-20221120104301-f9e456637274844d45d9758ec661a136d0cda7966b075e4426b69fe6da00427b 0.1.0-237-g62965d4-20230527202149-6118c39221f318154e234098b5cffd4dc1d80f19cf2200cc6b1eb768dbf6decb

packaging/visualizations.sh

@@ -1,226 +0,0 @@
-#!/bin/sh
-
-set -e
-#set -x
-
-prog_NAME=$(basename "${0}")
-
-warn()
-{
-    echo "${prog_NAME}: WARN: $*"
-}
-
-info()
-{
-    echo "${prog_NAME}: INFO: $*"
-}
-
-err()
-{
-    echo "${prog_NAME}: ERROR: $*" 1>&2
-}
-
-die()
-{
-    echo "${prog_NAME}: ERROR: $*" 1>&2
-    exit 1
-}
-
-usage()
-{
-    cat <<EOM 1>&2
-usage: ${prog_NAME} [ OPTIONS ]
-Generates visualizations
-Options:
-    --uuid=STRING
-        UUID of build.
-    --data-dir=STRING
-        Path to the data directory.
-    --cache-dir=STRING
-        Path to the cache directory.
-EOM
-    exit 1
-}
-
-UUID=
-CACHE_DIR=
-DATA_DIR=
-
-while [ $# -gt 0 ]; do
-    OPT="$1"
-
-    case "${OPT}" in
-        --uuid=*)
-            UUID="${OPT##*=}"
-            ;;
-        --cache-dir=*)
-            CACHE_DIR="${OPT##*=}"
-            ;;
-        --data-dir=*)
-            DATA_DIR="${OPT##*=}"
-            ;;
-        *)
-            warn "Ignoring unknown option: '${OPT}' (Note that this script reads DB)"
-            ;;
-    esac
-    shift
-done
-
-[ -z "${UUID}" ] && die "The --uuid option must be specified"
-[ -z "${CACHE_DIR}" ] && die "The --cache-dir option must be specified"
-[ -z "${DATA_DIR}" ] && die "The --data-dir option must be specified"
-
-info "processing UUID '${UUID}'"
-
-DB="${DATA_DIR}/builder.sqlite3"
-
-# A new visualizations.sh script may be installed during an upgrade while the
-# old builder-web binary is running. In that case things can get out of sync.
-DB_VERSION="$(sqlite3 "$DB" "PRAGMA user_version;")"
-[ -z "$DB_VERSION" ] && die "Couldn't read database version from '$DB'"
-[ "$DB_VERSION" -ne 18 ] && die "The database version should be 18. It is '$DB_VERSION'"
-
-APP_ID="$(sqlite3 "$DB" "PRAGMA application_id;")"
-[ -z "$APP_ID" ] && die "Couldn't read application-id from '$DB'"
-[ "$APP_ID" -ne 1234839235 ] && die "The application-id should be 1234839235. It is '$APP_ID'"
-
-get_main_binary () {
-    sqlite3 "${DB}" "SELECT '_artifacts/' || substr(lower(hex(ba.sha256)), 1, 2) || '/' || lower(hex(ba.sha256))
-        FROM build AS b
-        JOIN build_artifact AS ba ON ba.build = b.id AND b.main_binary = ba.id
-        WHERE uuid = '${UUID}';"
-}
-
-BIN="${DATA_DIR}/$(get_main_binary)" || die "Failed to get main binary from database"
-[ -z "${BIN}" ] && die "No main-binary found in db '${DB}' for build '${UUID}'"
-
-get_debug_binary () {
-    sqlite3 "${DB}" "SELECT '_artifacts/' || substr(lower(hex(ba.sha256)), 1, 2) || '/' || lower(hex(ba.sha256))
-        FROM build AS b
-        JOIN build_artifact AS ba ON ba.build = b.id
-        WHERE
-          uuid = '${UUID}'
-          AND ba.filepath LIKE '%.debug';"
-}
-
-DEBUG_BIN_RELATIVE="$(get_debug_binary)" || die "Failed to get debug binary from database"
-
-get_opam_switch () {
-    sqlite3 "${DB}" "SELECT '_artifacts/' || substr(lower(hex(ba.sha256)), 1, 2) || '/' || lower(hex(ba.sha256))
-        FROM build AS b
-        JOIN build_artifact AS ba ON ba.build = b.id
-        WHERE
-          uuid = '${UUID}'
-          AND ba.filepath = 'opam-switch';"
-}
-
-OPAM_SWITCH="$(get_opam_switch)" || die "Failed to get opam switch from database"
-[ -z "${OPAM_SWITCH}" ] && die "No 'opam-switch' found in db '${DB}' for build '${UUID}'"
-OPAM_SWITCH="${DATA_DIR}/${OPAM_SWITCH}"
-
-OPAM_GRAPH="opam-graph"
-MODULECTOMY="modulectomy"
-
-LATEST_TREEMAPVIZ_VERSION="$(${MODULECTOMY} --version)" || die "Failed to get modulectomy version"
-LATEST_DEPENDENCIESVIZ_VERSION="$(${OPAM_GRAPH} --version)" || die "Failed to get opam-graph version"
-
-TREEMAP_CACHE_DIR="${CACHE_DIR}/treemap_${LATEST_TREEMAPVIZ_VERSION}"
-DEPENDENCIES_CACHE_DIR="${CACHE_DIR}/dependencies_${LATEST_DEPENDENCIESVIZ_VERSION}"
-
-mktemp_aux () {
-    if [ "$(uname)" = "Linux" ]; then
-        mktemp -t "$1.XXX"
-    elif [ "$(uname)" = "FreeBSD" ]; then
-        mktemp -t "$1"
-    else
-        die 'Unsupported platform'
-    fi
-}
-
-TMPTREE=$(mktemp_aux viz_treemap)
-TMPDEPENDENCIES=$(mktemp_aux viz_dependencies)
-
-cleanup () {
-  rm -rf "${TMPTREE}" "${TMPDEPENDENCIES}"
-}
-
-trap cleanup EXIT
-
-# /// Dependencies viz
-
-if [ ! -d "${DEPENDENCIES_CACHE_DIR}" ]; then
-    mkdir "${DEPENDENCIES_CACHE_DIR}" || die "Failed to create directory '${DEPENDENCIES_CACHE_DIR}'"
-fi
-
-OPAM_SWITCH_FILEPATH='opam-switch'
-
-get_opam_switch_hash () {
-    sqlite3 "${DB}" "SELECT lower(hex(ba.sha256)) FROM build AS b
-        JOIN build_artifact AS ba ON ba.build = b.id
-        WHERE uuid = '${UUID}'
-        AND ba.filepath = '${OPAM_SWITCH_FILEPATH}';"
-}
-
-DEPENDENCIES_INPUT_HASH="$(get_opam_switch_hash)" || die "Failed to get opam-switch hash from database"
-DEPENDENCIES_VIZ_FILENAME="${DEPENDENCIES_CACHE_DIR}/${DEPENDENCIES_INPUT_HASH}.html"
-
-if [ -e "${DEPENDENCIES_VIZ_FILENAME}" ]; then
-    info "Dependency visualization already exists: '${DEPENDENCIES_VIZ_FILENAME}'"
-else
-    if ${OPAM_GRAPH} --output-format=html "${OPAM_SWITCH}" > "${TMPDEPENDENCIES}"; then
-        cp "${TMPDEPENDENCIES}" "${DEPENDENCIES_VIZ_FILENAME}"
-        rm "${TMPDEPENDENCIES}"
-    else
-        die "opam-graph failed to generate visualization"
-    fi
-fi
-
-# /// Treemap viz
-
-stat_aux () {
-    if [ "$(uname)" = "Linux" ]; then
-        stat -c "%s" "$1"
-    elif [ "$(uname)" = "FreeBSD" ]; then
-        stat -f "%z" "$1"
-    else
-        die 'Unsupported platform'
-    fi
-}
-
-SIZE="$(stat_aux "${BIN}")"
-
-if [ ! -d "${TREEMAP_CACHE_DIR}" ]; then
-    mkdir "${TREEMAP_CACHE_DIR}" || die "Failed to create directory '${TREEMAP_CACHE_DIR}'"
-fi
-
-get_debug_bin_hash () {
-    sqlite3 "${DB}" "SELECT lower(hex(ba.sha256)) FROM build AS b
-        JOIN build_artifact AS ba ON ba.build = b.id
-        WHERE uuid = '${UUID}'
-        AND ba.filepath LIKE '%.debug';"
-}
-
-TREEMAP_INPUT_HASH="$(get_debug_bin_hash)" || die "Failed to get treemap input hash from database"
-TREEMAP_VIZ_FILENAME="${TREEMAP_CACHE_DIR}/${TREEMAP_INPUT_HASH}.html"
-
-if [ -n "${DEBUG_BIN_RELATIVE}" ]; then
-    DEBUG_BIN="${DATA_DIR}/$(get_debug_binary)"
-    if [ -e "${TREEMAP_VIZ_FILENAME}" ]; then
-        info "Treemap visualization already exists: '${TREEMAP_VIZ_FILENAME}'"
-    else
-        if
-            ${MODULECTOMY} \
-                --robur-defaults \
-                --with-scale="${SIZE}" \
-                "${DEBUG_BIN}" \
-                > "${TMPTREE}"
-        then
-            cp "${TMPTREE}" "${TREEMAP_VIZ_FILENAME}"
-            rm "${TMPTREE}"
-        else
-            die "modulectomy failed to generate visualization"
-        fi
-    fi
-else
-    info "No --debug-binary provided, not producing any treemap"
-fi

test/builder_db.ml

@@ -3,7 +3,7 @@ let ( >>| ) x f = Result.map f x
 
 module type CONN = Caqti_blocking.CONNECTION
 
-let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna)
+let () = Mirage_crypto_rng_unix.initialize ()
 
 let iter f xs = List.fold_left (fun r x -> r >>= fun () -> f x) (Ok ()) xs
 let get_opt message = function
@@ -25,8 +25,8 @@ module Testable = struct
       x.restricted = y.restricted &&
       match x.password_hash, y.password_hash with
       | `Scrypt (hash, salt, params), `Scrypt (hash', salt', params') ->
-        String.equal hash hash' &&
-        String.equal salt salt' &&
+        Cstruct.equal hash hash' &&
+        Cstruct.equal salt salt' &&
         params = params'
     in
     let pp ppf { Builder_web_auth.username; password_hash; restricted } =
@@ -34,7 +34,7 @@ module Testable = struct
       | `Scrypt (hash, salt, { Builder_web_auth.scrypt_n; scrypt_r; scrypt_p }) ->
         Format.fprintf ppf "user:%s;(%d,%d,%d);%B;%a;%a" username
           scrypt_n scrypt_r scrypt_p restricted
-          Ohex.pp hash Ohex.pp salt
+          Cstruct.hexdump_pp hash Cstruct.hexdump_pp salt
     in
     Alcotest.testable
       pp
@@ -43,15 +43,18 @@ module Testable = struct
   let file =
     let equal (x : Builder_db.Rep.file) (y : Builder_db.Rep.file) =
       Fpath.equal x.filepath y.filepath &&
-      String.equal x.sha256 y.sha256 &&
+      Fpath.equal x.localpath y.localpath &&
+      Cstruct.equal x.sha256 y.sha256 &&
       x.size = y.size
     in
-    let pp ppf { Builder_db.Rep.filepath; sha256; size } =
+    let pp ppf { Builder_db.Rep.filepath; localpath; sha256; size } =
       Format.fprintf ppf "{@[<v 1>@;<1 0>Builder_db.Rep.filepath = %a;@;<1 0>\
+                          localpath = %a;@;<1 0>\
                           sha256 = %a;@;<1 0>\
                           size = %d;@;<1 0>\
                           @]@,}"
-        Fpath.pp filepath Ohex.pp sha256 size
+        Fpath.pp filepath Fpath.pp localpath
+        Cstruct.hexdump_pp sha256 size
     in
     Alcotest.testable pp equal
 
@@ -123,39 +126,39 @@ let test_user_unauth (module Db : CONN) =
 
 let job_name = "test-job"
 let script = Fpath.v "/dev/null"
-let uuid = Uuidm.v `V4
+let uuid = Uuidm.create `V4
 let console = Fpath.v "/dev/null"
 let start = Option.get (Ptime.of_float_s 0.)
 let finish = Option.get (Ptime.of_float_s 1.)
 let result = Builder.Exited 0
 let main_binary =
   let filepath = Result.get_ok (Fpath.of_string "bin/hello.sh") in
+  let localpath = Result.get_ok (Fpath.of_string "/dev/null") in
   let data = "#!/bin/sh\necho Hello, World\n" in
-  let sha256 = Digestif.SHA256.(to_raw_string (digest_string data)) in
+  let sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
   let size = String.length data in
-  { Builder_db.Rep.filepath; sha256; size }
-let main_binary2 =
-  let data = "#!/bin/sh\necho Hello, World 2\n" in
-  let sha256 = Digestif.SHA256.(to_raw_string (digest_string data)) in
-  let size = String.length data in
-  { main_binary with sha256 ; size }
+  { Builder_db.Rep.filepath; localpath; sha256; size }
 let platform = "exotic-os"
 
 let fail_if_none a =
   Option.to_result ~none:(`Msg "Failed to retrieve") a
 
 let add_test_build user_id (module Db : CONN) =
-  let open Builder_db in
-  Db.start () >>= fun () ->
-  Db.exec Job.try_add job_name >>= fun () ->
-  Db.find_opt Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id ->
-  Db.exec Build.add { Build.uuid; start; finish; result; console; script; platform;
-                      main_binary = None; input_id = None; user_id; job_id } >>= fun () ->
-  Db.find last_insert_rowid () >>= fun id ->
-  Db.exec Build_artifact.add (main_binary, id) >>= fun () ->
-  Db.find last_insert_rowid () >>= fun main_binary_id ->
-  Db.exec Build.set_main_binary (id, main_binary_id) >>= fun () ->
-  Db.commit ()
+  let r =
+    let open Builder_db in
+    Db.start () >>= fun () ->
+    Db.exec Job.try_add job_name >>= fun () ->
+    Db.find_opt Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id ->
+    Db.exec Build.add { Build.uuid; start; finish; result; console; script; platform;
+                        main_binary = None; input_id = None; user_id; job_id } >>= fun () ->
+    Db.find last_insert_rowid () >>= fun id ->
+    Db.exec Build_artifact.add (main_binary, id) >>= fun () ->
+    Db.find last_insert_rowid () >>= fun main_binary_id ->
+    Db.exec Build.set_main_binary (id, main_binary_id) >>= fun () ->
+    Db.commit ()
+  in
+  Result.fold ~ok:Result.ok ~error:(fun _ -> Db.rollback ())
+    r
 
 let with_build_db f () =
   or_fail
@@ -195,7 +198,7 @@ let test_build_get_all (module Db : CONN) =
   Db.collect_list Builder_db.Build.get_all job_id >>| fun builds ->
   Alcotest.(check int) "one build" (List.length builds) 1
 
-let uuid' = Uuidm.v `V4
+let uuid' = Uuidm.create `V4
 let start' = Option.get (Ptime.of_float_s 3600.)
 let finish' = Option.get (Ptime.of_float_s 3601.)
 
@@ -208,7 +211,7 @@ let add_second_build (module Db : CONN) =
   Db.exec Build.add { Build.uuid; start; finish; result; console; script; platform;
                      main_binary = None; input_id = None; user_id; job_id; } >>= fun () ->
   Db.find last_insert_rowid () >>= fun id ->
-  Db.exec Build_artifact.add (main_binary2, id) >>= fun () ->
+  Db.exec Build_artifact.add (main_binary, id) >>= fun () ->
   Db.find last_insert_rowid () >>= fun main_binary_id ->
   Db.exec Build.set_main_binary (id, main_binary_id) >>= fun () ->
   Db.commit ()
@@ -217,34 +220,30 @@ let test_build_get_latest (module Db : CONN) =
   add_second_build (module Db) >>= fun () ->
   (* Test *)
   Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id ->
-  Db.find_opt Builder_db.Build.get_latest_successful_with_binary (job_id, platform)
+  Db.find_opt Builder_db.Build.get_latest (job_id, platform)
   >>| get_opt "no latest build" >>| fun (_id, meta, main_binary') ->
-  Alcotest.(check Testable.file) "same main binary" main_binary2 main_binary';
+  Alcotest.(check (option Testable.file)) "same main binary" main_binary' (Some main_binary);
   Alcotest.(check Testable.uuid) "same uuid" meta.uuid uuid'
 
 let test_build_get_previous (module Db : CONN) =
   add_second_build (module Db) >>= fun () ->
   Db.find_opt Builder_db.Build.get_by_uuid uuid'
   >>| get_opt "no build" >>= fun (id, _build) ->
-  Db.find_opt Builder_db.Build.get_previous_successful_different_output id
-  >>| get_opt "no previous build" >>| fun build ->
-  Alcotest.(check Testable.uuid) "same uuid" build.Builder_db.Build.uuid uuid
+  Db.find_opt Builder_db.Build.get_previous_successful_uuid id
+  >>| get_opt "no previous build" >>| fun uuid' ->
+  Alcotest.(check Testable.uuid) "same uuid" uuid' uuid
 
 let test_build_get_previous_none (module Db : CONN) =
   Db.find_opt Builder_db.Build.get_by_uuid uuid
   >>| get_opt "no build" >>= fun (id, _build) ->
-  Db.find_opt Builder_db.Build.get_previous_successful_different_output id >>| function
+  Db.find_opt Builder_db.Build.get_previous_successful_uuid id >>| function
   | None -> ()
-  | Some build ->
-    Alcotest.failf "Got unexpected result %a" Uuidm.pp build.Builder_db.Build.uuid
+  | Some uuid ->
+    Alcotest.failf "Got unexpected result %a" Uuidm.pp uuid
 
 let test_build_get_with_jobname_by_hash (module Db : CONN) =
   add_second_build (module Db) >>= fun () ->
   Db.find_opt Builder_db.Build.get_with_jobname_by_hash main_binary.sha256
-  >>| get_opt "no build" >>= fun (job_name', build) ->
-  Alcotest.(check string) "same job" job_name' job_name;
-  Alcotest.(check Testable.uuid) "same uuid" build.uuid uuid;
-  Db.find_opt Builder_db.Build.get_with_jobname_by_hash main_binary2.sha256
   >>| get_opt "no build" >>| fun (job_name', build) ->
   Alcotest.(check string) "same job" job_name' job_name;
   Alcotest.(check Testable.uuid) "same uuid" build.uuid uuid'
@@ -261,14 +260,6 @@ let test_artifact_get_by_build_uuid (module Db : CONN) =
   get_opt "no build" >>| fun (_id, file) ->
   Alcotest.(check Testable.file) "same file" file main_binary
 
-let test_artifact_exists_true (module Db : CONN) =
-  Db.find Builder_db.Build_artifact.exists main_binary.sha256 >>| fun exists ->
-  Alcotest.(check bool) "main binary exists" true exists
-
-let test_artifact_exists_false (module Db : CONN) =
-  Db.find Builder_db.Build_artifact.exists main_binary2.sha256 >>| fun exists ->
-  Alcotest.(check bool) "main binary2 doesn't exists" false exists
-
 (* XXX: This test should fail because main_binary on the corresponding build
  * references its main_binary. This is not the case now due to foreign key. *)
 let test_artifact_remove_by_build (module Db : CONN) =
@@ -276,39 +267,6 @@ let test_artifact_remove_by_build (module Db : CONN) =
   get_opt "no build" >>= fun (id, _build) ->
   Db.exec Builder_db.Build_artifact.remove_by_build id
 
-let test_get_builds_older_than (module Db : CONN) =
-  add_second_build (module Db) >>= fun () ->
-  let date = Option.get (Ptime.of_float_s (3600. /. 2.)) in
-  Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id ->
-  Db.collect_list Builder_db.Build.get_builds_older_than (job_id, None, date) >>= fun builds ->
-  let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
-  Alcotest.(check (list Testable.uuid)) "last build" builds [ uuid ];
-  Db.collect_list Builder_db.Build.get_builds_older_than (job_id, None, Ptime_clock.now ()) >>= fun builds ->
-  let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
-  (* NOTE(dinosaure): from the most recent to the older. *)
-  Alcotest.(check (list Testable.uuid)) "last builds" builds [ uuid'; uuid ];
-  Ok ()
-
-let test_builds_excluding_latest_n (module Db : CONN) =
-  add_second_build (module Db) >>= fun () ->
-  Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id ->
-  Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 1) >>= fun builds ->
-  let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
-  Alcotest.(check (list Testable.uuid)) "keep recent build" builds [ uuid ];
-  Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 2) >>= fun builds ->
-  let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
-  Alcotest.(check (list Testable.uuid)) "keep 2 builds" builds [];
-  Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 3) >>= fun builds ->
-  let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
-  Alcotest.(check (list Testable.uuid)) "last more builds than we have" builds [];
-  Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, 0) >>= fun builds ->
-  let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
-  Alcotest.(check (list Testable.uuid)) "delete all builds" builds [ uuid'; uuid ];
-  Db.collect_list Builder_db.Build.get_builds_excluding_latest_n (job_id, None, -1) >>= fun builds ->
-  let builds = List.map (fun (_, { Builder_db.Build.uuid; _ }) -> uuid) builds in
-  Alcotest.(check (list Testable.uuid)) "test an incomprehensible argument (-1)" builds [ uuid'; uuid ];
-  Ok ()
-
 let () =
   let open Alcotest in
   Alcotest.run "Builder_db" [
@@ -339,12 +297,6 @@ let () =
     "build-artifact", [
       test_case "Get all by build" `Quick (with_build_db test_artifact_get_all_by_build);
       test_case "Get by build uuid" `Quick (with_build_db test_artifact_get_by_build_uuid);
-      test_case "Artifact exists" `Quick (with_build_db test_artifact_exists_true);
-      test_case "Other artifact doesn't exists" `Quick (with_build_db test_artifact_exists_false);
       test_case "Remove by build" `Quick (with_build_db test_artifact_remove_by_build);
     ];
-    "vacuum", [
-      test_case "Get builds older than now" `Quick (with_build_db test_get_builds_older_than);
-      test_case "Get older builds and keep a fixed number of then" `Quick (with_build_db test_builds_excluding_latest_n);
-    ]
   ]

test/dune

@@ -1,16 +1,3 @@
 (test
- (name test_builder_db)
- (modules test_builder_db)
- (libraries ptime.clock.os builder_db caqti.blocking alcotest mirage-crypto-rng.unix ohex))
-
-(test
- (name markdown_to_html)
- (modules markdown_to_html)
- (libraries builder_web cmarkit alcotest))
-
-(test
- (name router)
- (modules router)
- (libraries builder_web fmt dream yojson alcotest)
- (preprocess
-  (pps ppx_deriving.std ppx_deriving_yojson)))
+ (name builder_db)
+ (libraries builder_db caqti.blocking alcotest mirage-crypto-rng.unix))

test/markdown_to_html.ml

@@ -1,201 +0,0 @@
-let markdown_to_html = Builder_web__Utils.md_to_html
-
-let test_simple () =
-  let markdown = {|# Hello world|} in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "simple html" "<h1 id=\"hello-world\"><a class=\"anchor\" aria-hidden=\"true\" href=\"#hello-world\"></a>Hello world</h1>\n" html)
-
-let test_html_script () =
-  let markdown = {|# <script>Hello world</script>|} in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "html script header" "<h1 id=\"hello-world\"><a class=\"anchor\" aria-hidden=\"true\" href=\"#hello-world\"></a><!-- CommonMark raw HTML omitted -->Hello world<!-- CommonMark raw HTML omitted --></h1>\n" html)
-
-let test_preserve_span_content () =
-  let markdown = {|* <span id="myref">My ref</span>
-* [See my ref](#myref) for more information|} in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "html span content preserved"
-              {|<ul>
-<li><!-- CommonMark raw HTML omitted -->My ref<!-- CommonMark raw HTML omitted --></li>
-<li><a href="#myref">See my ref</a> for more information</li>
-</ul>
-|}
-              html)
-
-let test_remove_script () =
-  let markdown = {|<script>alert(1);</script>|} in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "html script removed" "<!-- CommonMark HTML block omitted -->\n" html)
-
-let test_list_with_html_block_and_markdown () =
-  let markdown = "* <div> Hello, World!</div> *this is not html*" in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "list with html block and markdown"
-              (*"<ul>\n<li><em>this is not html</em>\n</li>\n</ul>\n"*)
-              "<ul>\n<li>\n<!-- CommonMark HTML block omitted -->\n</li>\n</ul>\n"
-              html)
-
-let test_list_with_inline_html_and_markdown () =
-  let markdown = "* <span> Hello, World!</span> *this is not html*" in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "list with html block and markdown"
-              "<ul>\n<li><!-- CommonMark raw HTML omitted --> Hello, World!<!-- CommonMark raw HTML omitted --> <em>this is not html</em></li>\n</ul>\n"
-              html)
-
-let test_absolute_link () =
-  let markdown = "[foo](https://foo.com)" in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "absolute link" "<p><a href=\"https://foo.com\">foo</a></p>\n" html)
-
-let test_relative_link () =
-  let markdown = "[foo](../foo.jpg)" in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "relative link" "<p><a href=\"../foo.jpg\">foo</a></p>\n" html)
-
-let test_absolute_image () =
-  let markdown = "![alttext](https://foo.com/bar.jpg)" in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "absolute image"
-              "<p><img src=\"https://foo.com/bar.jpg\" alt=\"alttext\" ></p>\n" html)
-
-let test_absolute_image_no_alt () =
-  let markdown = "![](https://foo.com/bar.jpg)" in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "absolute image"
-              "<p><img src=\"https://foo.com/bar.jpg\" alt=\"\" ></p>\n" html)
-
-let test_relative_image () =
-  let markdown = "![](/bar.jpg)" in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "relative image" "<p><img src=\"/bar.jpg\" alt=\"\" ></p>\n" html)
-
-let test_absolute_image_script_alt () =
-  let markdown = "![<script src=\"bla.js\"></script>](https://foo.com/bar.jpg)" in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "absolute image with script alt text"
-              "<p><img src=\"https://foo.com/bar.jpg\" alt=\"\" ></p>\n" html)
-
-let test_fragment_link () =
-  let markdown = "[fragment](#fragment)" in
-  let html = markdown_to_html markdown in
-  Alcotest.(check string "fragment link" "<p><a href=\"#fragment\">fragment</a></p>\n" html)
-
-let test_heading_adjustment () =
-  let markdown = {|# foo
-## bar
-# baz
-## bazbar
-### bazbarbar
-#### bazbarbarbar
-##### bazbarbarbarbar
-###### bazbarbarbarbarbar
-|}
-  in
-  let html = markdown_to_html ~adjust_heading:2 markdown in
-  (* NB: the maximum heading is 6 in cmarkit, thus we reduce the structure *)
-  let exp = {|<h3 id="foo"><a class="anchor" aria-hidden="true" href="#foo"></a>foo</h3>
-<h4 id="bar"><a class="anchor" aria-hidden="true" href="#bar"></a>bar</h4>
-<h3 id="baz"><a class="anchor" aria-hidden="true" href="#baz"></a>baz</h3>
-<h4 id="bazbar"><a class="anchor" aria-hidden="true" href="#bazbar"></a>bazbar</h4>
-<h5 id="bazbarbar"><a class="anchor" aria-hidden="true" href="#bazbarbar"></a>bazbarbar</h5>
-<h6 id="bazbarbarbar"><a class="anchor" aria-hidden="true" href="#bazbarbarbar"></a>bazbarbarbar</h6>
-<h6 id="bazbarbarbarbar"><a class="anchor" aria-hidden="true" href="#bazbarbarbarbar"></a>bazbarbarbarbar</h6>
-<h6 id="bazbarbarbarbarbar"><a class="anchor" aria-hidden="true" href="#bazbarbarbarbarbar"></a>bazbarbarbarbarbar</h6>
-|} in
-  Alcotest.(check string "header adjustment works fine" exp html)
-
-let test_table () =
-  let markdown = {__|| a           | | b         |  c            | d | e |
-| --------------------- |-| -------------- | -------------- | --------------- | ------ |
-| entry         | | **bla.file** | **other.file**     |                 |        |
-| _another entry_  | | **another.file** | **another.other** |                 |        |
-|__}
-  in
-  let html = markdown_to_html ~adjust_heading:2 markdown in
-  let exp = {|<div role="region"><table>
-<tr>
-<th>a</th>
-<th></th>
-<th>b</th>
-<th>c</th>
-<th>d</th>
-<th>e</th>
-</tr>
-<tr>
-<td>entry</td>
-<td></td>
-<td><strong>bla.file</strong></td>
-<td><strong>other.file</strong></td>
-<td></td>
-<td></td>
-</tr>
-<tr>
-<td><em>another entry</em></td>
-<td></td>
-<td><strong>another.file</strong></td>
-<td><strong>another.other</strong></td>
-<td></td>
-<td></td>
-</tr>
-</table></div>|} in
-  Alcotest.(check string "table is rendered as html" exp html)
-
-let test_table2 () =
-  let markdown = {__|| a           | | b         |  c            | d | e |
-| --------------------- |-| -------------- | -------------- | --------------- | ------ |
-| entry         | | | | **bla.file** | **other.file**     |
-| _another entry_  | | | **another.file** | **another.other** |                |
-|__}
-  in
-  let html = markdown_to_html ~adjust_heading:2 markdown in
-  let exp = {|<div role="region"><table>
-<tr>
-<th>a</th>
-<th></th>
-<th>b</th>
-<th>c</th>
-<th>d</th>
-<th>e</th>
-</tr>
-<tr>
-<td>entry</td>
-<td></td>
-<td></td>
-<td></td>
-<td><strong>bla.file</strong></td>
-<td><strong>other.file</strong></td>
-</tr>
-<tr>
-<td><em>another entry</em></td>
-<td></td>
-<td></td>
-<td><strong>another.file</strong></td>
-<td><strong>another.other</strong></td>
-<td></td>
-</tr>
-</table></div>|} in
-  Alcotest.(check string "table is rendered as html" exp html)
-
-let markdown_tests = [
-  Alcotest.test_case "Simple" `Quick test_simple;
-  Alcotest.test_case "script header" `Quick test_html_script;
-  Alcotest.test_case "preserve span content" `Quick test_preserve_span_content;
-  Alcotest.test_case "Remove script" `Quick test_remove_script;
-  Alcotest.test_case "List with html block and markdown" `Quick test_list_with_html_block_and_markdown;
-  Alcotest.test_case "List with inline html and markdown" `Quick test_list_with_inline_html_and_markdown;
-  Alcotest.test_case "absolute link" `Quick test_absolute_link;
-  Alcotest.test_case "relative link" `Quick test_relative_link;
-  Alcotest.test_case "absolute image" `Quick test_absolute_image;
-  Alcotest.test_case "absolute image no alt" `Quick test_absolute_image_no_alt;
-  Alcotest.test_case "relative image" `Quick test_relative_image;
-  Alcotest.test_case "absolute image with script alt" `Quick test_absolute_image_script_alt;
-  Alcotest.test_case "fragment link" `Quick test_fragment_link;
-  Alcotest.test_case "heading adjustment" `Quick test_heading_adjustment;
-  Alcotest.test_case "table" `Quick test_table;
-  Alcotest.test_case "table2" `Quick test_table2;
-]
-
-let () =
-  Alcotest.run "Markdown to HTML" [
-    "markdown", markdown_tests
-  ]

test/router.ml

@@ -1,191 +0,0 @@
-
-module Param_verification = struct
-
-  (*> None is 'verified'*)
-  type t = wrong_type option
-  [@@deriving yojson,show,eq]
-
-  and wrong_type = {
-    param : string;
-    expected : string;
-  }
-
-  let alcotyp = Alcotest.testable pp equal
-
-  module P = struct
-
-    let is_string : (string * string) -> _ option  =
-      Fun.const None
-
-    let is_uuid (param, value) =
-      match Uuidm.of_string value with
-      | Some _ when String.length value = 36 -> None
-      | _ -> Some {
-          param;
-          expected = "Uuidm.t"
-        }
-
-  end
-
-  let verify parameters req =
-    let verified_params =
-      List.fold_left (fun acc p ->
-        match acc with
-        | None ->
-          if String.starts_with ~prefix:"build" p then
-           P.is_uuid (p, Dream.param req p)
-          else
-            P.is_string (p, Dream.param req p)
-        | Some _ as x -> x)
-      None parameters
-    in
-    let response_json =
-      verified_params |> to_yojson |> Yojson.Safe.to_string
-    in
-    Dream.respond response_json
-
-end
-
-let find_parameters path =
-  List.filter_map (fun s ->
-      if String.length s > 0 && String.get s 0 = ':' then
-        Some (String.sub s 1 (String.length s - 1))
-      else
-        None)
-    (String.split_on_char '/' path)
-
-let router =
-  (* XXX: this relies on [Builder_web.routes] only using {data,cache,config}dir
-   * in the handlers which are never called here. The path /nonexistant is
-   * assumed to not exist. *)
-  let nodir = Fpath.v "/nonexistant" in
-  Builder_web.routes ~datadir:nodir ~cachedir:nodir ~configdir:nodir ~expired_jobs:0
-  |> List.map (fun (meth, route, _handler) ->
-      meth, route, Param_verification.verify (find_parameters route))
-  |> Builder_web.to_dream_routes
-  |> Dream.router
-  (* XXX: we test without remove_trailing_url_slash to ensure we don't produce
-   * urls with trailing slashes: *)
-  (* |> Builder_web.Middleware.remove_trailing_url_slash *)
-  |> Dream.test
-
-let test_link method_ target () =
-  let req = Dream.request ~method_ ~target "" in
-  let resp = router req in
-  let status_code = Dream.(status resp |> status_to_int) in
-  Alcotest.(check' int ~msg:"status-code" ~actual:status_code ~expected:200);
-  let body =
-    Dream.body resp
-    |> Lwt_main.run
-    |> Yojson.Safe.from_string
-    |> Param_verification.of_yojson
-  in
-  Alcotest.(check' (result Param_verification.alcotyp string) ~msg:"param-verification"
-              ~actual:body ~expected:(Ok None))
-
-let test_link_artifact artifact =
-  let job_name = "test" in
-  let build = Uuidm.v `V4 in
-  test_link `GET @@
-  Builder_web.Link.Job_build_artifact.make ~job_name ~build ~artifact ()
-
-let () =
-  Alcotest.run "Router" [
-    "Link module synced", Alcotest.[
-        test_case "Link.Root.make" `Quick begin
-          test_link `GET @@ Builder_web.Link.Root.make ()
-        end;
-        test_case "Link.Job.make" `Quick begin
-          let queries = [ `Platform "test" ] in
-          let job_name = "test" in
-          test_link `GET @@ Builder_web.Link.Job.make ~queries ~job_name ()
-        end;
-        test_case "Link.Job.make_failed" `Quick begin
-          let queries = [ `Platform "test" ] in
-          let job_name = "test" in
-          test_link `GET @@
-          Builder_web.Link.Job.make_failed ~queries ~job_name ()
-        end;
-        test_case "Link.Job_build.make" `Quick begin
-          let job_name = "test" in
-          let build = Uuidm.v `V4 in
-          test_link `GET @@ Builder_web.Link.Job_build.make ~job_name ~build ()
-        end;
-        test_case "Link.Job_build_artifact.make_from_string" `Quick begin
-          let job_name = "test" in
-          let build = Uuidm.v `V4 in
-          let artifact = "" in
-          test_link `GET @@
-          Builder_web.Link.Job_build_artifact.make_from_string
-            ~job_name ~build ~artifact ()
-        end;
-      ] @ Alcotest.(
-        [
-          `Main_binary;
-          `Viz_treemap;
-          `Viz_dependencies;
-          `Script;
-          `Console;
-          `All_targz;
-          `File Fpath.(v "some" / "path");
-        ]
-        |> List.map (fun artifact ->
-            let descr =
-              Fmt.str "Job_build_artifact.make: %s" @@
-              Builder_web.Link.Job_build_artifact.encode_artifact artifact
-            in
-            test_case descr `Quick begin
-              test_link_artifact artifact
-            end
-          )
-      ) @ Alcotest.[
-        test_case "Link.Compare_builds.make" `Quick begin
-          let left = Uuidm.v `V4 in
-          let right = Uuidm.v `V4 in
-          test_link `GET @@
-          Builder_web.Link.Compare_builds.make ~left ~right ()
-        end;
-        test_case "Link.Failed_builds.make" `Quick begin
-          test_link `GET @@
-          Builder_web.Link.Failed_builds.make ~count:2 ~start:1 ()
-        end;
-      ];
-    (* this doesn't actually test the redirects, unfortunately *)
-    "Latest", List.map (fun p -> Alcotest.(test_case ("…"^p) `Quick begin
-        test_link `GET @@ "/job/test/build/latest" ^ p end))
-      [
-        "/f/bin/unikernel.hvt";
-        "/";
-        "";
-      ];
-    "Albatross hardcoded links",
-    [
-      (*> Note: these links can be found in
-          albatross/command-line/albatross_client_update.ml
-          .. to find them I follewed the trails of 'Albatross_cli.http_host'
-      *)
-      begin
-        let sha_str =
-          Digestif.SHA256.(to_raw_string (digest_string "foo"))
-          |> Ohex.encode
-        in
-        Fmt.str "/hash?sha256=%s" sha_str
-      end;
-      begin
-        let jobname = "foo" in
-        "/job/" ^ jobname ^ "/build/latest"
-      end;
-      begin
-        let job = "foo" in
-        let build = Uuidm.(v `V4 |> to_string) in
-        "/job/" ^ job ^ "/build/" ^ build ^ "/main-binary"
-      end;
-      begin
-        let old_uuid = Uuidm.(v `V4 |> to_string) in
-        let new_uuid = Uuidm.(v `V4 |> to_string) in
-        Fmt.str "/compare/%s/%s" old_uuid new_uuid
-      end;
-    ]
-    |> List.map Alcotest.(fun p ->
-        test_case ("…" ^ p) `Quick (test_link `GET p))
-  ]