Merge pull request 'Update to caqti 1.8.0 and dream 1.0.0~alpha4' (#103) from caqti-dream-update into main

Reviewed-on: https://git.robur.io/robur/builder-web/pulls/103

bin/builder_db_app.ml

@@ -1,3 +1,5 @@
+open Caqti_request.Infix
+
 let ( let* ) = Result.bind
 let ( let+ ) x f = Result.map f x
 
@@ -10,19 +12,12 @@ let or_die exit_code = function
     Format.eprintf "Database error: %a\n" 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 ->. Caqti_type.unit @@
-    Caqti_type.unit
   "PRAGMA defer_foreign_keys = ON"
 
 let connect uri =
-  let* (module Db : Caqti_blocking.CONNECTION) = Caqti_blocking.connect uri in
+  let* (module Db : Caqti_blocking.CONNECTION) = Caqti_blocking.connect ~tweaks_version:(1,8) uri in
-  let* () = Db.exec foreign_keys () in
   let* () = Db.exec defer_foreign_keys () in
   Ok (module Db : Caqti_blocking.CONNECTION)
 
@@ -179,15 +174,12 @@ let job_remove () datadir jobname =
   or_die 1 r
 
 let input_ids =
-   Caqti_request.collect
+  Caqti_type.unit ->* Builder_db.Rep.cstruct @@
-     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 ->*
-     Builder_db.Rep.cstruct
+  Caqti_type.tup3 Builder_db.Rep.cstruct Builder_db.Rep.uuid Caqti_type.string @@
-     (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
@@ -219,23 +211,22 @@ let verify_input_id () dbpath =
   or_die 1 r
 
 let num_build_artifacts =
-  Caqti_request.find
+  Caqti_type.unit ->! Caqti_type.int @@
-    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.unit
+  Caqti_type.(tup3 string Builder_db.Rep.uuid
-    Caqti_type.(tup3 string Builder_db.Rep.uuid (tup4 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct int64))
+                (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.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 |}

bin/builder_web_app.ml

@@ -108,13 +108,12 @@ let setup_app level influx port host datadir cachedir configdir =
       | Some App -> None
     in
     Dream.initialize_log ?level ();
-    Dream.run ~port ~interface:host ~https:false
+    Dream.run ~port ~interface:host ~tls:false
     @@ Dream.logger
     @@ Dream.sql_pool ("sqlite3:" ^ dbpath)
     @@ Http_status_metrics.handle
     @@ Builder_web.Middleware.remove_trailing_url_slash
-    @@ Builder_web.add_routes ~datadir ~cachedir ~configdir
+    @@ Dream.router (Builder_web.routes ~datadir ~cachedir ~configdir)
-    @@ Builder_web.not_found
 
 open Cmdliner
 

bin/migrations/grej.ml

@@ -1,20 +1,29 @@
 (* 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_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
+  Printf.sprintf "PRAGMA user_version = %Ld" version
-    (Printf.sprintf "PRAGMA user_version = %Ld" version)
 
 let check_version
     ?application_id:(desired_application_id=Builder_db.application_id)
@@ -34,6 +43,5 @@ let list_iter_result f xs =
 
 let foreign_keys on =
   let on = if on then "ON" else "OFF" in
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
+  Printf.sprintf "PRAGMA foreign_keys = %s" on
-    (Printf.sprintf "PRAGMA foreign_keys = %s" on)

bin/migrations/m20210126.ml

@@ -3,31 +3,26 @@ 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_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
+  Printf.sprintf "PRAGMA application_id = %ld" Builder_db.application_id
-    (Printf.sprintf "PRAGMA application_id = %ld" Builder_db.application_id)
 
 let alter_build =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "ALTER TABLE build ADD COLUMN main_binary TEXT"
 
 let all_builds =
-  Caqti_request.collect ~oneshot:true
+  Caqti_type.unit ->* Caqti_type.int64 @@
-    Caqti_type.unit
-    Caqti_type.int64
   "SELECT id FROM build"
 
 let bin_artifact =
-  Caqti_request.collect ~oneshot:true
+  Caqti_type.int64 ->* Caqti_type.(tup2 int64 string) @@
-    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_request.exec ~oneshot:true
+  Caqti_type.(tup2 int64 (option string)) ->. Caqti_type.unit @@
-    Caqti_type.(tup2 int64 (option string))
   "UPDATE build SET main_binary = $2 WHERE id = $1"
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
@@ -52,13 +47,11 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Db.exec (Grej.set_version new_version) ()
 
 let rename_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "ALTER TABLE build RENAME TO __tmp_build"
 
 let create_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -78,8 +71,7 @@ let create_build =
   |}
 
 let rollback_data =
-  Caqti_request.exec
+  Caqti_type.unit ->. 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

bin/migrations/m20210202.ml

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

bin/migrations/m20210216.ml

@@ -4,14 +4,14 @@ 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_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE user"
 
 let new_user =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE user (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        username VARCHAR(255) NOT NULL UNIQUE,
@@ -24,8 +24,7 @@ let new_user =
   |}
 
 let old_user =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE user (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        username VARCHAR(255) NOT NULL UNIQUE,
@@ -36,14 +35,12 @@ let old_user =
   |}
 
 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,9 +4,10 @@ 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_request.exec ~oneshot:true
+  Caqti_type.unit ->. 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
@@ -21,8 +22,7 @@ let new_build_artifact =
   |}
 
 let new_build_file =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. 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
@@ -37,53 +37,42 @@ let new_build_file =
   |}
 
 let collect_build_artifact =
-  Caqti_request.collect ~oneshot:true
+  Caqti_type.unit ->* Caqti_type.(tup3 int64 (tup3 string string octets) int64) @@
-    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_request.collect ~oneshot:true
+  Caqti_type.unit ->* Caqti_type.(tup3 int64 (tup3 string string octets) int64) @@
-    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_request.exec ~oneshot:true
+  Caqti_type.(tup3 int64 (tup4 string string octets int64) int64) ->. Caqti_type.unit @@
-    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_request.exec ~oneshot:true
+  Caqti_type.(tup3 int64 (tup4 string string octets int64) int64) ->. Caqti_type.unit @@
-    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_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE build_artifact"
 
 let drop_build_file =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE build_file"
 
 let rename_build_artifact =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "ALTER TABLE new_build_artifact RENAME TO build_artifact"
 
 let rename_build_file =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    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 ->
@@ -110,8 +99,7 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Db.exec (Grej.set_version new_version) ()
 
 let old_build_artifact =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. 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
@@ -125,8 +113,7 @@ let old_build_artifact =
   |}
 
 let old_build_file =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. 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
@@ -140,17 +127,14 @@ let old_build_file =
   |}
 
 let copy_build_artifact =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "INSERT INTO new_build_artifact SELECT id, filepath, localpath, sha256, build FROM build_artifact"
 
 let copy_build_file =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    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,9 +1,9 @@
 module Rep = Builder_db.Rep
 
+open Grej.Infix
+
 let broken_builds =
-  Caqti_request.collect ~oneshot:true
+  Caqti_type.unit ->* Caqti_type.tup3 (Rep.id `build) Rep.uuid Caqti_type.string @@
-    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
@@ -11,7 +11,6 @@ let broken_builds =
   |}
 
 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

bin/migrations/m20210427.ml

@@ -7,13 +7,11 @@ open Grej.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let idx_build_job_start =
-    Caqti_request.exec ~oneshot:true
+    Caqti_type.unit ->. Caqti_type.unit @@
-      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_request.exec ~oneshot:true
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     "DROP INDEX IF EXISTS job_build_idx"
   in
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
@@ -22,13 +20,11 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let job_build_idx =
-    Caqti_request.exec ~oneshot:true
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     "CREATE INDEX job_build_idx ON build(job)"
   in
   let rm_idx_build_job_start =
-    Caqti_request.exec ~oneshot:true
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     "DROP INDEX IF EXISTS idx_build_job_start"
   in
   Grej.check_version ~user_version:new_version (module Db) >>= fun () ->

bin/migrations/m20210531.ml

@@ -4,21 +4,19 @@ 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_request.collect ~oneshot:true
+  Caqti_type.unit ->* Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath @@
-    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_request.exec ~oneshot:true
+  Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath ->. Caqti_type.unit @@
-    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) ->
@@ -29,7 +27,6 @@ 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,13 +3,14 @@ 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_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
 
 let new_build =
-    Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -31,8 +32,7 @@ let new_build =
   |}
 
 let old_build =
-    Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -53,67 +53,64 @@ let old_build =
   |}
 
 let collect_old_build =
-  Caqti_request.collect ~oneshot:true
+  Caqti_type.unit ->*
-    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)))
+                (tup3 (tup4 string int64 int64 int64)
-      Builder_db.Rep.untyped_id)
+                   (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_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)))
+                (tup3 (tup4 string int64 int64 int64)
-      Builder_db.Rep.untyped_id)
+                   (tup4 int64 int (option int) (option string))
+                   (tup3 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 (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |}
 
 let drop_build =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
     "DROP TABLE build"
 
 let rename_build =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
     "ALTER TABLE new_build RENAME TO build"
 
 let find_main_artifact_id =
-  Caqti_request.find ~oneshot:true
+  Caqti_type.(tup2 Builder_db.Rep.untyped_id string) ->!  Builder_db.Rep.untyped_id @@
-    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 =
-  Caqti_request.find ~oneshot:true
+  Builder_db.Rep.untyped_id ->! Caqti_type.string @@
-    Builder_db.Rep.untyped_id
-    Caqti_type.string
     "SELECT filepath FROM build_artifact WHERE id = ?"
 
 let collect_new_build =
-  Caqti_request.collect ~oneshot:true
+  Caqti_type.unit ->*
-    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)))
+                (tup3 (tup4 string int64 int64 int64)
-      Builder_db.Rep.untyped_id)
+                   (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_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)))
+                (tup3 (tup4 string int64 int64 int64)
-      Builder_db.Rep.untyped_id)
+                   (tup4 int64 int (option int) (option string))
+                   (tup3 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 (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |}
 
 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 ->
@@ -133,7 +130,6 @@ let migrate _ (module Db : Caqti_blocking.CONNECTION) =
 
 
 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 ->

bin/migrations/m20210608.ml

@@ -3,9 +3,10 @@ let identifier = "2021-06-08"
 let migrate_doc = "add access list"
 let rollback_doc = "remove access list"
 
+open Grej.Infix
+
 let new_user =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_user (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        username VARCHAR(255) NOT NULL UNIQUE,
@@ -19,8 +20,7 @@ let new_user =
   |}
 
 let old_user =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_user (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        username VARCHAR(255) NOT NULL UNIQUE,
@@ -33,40 +33,35 @@ let old_user =
   |}
 
 let collect_old_user =
-  Caqti_request.collect
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64)) @@
-    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_request.collect
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool)) @@
-    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_request.exec
+  Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool)) ->.
-    Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 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 (?, ?, ?, ?, ?, ?, ?, ?)"
 
 let insert_old_user =
-  Caqti_request.exec
+  Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64)) ->.
-    Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64))
+  Caqti_type.unit @@
   "INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p) VALUES (?, ?, ?, ?, ?, ?, ?)"
 
 let drop_user =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
     "DROP TABLE user"
 
 let rename_new_user =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
     "ALTER TABLE new_user RENAME TO user"
 
 let access_list =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE access_list (
          id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
          user INTEGER NOT NULL,
@@ -79,12 +74,9 @@ let access_list =
   |}
 
 let rollback_access_list =
- Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-   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 () ->
   Db.exec new_user () >>= fun () ->

bin/migrations/m20210609.ml

@@ -3,24 +3,23 @@ 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_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
 
 let nologin_user =
-  Caqti_request.exec
+  Caqti_type.unit ->. 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)"
 
 let remove_nologin_user =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DELETE FROM user WHERE username = 'nologin'"
 
 let new_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -44,8 +43,7 @@ let new_build =
   |}
 
 let old_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -67,8 +65,7 @@ let old_build =
   |}
 
 let insert_from_old_build =
-  Caqti_request.exec ~oneshot:true
+  Builder_db.Rep.id (`user : [`user]) ->. Caqti_type.unit @@
-    (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)
@@ -77,8 +74,7 @@ let insert_from_old_build =
      FROM build |}
 
 let insert_from_new_build =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. 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)
@@ -87,17 +83,13 @@ let insert_from_new_build =
      FROM build |}
 
 let drop_build =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE build"
 
 let rename_build =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.unit ->. Caqti_type.unit @@
-    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 () ->
   Db.exec nologin_user () >>= fun () ->

bin/migrations/m20210625.ml

@@ -3,9 +3,10 @@ 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_request.exec
+  Caqti_type.unit ->. 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
@@ -20,12 +21,9 @@ let build_file =
   |}
 
 let drop_build_file =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    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 () ->
   Db.exec drop_build_file () >>= fun () ->

bin/migrations/m20210629.ml

@@ -3,9 +3,10 @@ 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_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE tag (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        tag VARCHAR(255) NOT NULL UNIQUE
@@ -13,8 +14,7 @@ let tag =
   |}
 
 let job_tag =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE job_tag (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        tag INTEGER NOT NULL,
@@ -28,15 +28,11 @@ let job_tag =
   |}
 
 let jobs =
-  Caqti_request.collect
+  Caqti_type.unit ->* Builder_db.Rep.untyped_id @@
-    Caqti_type.unit
-    Builder_db.Rep.untyped_id
   "SELECT id FROM job"
 
 let latest_successful_build =
-  Caqti_request.find_opt
+  Builder_db.Rep.untyped_id ->? Builder_db.Rep.untyped_id @@
-    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
@@ -45,9 +41,8 @@ let latest_successful_build =
   |}
 
 let build_artifacts =
-  Caqti_request.collect
+  Builder_db.Rep.untyped_id ->*
-    Builder_db.Rep.untyped_id
+  Caqti_type.tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@
-    Caqti_type.(tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath)
   {| SELECT a.filepath, a.localpath
      FROM build_artifact a
      WHERE a.build = ?
@@ -99,33 +94,26 @@ let infer_section_and_synopsis artifacts =
     Some section, infer_synopsis_and_descr opam_switch
 
 let remove_tag =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE tag"
 
 let remove_job_tag =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE job_tag"
 
 let insert_tag =
-   Caqti_request.exec
+  Caqti_type.string ->. Caqti_type.unit @@
-     Caqti_type.string
   "INSERT INTO tag (tag) VALUES (?)"
 
 let insert_job_tag =
-   Caqti_request.exec
+  Caqti_type.(tup3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id) ->.
-     Caqti_type.(tup3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id)
+  Caqti_type.unit @@
   "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"
 
 let find_tag =
-   Caqti_request.find
+  Caqti_type.string ->! Builder_db.Rep.untyped_id @@
-     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 () ->
   Db.exec tag () >>= fun () ->

bin/migrations/m20210630.ml

@@ -3,16 +3,14 @@ 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_request.collect
+  Caqti_type.unit ->* Builder_db.Rep.untyped_id @@
-    Caqti_type.unit
-    Builder_db.Rep.untyped_id
   "SELECT id FROM job"
 
 let latest_successful_build =
-  Caqti_request.find_opt
+  Builder_db.Rep.untyped_id ->? Builder_db.Rep.untyped_id @@
-    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
@@ -21,42 +19,34 @@ let latest_successful_build =
   |}
 
 let build_artifacts =
-  Caqti_request.collect
+  Builder_db.Rep.untyped_id ->*
-    Builder_db.Rep.untyped_id
+  Caqti_type.tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@
-    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_request.exec
+  Caqti_type.string ->. Caqti_type.unit @@
-     Caqti_type.string
   "INSERT INTO tag (tag) VALUES (?)"
 
 let insert_job_tag =
-   Caqti_request.exec
+  Caqti_type.(tup3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id) ->.
-     Caqti_type.(tup3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id)
+  Caqti_type.unit @@
   "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"
 
 let find_tag =
-   Caqti_request.find
+  Caqti_type.string ->! Builder_db.Rep.untyped_id @@
-     Caqti_type.string
-     Builder_db.Rep.untyped_id
   "SELECT id FROM tag where tag = ?"
 
 let remove_job_tag =
-   Caqti_request.exec
+  Builder_db.Rep.untyped_id ->. Caqti_type.unit @@
-     Builder_db.Rep.untyped_id
   "DELETE FROM job_tag where tag = ?"
 
 let remove_tag =
-   Caqti_request.exec
+  Builder_db.Rep.untyped_id ->. Caqti_type.unit @@
-     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 () ->
   Db.exec insert_tag "readme.md" >>= fun () ->

bin/migrations/m20210701.ml

@@ -3,13 +3,14 @@ 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_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
 
 let new_build =
-    Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -33,8 +34,7 @@ let new_build =
   |}
 
 let old_build =
-    Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -58,22 +58,17 @@ let old_build =
   |}
 
 let copy_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "INSERT INTO new_build SELECT * from build"
 
 let drop_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE build"
 
 let rename_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    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 () ->
   Db.exec new_build () >>= fun () ->

bin/migrations/m20210706.ml

@@ -3,18 +3,18 @@ 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_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
+  "ALTER TABLE build ADD COLUMN input_id BLOB"
-      {| ALTER TABLE build ADD COLUMN input_id BLOB |}
 
 let idx_build_job_start =
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
 
 let old_build =
-    Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -38,33 +38,28 @@ let old_build =
   |}
 
 let copy_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. 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"
 
 let drop_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE build"
 
 let rename_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "ALTER TABLE new_build RENAME TO build"
 
 let drop_input_id_from_build =
-    Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
   {| ALTER TABLE build DROP COLUMN input_id |}
 
 let builds =
-  Caqti_request.collect
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.tup4
-    (Caqti_type.tup4
     Builder_db.Rep.untyped_id
     Builder_db.Rep.cstruct
     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'
@@ -73,12 +68,9 @@ let builds =
   |}
 
 let set_input_id =
-  Caqti_request.exec
+  Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.cstruct ->. Caqti_type.unit @@
-    (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 () ->

bin/migrations/m20210707a.ml

@@ -1,13 +1,13 @@
+open Grej.Infix
+
 let orb_left_in_builds =
-  Caqti_request.collect ~oneshot:true
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
-    (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,30 +1,28 @@
+open Grej.Infix
+
 let deb_debug_left_in_builds =
-  Caqti_request.collect ~oneshot:true
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.tup4 (Builder_db.Rep.id `build_artifact) (Builder_db.Rep.id `build)
-    (Caqti_type.tup4 (Builder_db.Rep.id `build_artifact) (Builder_db.Rep.id `build) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    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 =
-  Caqti_request.find_opt
+  Builder_db.Rep.id `build ->? Builder_db.Rep.id `build_artifact @@
-    (Builder_db.Rep.id `build)
-    (Builder_db.Rep.id `build_artifact)
   "SELECT main_binary FROM build WHERE id = ?"
 
 let get_localpath =
-  Caqti_request.find
+  Builder_db.Rep.id `build_artifact ->! Builder_db.Rep.fpath @@
-    (Builder_db.Rep.id `build_artifact)
-    Builder_db.Rep.fpath
   "SELECT localpath FROM build_artifact WHERE id = ?"
 
 let update_paths =
-  Caqti_request.exec
+  Caqti_type.tup3 (Builder_db.Rep.id `build_artifact)
-    (Caqti_type.tup3 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
+  Caqti_type.unit @@
   "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_request.collect ~oneshot:true
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.tup4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact)
-    (Caqti_type.tup4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    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 | `Many > `Zero `One ]) Caqti_request.t =
+let build_not_stripped : ([`build] Builder_db.Rep.id, [`build_artifact] Builder_db.Rep.id, [ `Zero | `One ]) Caqti_request.t =
-  Caqti_request.find_opt
+  Builder_db.Rep.id `build ->? Builder_db.Rep.id `build_artifact @@
-    (Builder_db.Rep.id `build)
+  "SELECT id FROM build_artifact WHERE build = ? AND filepath LIKE '%.debug'"
-    (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 | `One | `Many > `Zero ]) Caqti_request.t =
+let update_paths : ([`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, unit, [ `Zero ]) Caqti_request.t =
-  Caqti_request.exec
+  Caqti_type.tup3 (Builder_db.Rep.id `build_artifact)
-    (Caqti_type.tup3 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
+  Caqti_type.unit @@
   "UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1"
 
-let add_artifact : ((Fpath.t * Fpath.t * Cstruct.t) * (int64 * [`build] Builder_db.Rep.id), unit, [< `Zero | `One | `Many > `Zero]) Caqti_request.t =
+let add_artifact : ((Fpath.t * Fpath.t * Cstruct.t) * (int64 * [`build] Builder_db.Rep.id), unit, [ `Zero]) Caqti_request.t =
-  Caqti_request.exec
+  Caqti_type.(tup2 (tup3 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct)
-    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)))
+                (tup2 Caqti_type.int64 (Builder_db.Rep.id `build))) ->.
-    {| INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?) |}
+  Caqti_type.unit @@
+  "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

bin/migrations/m20210707d.ml

@@ -1,17 +1,16 @@
+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_request.collect ~oneshot:true
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
-    (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_request.exec
+  Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath ->.
-    (Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath)
+  Caqti_type.unit @@
   "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,9 +3,10 @@ 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_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -29,8 +30,7 @@ let new_build =
   |}
 
 let copy_old_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. 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,
@@ -39,19 +39,16 @@ let copy_old_build =
   |}
 
 let old_build_execution_result =
-  Caqti_request.collect
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) @@
-    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_request.exec
+  Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int) ->. Caqti_type.unit @@
-    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int)
   "UPDATE new_build SET result_code = $2 WHERE id = $1"
 
 let old_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -76,8 +73,7 @@ let old_build =
   |}
 
 let copy_new_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. 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,
@@ -86,24 +82,21 @@ let copy_new_build =
   |}
 
 let new_build_execution_result =
-  Caqti_request.collect
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int) @@
-    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int)
   "SELECT id, result_code FROM build"
 
 let update_old_build_execution_result =
-  Caqti_request.exec
+  Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) ->.
-    Caqti_type.(tup3 (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"
 
 let drop_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE build"
 
 let rename_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "ALTER TABLE new_build RENAME TO build"
 
 let execution_new_of_old kind code =
@@ -126,7 +119,6 @@ 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 () ->
@@ -137,25 +129,25 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
     results >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
            "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  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")
+           "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
+            WHERE result_code <> 0")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
            "CREATE INDEX idx_build_input_id ON build(input_id)")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
            "CREATE INDEX idx_build_main_binary ON build(main_binary)")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. 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 () ->
@@ -166,8 +158,9 @@ let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
     results >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit "DROP INDEX idx_build_artifact_sha256") () >>= fun () ->
+  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
-  Db.exec (Caqti_request.exec 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)")
     () >>= fun () ->
   Db.exec (Grej.set_version old_version) ()

bin/migrations/m20210712b.ml

@@ -1,18 +1,16 @@
+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_request.collect ~oneshot:true
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
-    (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_request.collect ~oneshot:true
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
-    (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

@@ -28,8 +28,7 @@ module Asn = struct
 end
 
 let new_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -53,8 +52,7 @@ let new_build =
   |}
 
 let old_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -78,8 +76,7 @@ let old_build =
   |}
 
 let copy_from_old_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. 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,
@@ -88,8 +85,7 @@ let copy_from_old_build =
   |}
 
 let copy_from_new_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. 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,
@@ -98,36 +94,34 @@ let copy_from_new_build =
   |}
 
 let old_build_console_script =
-  Caqti_request.collect
+  Caqti_type.unit ->*
-    Caqti_type.unit
   Caqti_type.(tup4 (Builder_db.Rep.id  (`build : [ `build ]))
-                  (tup2 string Builder_db.Rep.uuid) Builder_db.Rep.cstruct string)
+                (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_request.exec
+  Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ]))
-    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+                Builder_db.Rep.fpath Builder_db.Rep.fpath) ->.
+  Caqti_type.unit @@
   "UPDATE new_build SET console = $2, script = $3 WHERE id = $1"
 
 let new_build_console_script =
-  Caqti_request.collect
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.tup3 (Builder_db.Rep.id (`build : [ `build ]))
-    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    Builder_db.Rep.fpath Builder_db.Rep.fpath @@
   "SELECT id, console, script FROM build"
 
 let update_old_build_console_script =
-  Caqti_request.exec
+  Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.cstruct string) ->.
-    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.cstruct string)
+  Caqti_type.unit @@
   "UPDATE new_build SET console = $2, script = $3 WHERE id = $1"
 
 let drop_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE build"
 
 let rename_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "ALTER TABLE new_build RENAME TO build"
 
 let console_to_string console =
@@ -187,16 +181,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_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
            "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  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")
+           "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
+            WHERE result_code <> 0")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
            "CREATE INDEX idx_build_input_id ON build(input_id)")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
            "CREATE INDEX idx_build_main_binary ON build(main_binary)")
     () >>= fun () ->
   Db.exec (Grej.set_version new_version) ()
@@ -212,16 +207,17 @@ let rollback datadir (module Db : Caqti_blocking.CONNECTION) =
     console_scripts >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
            "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  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")
+           "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
+            WHERE result_code <> 0")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
            "CREATE INDEX idx_build_input_id ON build(input_id)")
     () >>= fun () ->
-  Db.exec (Caqti_request.exec Caqti_type.unit
+  Db.exec (Caqti_type.unit ->. 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,16 +1,19 @@
+open Grej.Infix
+
 let mixups =
-  Caqti_request.collect ~oneshot:true
+  Caqti_type.unit ->*
-    Caqti_type.unit
+  Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build]))
-    (Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    Builder_db.Rep.fpath Builder_db.Rep.fpath @@
-"SELECT id, console, script FROM build WHERE console LIKE '%/script.txt' AND script LIKE '%/console.txt'"
+  "SELECT id, console, script FROM build \
+   WHERE console LIKE '%/script.txt' AND script LIKE '%/console.txt'"
 
 let fixup =
-  Caqti_request.exec ~oneshot:true
+  Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build]))
-    (Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
+  Caqti_type.unit @@
   "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,8 +6,7 @@ and rollback_doc = "remove platform from build"
 open Grej.Syntax
 
 let new_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -32,8 +31,7 @@ let new_build =
   |}
 
 let old_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   {| CREATE TABLE new_build (
        id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
        uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -57,8 +55,7 @@ let old_build =
   |}
 
 let copy_from_old_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. 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,
@@ -67,8 +64,7 @@ let copy_from_old_build =
   |}
 
 let copy_from_new_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. 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,
@@ -77,24 +73,19 @@ let copy_from_new_build =
   |}
 
 let build_id_and_user =
-  Caqti_request.collect
+  Caqti_type.unit ->* Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int64) @@
-    Caqti_type.unit
-    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int64)
   "SELECT id, user FROM build"
 
 let update_new_build_platform =
-  Caqti_request.exec
+  Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) string) ->. Caqti_type.unit @@
-    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) string)
   "UPDATE new_build SET platform = $2 WHERE id = $1"
 
 let drop_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "DROP TABLE build"
 
 let rename_build =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
   "ALTER TABLE new_build RENAME TO build"
 
 (*
@@ -114,6 +105,22 @@ 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
@@ -127,26 +134,10 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   in
   let* () = Db.exec drop_build () in
   let* () = Db.exec rename_build () in
-  let* () =
+  let* () = Db.exec idx_build_job_start () in
-    Db.exec (Caqti_request.exec Caqti_type.unit
+  let* () = Db.exec idx_build_failed () in
-        "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+  let* () = Db.exec idx_build_input_id () in
-      ()
+  let* () = Db.exec idx_build_main_binary () in
-  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) =
@@ -155,25 +146,9 @@ 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* () =
+  let* () = Db.exec idx_build_job_start () in
-    Db.exec (Caqti_request.exec Caqti_type.unit
+  let* () = Db.exec idx_build_failed () in
-        "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+  let* () = Db.exec idx_build_input_id () in
-      ()
+  let* () = Db.exec idx_build_main_binary () in
-  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) ()
 

builder-web.opam

@@ -23,7 +23,7 @@ depends: [
   "bos"
   "hex"
   "lwt" {>= "5.3.0"}
-  "caqti"
+  "caqti" {>= "1.8.0"}
   "caqti-lwt"
   "caqti-driver-sqlite3"
   "pbkdf"

db/builder_db.ml

@@ -1,5 +1,6 @@
 module Rep = Representation
 open Rep
+open Caqti_request.Infix
 
 let application_id = 1234839235l
 
@@ -18,31 +19,24 @@ type file = Rep.file = {
 let last_insert_rowid = Rep.last_insert_rowid
 
 let get_application_id =
-  Caqti_request.find
+  Caqti_type.unit ->!  Caqti_type.int32 @@
-    Caqti_type.unit
-    Caqti_type.int32
   "PRAGMA application_id"
 
 let get_version =
-  Caqti_request.find
+  Caqti_type.unit ->!  Caqti_type.int64 @@
-    Caqti_type.unit
-    Caqti_type.int64
   "PRAGMA user_version"
 
 let set_application_id =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
+  Printf.sprintf "PRAGMA application_id = %ld" application_id
-    (Printf.sprintf "PRAGMA application_id = %ld" application_id)
 
 let set_current_version =
-  Caqti_request.exec
+  Caqti_type.unit ->. Caqti_type.unit @@
-    Caqti_type.unit
+  Printf.sprintf "PRAGMA user_version = %Ld" current_version
-    (Printf.sprintf "PRAGMA user_version = %Ld" current_version)
 
 module Job = struct
   let migrate =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     {| CREATE TABLE job (
          id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
          name VARCHAR(255) NOT NULL UNIQUE
@@ -50,26 +44,20 @@ module Job = struct
     |}
 
   let rollback =
-    Caqti_request.exec
+    Caqti_type.unit ->.  Caqti_type.unit @@
-      Caqti_type.unit
+    "DROP TABLE IF EXISTS job"
-      {| DROP TABLE IF EXISTS job |}
 
   let get =
-    Caqti_request.find
+    id `job ->! Caqti_type.string @@
-      (id `job)
-      Caqti_type.string
     "SELECT name FROM job WHERE id = ?"
 
   let get_id_by_name =
-    Caqti_request.find_opt
+    Caqti_type.string ->? id `job @@
-      Caqti_type.string
-      (id `job)
     "SELECT id FROM job WHERE name = ?"
 
   let get_all_with_section_synopsis =
-    Caqti_request.collect
+    Caqti_type.unit ->*
-      Caqti_type.unit
+    Caqti_type.(tup4 (id `job) string (option string) (option string)) @@
-      Caqti_type.(tup4 (id `job) string (option string) (option string))
     {| SELECT j.id, j.name, section.value, synopsis.value
        FROM job j, tag section_tag, tag synopsis_tag
        LEFT JOIN job_tag section ON section.job = j.id AND section.tag = section_tag.id
@@ -79,20 +67,17 @@ module Job = struct
     |}
 
   let try_add =
-    Caqti_request.exec
+    Caqti_type.string ->. Caqti_type.unit @@
-      Caqti_type.string
     "INSERT OR IGNORE INTO job (name) VALUES (?)"
 
   let remove =
-    Caqti_request.exec
+    id `job ->. Caqti_type.unit @@
-      (id `job)
     "DELETE FROM job WHERE id = ?"
 end
 
 module Tag = struct
   let migrate =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     {| CREATE TABLE tag (
          id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
          tag VARCHAR(255) NOT NULL UNIQUE
@@ -100,26 +85,21 @@ module Tag = struct
     |}
 
   let rollback =
-    Caqti_request.exec
+    Caqti_type.unit ->.  Caqti_type.unit @@
-      Caqti_type.unit
       "DROP TABLE IF EXISTS tag"
 
   let get_id_by_name =
-    Caqti_request.find
+    Caqti_type.string ->! id `tag @@
-      Caqti_type.string
-      (id `tag)
       "SELECT id FROM tag WHERE tag = ?"
 
   let try_add =
-    Caqti_request.exec
+    Caqti_type.string ->. Caqti_type.unit @@
-      Caqti_type.string
     "INSERT OR IGNORE INTO tag (tag) VALUES (?)"
 end
 
 module Job_tag = struct
   let migrate =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     {| CREATE TABLE job_tag (
          id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
          tag INTEGER NOT NULL,
@@ -133,37 +113,30 @@ module Job_tag = struct
     |}
 
   let rollback =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
       "DROP TABLE IF EXISTS job_tag"
 
   let add =
-    Caqti_request.exec
+    Caqti_type.(tup3 (id `tag) string (id `job)) ->. Caqti_type.unit @@
-      Caqti_type.(tup3 (id `tag) string (id `job))
     "INSERT INTO job_tag (tag, value, job) VALUES ($1, $2, $3)"
 
   let update =
-    Caqti_request.exec
+    Caqti_type.(tup3 (id `tag) string (id `job)) ->. Caqti_type.unit @@
-      Caqti_type.(tup3 (id `tag) string (id `job))
     "UPDATE job_tag SET value = $2 WHERE tag = $1 AND job = $3"
 
   let get_value =
-    Caqti_request.find_opt
+    Caqti_type.(tup2 (id `tag) (id `job)) ->?  Caqti_type.string @@
-      Caqti_type.(tup2 (id `tag) (id `job))
-      Caqti_type.string
     "SELECT value FROM job_tag WHERE tag = ? AND job = ?"
 
   let remove_by_job =
-    Caqti_request.exec
+    id `job ->. Caqti_type.unit @@
-      (id `job)
     "DELETE FROM job_tag WHERE job = ?"
 
 end
 
 module Build_artifact = struct
   let migrate =
-    Caqti_request.exec
+    Caqti_type.unit ->.  Caqti_type.unit @@
-      Caqti_type.unit
     {| CREATE TABLE build_artifact (
            id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
            filepath TEXT NOT NULL, -- the path as in the build
@@ -178,21 +151,16 @@ module Build_artifact = struct
     |}
 
   let rollback =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     "DROP TABLE IF EXISTS build_artifact"
 
   let get =
-    Caqti_request.find
+    id `build_artifact ->! file @@
-      (id `build_artifact)
-      file
     {| SELECT filepath, localpath, sha256, size
        FROM build_artifact WHERE id = ? |}
 
   let get_by_build_uuid =
-    Caqti_request.find_opt
+    Caqti_type.tup2 uuid fpath ->? Caqti_type.tup2 (id `build_artifact) file @@
-      (Caqti_type.tup2 uuid fpath)
-      (Caqti_type.tup2 (id `build_artifact) file)
     {| SELECT build_artifact.id, build_artifact.filepath,
          build_artifact.localpath, build_artifact.sha256, build_artifact.size
        FROM build_artifact
@@ -201,27 +169,20 @@ module Build_artifact = struct
     |}
 
   let get_all_by_build =
-    Caqti_request.collect
+    id `build ->* Caqti_type.(tup2 (id `build_artifact) file) @@
-      (id `build)
-      Caqti_type.(tup2
-                    (id `build_artifact)
-                    file)
     "SELECT id, filepath, localpath, sha256, size FROM build_artifact WHERE build = ?"
 
   let add =
-    Caqti_request.exec
+    Caqti_type.(tup2 file (id `build)) ->. Caqti_type.unit @@
-      Caqti_type.(tup2 file (id `build))
+    "INSERT INTO build_artifact (filepath, localpath, sha256, size, build) \
-      "INSERT INTO build_artifact (filepath, localpath, sha256, size, build)
      VALUES (?, ?, ?, ?, ?)"
 
   let remove_by_build =
-    Caqti_request.exec
+    id `build ->. Caqti_type.unit @@
-      (id `build)
     "DELETE FROM build_artifact WHERE build = ?"
 
   let remove =
-    Caqti_request.exec
+    id `build_artifact ->. Caqti_type.unit @@
-      (id `build_artifact)
     "DELETE FROM build_artifact WHERE id = ?"
 end
 
@@ -268,8 +229,7 @@ module Build = struct
     Caqti_type.custom ~encode ~decode rep
 
   let migrate =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     {| CREATE TABLE build (
          id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
          uuid VARCHAR(36) NOT NULL UNIQUE,
@@ -294,14 +254,11 @@ module Build = struct
     |}
 
   let rollback =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
+    "DROP TABLE IF EXISTS build"
-      {| DROP TABLE IF EXISTS build |}
 
   let get_by_uuid =
-    Caqti_request.find_opt
+    Rep.uuid ->?  Caqti_type.tup2 (id `build) t @@
-      Rep.uuid
-      (Caqti_type.tup2 (id `build) t)
     {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
                 result_code, result_msg,
                 console, script, platform, main_binary, input_id, user, job
@@ -310,9 +267,7 @@ module Build = struct
     |}
 
   let get_all =
-    Caqti_request.collect
+    id `job ->* Caqti_type.tup2 (id `build) t @@
-      (id `job)
-      (Caqti_type.tup2 (id `build) t)
     {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
                 result_code, result_msg, console,
                 script, platform, main_binary, input_id, user, job
@@ -322,9 +277,7 @@ module Build = struct
     |}
 
   let get_all_failed =
-    Caqti_request.collect
+    Caqti_type.(tup3 int int (option string)) ->* Caqti_type.tup2 Caqti_type.string t @@
-      Caqti_type.(tup3 int int (option string))
-      (Caqti_type.tup2 Caqti_type.string t)
     {| SELECT job.name, b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
          b.result_code, b.result_msg, b.console, b.script, b.platform,
          b.main_binary, b.input_id, b.user, b.job
@@ -337,9 +290,7 @@ module Build = struct
     |}
 
   let get_all_artifact_sha =
-    Caqti_request.collect
+    Caqti_type.(tup2 (id `job) (option string)) ->* Rep.cstruct @@
-      Caqti_type.(tup2 (id `job) (option string))
-      Rep.cstruct
     {| SELECT DISTINCT a.sha256
        FROM build_artifact a, build b
        WHERE b.job = $1 AND b.main_binary = a.id
@@ -348,9 +299,7 @@ module Build = struct
     |}
 
   let get_failed_builds =
-    Caqti_request.collect
+    Caqti_type.(tup2 (id `job) (option string)) ->* t @@
-      Caqti_type.(tup2 (id `job) (option string))
-      t
     {| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
               result_code, result_msg, console, script,
               platform, main_binary, input_id, user, job
@@ -361,12 +310,7 @@ module Build = struct
     |}
 
   let get_latest_successful_with_binary =
-    Caqti_request.find_opt
+    Caqti_type.(tup2 (id `job) string) ->? Caqti_type.tup3 (id `build) t file_opt @@
-      Caqti_type.(tup2 (id `job) string)
-      Caqti_type.(tup3
-                   (id `build)
-                   t
-                   file_opt)
     {| SELECT b.id,
          b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
          b.result_code, b.result_msg, b.console, b.script,
@@ -381,9 +325,7 @@ module Build = struct
     |}
 
   let get_latest_successful =
-    Caqti_request.find_opt
+    Caqti_type.(tup2 (id `job) (option string)) ->? t @@
-      Caqti_type.(tup2 (id `job) (option string))
-      t
     {| SELECT
          b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
          b.result_code, b.result_msg, b.console, b.script,
@@ -396,9 +338,7 @@ module Build = struct
     |}
 
   let get_previous_successful_different_output =
-    Caqti_request.find_opt
+    id `build ->? t @@
-      (id `build)
-      t
     {| SELECT
          b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
          b.result_code, b.result_msg, b.console, b.script,
@@ -415,9 +355,7 @@ module Build = struct
     |}
 
   let get_next_successful_different_output =
-    Caqti_request.find_opt
+    id `build ->? t @@
-      (id `build)
-      t
     {| SELECT
          b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
          b.result_code, b.result_msg, b.console, b.script,
@@ -434,9 +372,7 @@ module Build = struct
     |}
 
   let get_same_input_same_output_builds =
-    Caqti_request.collect
+    id `build ->* t @@
-      (id `build)
-      t
     {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
          b.result_code, b.result_msg, b.console, b.script,
          b.platform, b.main_binary, b.input_id, b.user, b.job
@@ -447,9 +383,7 @@ module Build = struct
     |}
 
   let get_same_input_different_output_hashes =
-    Caqti_request.collect
+    id `build ->* Rep.cstruct @@
-      (id `build)
-      Rep.cstruct
     {| SELECT DISTINCT a.sha256
        FROM build b0, build_artifact a0, build b, build_artifact a
        WHERE b0.id = ? AND a0.id = b0.main_binary AND a0.sha256 <> a.sha256
@@ -458,9 +392,7 @@ module Build = struct
     |}
 
   let get_different_input_same_output_input_ids =
-    Caqti_request.collect
+    id `build ->* Rep.cstruct @@
-      (id `build)
-      Rep.cstruct
     {| SELECT DISTINCT b.input_id
        FROM build b0, build_artifact a0, build b, build_artifact a
        WHERE b0.id = ? AND a0.id = b0.main_binary AND a0.sha256 = a.sha256
@@ -468,9 +400,7 @@ module Build = struct
     |}
 
   let get_one_by_input_id =
-    Caqti_request.find
+    Rep.cstruct ->! t @@
-      Rep.cstruct
-      t
     {| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
         result_code, result_msg, console, script,
         platform, main_binary, input_id, user, job
@@ -481,14 +411,11 @@ module Build = struct
     |}
 
   let get_platforms_for_job =
-    Caqti_request.collect
+    id `job ->* Caqti_type.string @@
-      (id `job)
-      Caqti_type.string
     "SELECT DISTINCT platform FROM build WHERE job = ?"
 
   let add =
-    Caqti_request.exec
+    t ->. Caqti_type.unit @@
-      t
     {| INSERT INTO build
          (uuid, start_d, start_ps, finish_d, finish_ps,
          result_code, result_msg, console, script, platform, main_binary, input_id, user, job)
@@ -497,9 +424,7 @@ module Build = struct
     |}
 
   let get_by_hash =
-    Caqti_request.find
+    Rep.cstruct ->! t @@
-      Rep.cstruct
-      t
     {| SELECT
          b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
          b.result_code, b.result_msg, b.console, b.script,
@@ -512,9 +437,7 @@ module Build = struct
     |}
 
   let get_with_main_binary_by_hash =
-    Caqti_request.find
+    Rep.cstruct ->! Caqti_type.tup2 t file_opt @@
-      Rep.cstruct
-      (Caqti_type.tup2 t file_opt)
     {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
             b.result_code, b.result_msg, b.console, b.script,
             b.platform, b.main_binary, b.input_id, b.user, b.job,
@@ -527,11 +450,7 @@ module Build = struct
     |}
 
   let get_with_jobname_by_hash =
-    Caqti_request.find_opt
+    Rep.cstruct ->? Caqti_type.tup2 Caqti_type.string t @@
-      Rep.cstruct
-      (Caqti_type.tup2
-         Caqti_type.string
-         t)
     {| SELECT job.name,
          b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
          b.result_code, b.result_msg,
@@ -545,20 +464,17 @@ module Build = struct
     |}
 
   let set_main_binary =
-    Caqti_request.exec
+    Caqti_type.tup2 (id `build) (id `build_artifact) ->. Caqti_type.unit @@
-      (Caqti_type.tup2 (id `build) (id `build_artifact))
     "UPDATE build SET main_binary = $2 WHERE id = $1"
 
   let remove =
-    Caqti_request.exec
+    id `build ->. Caqti_type.unit @@
-      (id `build)
     "DELETE FROM build WHERE id = ?"
 end
 
 module User = struct
   let migrate =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     {| CREATE TABLE user (
          id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
          username VARCHAR(255) NOT NULL UNIQUE,
@@ -572,14 +488,11 @@ module User = struct
     |}
 
   let rollback =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     "DROP TABLE IF EXISTS user"
 
   let get_user =
-    Caqti_request.find_opt
+    Caqti_type.string ->? Caqti_type.tup2 (id `user) user_info @@
-      Caqti_type.string
-      (Caqti_type.tup2 (id `user) user_info)
     {| SELECT id, username, password_hash, password_salt,
          scrypt_n, scrypt_r, scrypt_p, restricted
        FROM user
@@ -587,27 +500,22 @@ module User = struct
     |}
 
   let get_all =
-    Caqti_request.collect
+    Caqti_type.unit ->* Caqti_type.string @@
-      Caqti_type.unit
-      Caqti_type.string
     "SELECT username FROM user"
 
   let add =
-    Caqti_request.exec
+    user_info ->. Caqti_type.unit @@
-      user_info
     {| INSERT INTO user (username, password_hash, password_salt,
          scrypt_n, scrypt_r, scrypt_p, restricted)
        VALUES (?, ?, ?, ?, ?, ?, ?)
     |}
 
   let remove_user =
-    Caqti_request.exec
+    Caqti_type.string ->. Caqti_type.unit @@
-      Caqti_type.string
     "DELETE FROM user WHERE username = ?"
 
   let update_user =
-    Caqti_request.exec
+    user_info ->. Caqti_type.unit @@
-      user_info
     {| UPDATE user
        SET password_hash = $2,
            password_salt = $3,
@@ -621,8 +529,7 @@ end
 
 module Access_list = struct
   let migrate =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     {| CREATE TABLE access_list (
            id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
            user INTEGER NOT NULL,
@@ -635,34 +542,27 @@ module Access_list = struct
     |}
 
   let rollback =
-    Caqti_request.exec
+    Caqti_type.unit ->. Caqti_type.unit @@
-      Caqti_type.unit
     "DROP TABLE IF EXISTS access_list"
 
   let get =
-    Caqti_request.find
+    Caqti_type.tup2 (id `user) (id `job) ->! id `access_list @@
-      Caqti_type.(tup2 (id `user) (id `job))
-      (id `access_list)
     "SELECT id FROM access_list WHERE user = ? AND job = ?"
 
   let add =
-    Caqti_request.exec
+    Caqti_type.tup2 (id `user) (id `job) ->. Caqti_type.unit @@
-      Caqti_type.(tup2 (id `user) (id `job))
     "INSERT INTO access_list (user, job) VALUES (?, ?)"
 
   let remove =
-    Caqti_request.exec
+    Caqti_type.tup2 (id `user) (id `job) ->. Caqti_type.unit @@
-      Caqti_type.(tup2 (id `user) (id `job))
     "DELETE FROM access_list WHERE user = ? AND job = ?"
 
   let remove_by_job =
-    Caqti_request.exec
+    id `job ->. Caqti_type.unit @@
-      (id `job)
     "DELETE FROM access_list WHERE job = ?"
 
   let remove_all_by_username =
-    Caqti_request.exec
+    Caqti_type.string ->. Caqti_type.unit @@
-      Caqti_type.string
     {| DELETE FROM access_list
        WHERE access_list.id IN (
          SELECT access_list.id
@@ -682,15 +582,15 @@ let migrate = [
   Access_list.migrate;
   Tag.migrate;
   Job_tag.migrate;
-  Caqti_request.exec Caqti_type.unit
+  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
+  Caqti_type.unit ->. Caqti_type.unit @@
   "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0";
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "CREATE INDEX idx_build_input_id ON build(input_id)";
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "CREATE INDEX idx_build_main_binary ON build(main_binary)";
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "CREATE INDEX idx_build_artifact_sha256 ON build_artifact(sha256)";
   set_current_version;
   set_application_id;
@@ -704,18 +604,18 @@ let rollback = [
   Build_artifact.rollback;
   Build.rollback;
   Job.rollback;
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "DROP INDEX IF EXISTS idx_build_artifact_sha256";
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "DROP INDEX IF EXISTS idx_build_failed";
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "DROP INDEX IF EXISTS idx_build_input_id";
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "DROP INDEX IF EXISTS idx_build_main_binary";
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "DROP INDEX IF EXISTS idx_build_job_start";
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "PRAGMA user_version = 0";
-  Caqti_request.exec Caqti_type.unit
+  Caqti_type.unit ->. Caqti_type.unit @@
   "PRAGMA application_id = 0";
 ]

db/builder_db.mli

@@ -33,66 +33,66 @@ val application_id : int32
 val current_version : int64
 
 val get_application_id :
-  (unit, int32, [< `Many | `One | `Zero > `One ]) Caqti_request.t
+  (unit, int32, [ `One ]) Caqti_request.t
 
 val set_application_id :
-  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+  (unit, unit, [ `Zero ]) Caqti_request.t
 
 val get_version :
-  (unit, int64, [< `Many | `One | `Zero > `One ]) Caqti_request.t
+  (unit, int64, [ `One ]) Caqti_request.t
 
 val set_current_version :
-  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+  (unit, unit, [ `Zero ]) Caqti_request.t
 
 val last_insert_rowid :
-  (unit, 'a id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
+  (unit, 'a id, [ `One ]) Caqti_request.t
 
 module Job : sig
   val get :
-    ([`job] id, string, [< `Many | `One | `Zero > `One ])
+    ([`job] id, string, [ `One ])
       Caqti_request.t
   val get_id_by_name :
-    (string, [`job] id, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t
+    (string, [`job] id, [ `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, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    (string, unit, [ `Zero ]) Caqti_request.t
   val remove :
-    ([`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    ([`job] id, unit, [ `Zero ]) Caqti_request.t
 end
 
 module Tag : sig
   val get_id_by_name :
-    (string, [`tag] id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
+    (string, [`tag] id, [ `One ]) Caqti_request.t
   val try_add :
-    (string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    (string, unit, [ `Zero ]) Caqti_request.t
 end
 
 module Job_tag : sig
   val add :
-    ([`tag] id * string * [`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    ([`tag] id * string * [`job] id, unit, [ `Zero ]) Caqti_request.t
   val update :
-    ([`tag] id * string * [`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    ([`tag] id * string * [`job] id, unit, [ `Zero ]) Caqti_request.t
   val get_value :
-    ([`tag] id * [`job] id, string, [< `Many | `One | `Zero > `Zero `One ]) Caqti_request.t
+    ([`tag] id * [`job] id, string, [ `One | `Zero ]) Caqti_request.t
   val remove_by_job :
-    ([`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    ([`job] id, unit, [ `Zero ]) Caqti_request.t
 end
 
 module Build_artifact : sig
-  val get : ([`build_artifact] id, file, [< `Many | `One | `Zero > `One]) Caqti_request.t
+  val get : ([`build_artifact] id, file, [ `One]) Caqti_request.t
   val get_by_build_uuid :
     (Uuidm.t * Fpath.t, [`build_artifact] id * file,
-     [< `Many | `One | `Zero > `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 add :
-    (file * [`build] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    (file * [`build] id, unit, [ `Zero ]) Caqti_request.t
   val remove_by_build :
-    ([`build] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    ([`build] id, unit, [ `Zero ]) Caqti_request.t
   val remove :
-    ([`build_artifact] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    ([`build_artifact] id, unit, [ `Zero ]) Caqti_request.t
 end
 
 module Build :
@@ -112,7 +112,7 @@ sig
   }
 
   val get_by_uuid :
-    (Uuidm.t, [`build] id * t, [< `Many | `One | `Zero > `One `Zero ])
+    (Uuidm.t, [`build] id * t, [ `One | `Zero ])
       Caqti_request.t
   val get_all :
     ([`job] id, [`build] id * t, [ `Many | `One | `Zero ]) Caqti_request.t
@@ -121,18 +121,18 @@ sig
   val get_all_artifact_sha :
     ([`job] id * string option, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
   val get_latest_successful_with_binary :
-    ([`job] id * string, [`build] id * t * file option, [< `Many | `One | `Zero > `One `Zero ])
+    ([`job] id * string, [`build] id * t * file option, [ `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, [< `Many | `One | `Zero > `One `Zero ])
+    ([`job] id * string option, t, [ `One | `Zero ])
       Caqti_request.t
   val get_previous_successful_different_output :
-    ([`build] id, t, [< `Many | `One | `Zero > `One `Zero ])
+    ([`build] id, t, [ `One | `Zero ])
       Caqti_request.t
   val get_next_successful_different_output :
-    ([`build] id, t, [< `Many | `One | `Zero > `One `Zero ])
+    ([`build] id, t, [ `One | `Zero ])
       Caqti_request.t
   val get_same_input_same_output_builds :
     ([`build] id, t, [ `Many | `One | `Zero ]) Caqti_request.t
@@ -141,51 +141,51 @@ sig
   val get_different_input_same_output_input_ids :
     ([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
   val get_one_by_input_id :
-    (Cstruct.t, t, [< `Many | `One | `Zero > `One ]) Caqti_request.t
+    (Cstruct.t, t, [ `One ]) Caqti_request.t
   val get_platforms_for_job :
     ([`job] id, string, [ `Many | `One | `Zero ]) Caqti_request.t
-  val add : (t, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+  val add : (t, unit, [ `Zero ]) Caqti_request.t
   val get_by_hash :
-    (Cstruct.t, t, [< `Many | `One | `Zero > `One]) Caqti_request.t
+    (Cstruct.t, t, [ `One]) Caqti_request.t
   val get_with_main_binary_by_hash :
-    (Cstruct.t, t * file option, [< `Many | `One | `Zero > `One]) Caqti_request.t
+    (Cstruct.t, t * file option, [ `One]) Caqti_request.t
   val get_with_jobname_by_hash :
-    (Cstruct.t, string * t, [< `Many | `One | `Zero > `One `Zero]) Caqti_request.t
+    (Cstruct.t, string * t, [ `One | `Zero]) Caqti_request.t
-  val set_main_binary : ([`build] id * [`build_artifact] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+  val set_main_binary : ([`build] id * [`build_artifact] id, unit, [ `Zero ]) Caqti_request.t
-  val remove : ([`build] id, unit, [< `Many | `One | `Zero > `Zero]) Caqti_request.t
+  val remove : ([`build] id, unit, [ `Zero]) Caqti_request.t
 end
 
 module User : sig
   val get_user :
     (string, [`user] id * Builder_web_auth.scrypt Builder_web_auth.user_info,
-     [< `Many | `One | `Zero > `One `Zero ])
+     [ `One | `Zero ])
     Caqti_request.t
   val get_all :
     (unit, string, [ `Many | `One | `Zero ]) Caqti_request.t
   val add :
-    (Builder_web_auth.scrypt Builder_web_auth.user_info, unit, [< `Many | `One | `Zero > `Zero ])
+    (Builder_web_auth.scrypt Builder_web_auth.user_info, unit, [ `Zero ])
     Caqti_request.t
   val remove_user :
-    (string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    (string, unit, [ `Zero ]) Caqti_request.t
   val update_user :
-    (Builder_web_auth.scrypt Builder_web_auth.user_info, unit, [< `Many | `One | `Zero > `Zero ])
+    (Builder_web_auth.scrypt Builder_web_auth.user_info, unit, [ `Zero ])
     Caqti_request.t
 end
 
 module Access_list : sig
   val get :
-    ([`user] id * [`job] id, [`access_list] id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
+    ([`user] id * [`job] id, [`access_list] id, [ `One ]) Caqti_request.t
   val add :
-    ([`user] id * [`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    ([`user] id * [`job] id, unit, [ `Zero ]) Caqti_request.t
   val remove :
-    ([`user] id * [`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    ([`user] id * [`job] id, unit, [ `Zero ]) Caqti_request.t
   val remove_by_job :
-    ([`job] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    ([`job] id, unit, [ `Zero ]) Caqti_request.t
   val remove_all_by_username :
-    (string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+    (string, unit, [ `Zero ]) Caqti_request.t
 end
 
 val migrate :
-  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t list
+  (unit, unit, [ `Zero ]) Caqti_request.t list
 val rollback :
-  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t list
+  (unit, unit, [ `Zero ]) Caqti_request.t list

db/representation.ml

@@ -138,7 +138,6 @@ let user_info =
 
 (* this doesn't really belong in this module, but we need access to the type of [id] *)
 let last_insert_rowid =
-  Caqti_request.find
+  let open Caqti_request.Infix in
-    Caqti_type.unit
+  Caqti_type.unit ->! any_id @@
-    any_id
     "SELECT last_insert_rowid()"

lib/authorization.ml

@@ -6,14 +6,14 @@ open Lwt.Syntax
 
 let realm = "builder-web"
 
-let user_info_local = Dream.new_local ~name:"user_info" ()
+let user_info_field = Dream.new_field ~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 "Authorization" req with
+  match Dream.header req "Authorization" 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 handler (Dream.with_local user_info_local (id, user_info) req)
+             then (Dream.set_field req user_info_field (id, user_info); handler 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.local user_info_local req with
+  match Dream.field req user_info_field with
   | None -> Lwt.return (Error (`Msg "not authenticated"))
   | Some (id, user) ->
      if user.restricted then

lib/builder_web.ml

@@ -60,12 +60,6 @@ let mime_lookup path =
 let string_of_html =
   Format.asprintf "%a" (Tyxml.Html.pp ())
 
-let not_found req =
-  let path = "/" ^ String.concat "/" (Dream.path req) in
-  let referer = Dream.header "referer" req in
-  Views.page_not_found ~path ~referer
-  |> string_of_html |> Dream.html ~status:`Not_Found
-
 let or_error_response r =
   let* r = r in
   match r with
@@ -99,15 +93,7 @@ let get_uuid s =
        | None -> Error ("Bad uuid", `Bad_Request)
      else Error ("Bad uuid", `Bad_Request))
 
-let dream_svg ?status ?code ?headers body =
+let routes ~datadir ~cachedir ~configdir =
-  Dream.response ?status ?code ?headers body
-  |> Dream.with_header "Content-Type" "image/svg+xml"
-  |> Lwt.return
-
-let add_routes ~datadir ~cachedir ~configdir =
-  let datadir_global = Dream.new_global ~name:"datadir" (fun () -> datadir) in
-  let cachedir_global = Dream.new_global ~name:"cachedir" (fun () -> cachedir) in
-
   let builds req =
     Dream.sql req Model.jobs_with_section_synopsis
     |> if_error "Error getting jobs"
@@ -138,8 +124,8 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let job req =
-    let job_name = Dream.param "job" req in
+    let job_name = Dream.param req "job" in
-    let platform = Dream.query "platform" req 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 job_id platform) >|= fun builds ->
      (readme, builds))
@@ -151,8 +137,8 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let job_with_failed req =
-    let job_name = Dream.param "job" req in
+    let job_name = Dream.param req "job" in
-    let platform = Dream.query "platform" req 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))
@@ -164,9 +150,10 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let redirect_latest req =
-    let job_name = Dream.param "job" req in
+    let job_name = Dream.param req "job" in
-    let platform = Dream.query "platform" req in
+    let platform = Dream.query req "platform" in
-    let path = Dream.path req |> String.concat "/" in
+    (* FIXME *)
+    let path = begin[@alert "-deprecated"] Dream.path req |> String.concat "/" end 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
@@ -177,8 +164,8 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let redirect_main_binary req =
-    let job_name = Dream.param "job" req
+    let job_name = Dream.param req "job"
-    and build = Dream.param "build" req in
+    and build = Dream.param req "build" in
     get_uuid build >>= fun uuid ->
     Dream.sql req (Model.build uuid)
     |> if_error "Error getting job build"
@@ -213,20 +200,18 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let job_build_viz viz_typ req =
-    let _job_name = Dream.param "job" req
+    let _job_name = Dream.param req "job"
-    and build = Dream.param "build" req
+    and build = Dream.param req "build" in
-    and cachedir = Dream.global cachedir_global req in
     get_uuid build >>= fun uuid ->
-    (try_load_cached_visualization ~cachedir ~uuid viz_typ
+    try_load_cached_visualization ~cachedir ~uuid viz_typ
-     |> if_error "Error getting cached visualization")
+    |> if_error ~status:`Not_Found "Error getting cached visualization"
     >>= fun svg_html ->
     Lwt_result.ok (Dream.html svg_html)
   in
 
   let job_build req =
-    let datadir = Dream.global datadir_global req in
+    let job_name = Dream.param req "job"
-    let job_name = Dream.param "job" req
+    and build = Dream.param req "build" in
-    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) ->
@@ -261,11 +246,11 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let job_build_file req =
-    let datadir = Dream.global datadir_global req in
+    let _job_name = Dream.param req "job"
-    let _job_name = Dream.param "job" req
+    and build = Dream.param req "build"
-    and build = Dream.param "build" req
+    (* FIXME *)
-    and filepath = Dream.path req |> String.concat "/" in
+    and filepath = begin[@alert "-deprecated"] Dream.path req |> String.concat "/" end in
-    let if_none_match = Dream.header "if-none-match" req in
+    let if_none_match = Dream.header req "if-none-match" 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. *)
@@ -292,9 +277,8 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let job_build_static_file (file : [< `Console | `Script ]) req =
-    let datadir = Dream.global datadir_global req in
+    let _job_name = Dream.param req "job"
-    let _job_name = Dream.param "job" req
+    and build = Dream.param req "build" in
-    and build = Dream.param "build" req in
     get_uuid build >>= fun build ->
     (match file with
     | `Console ->
@@ -309,10 +293,10 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let failed_builds req =
-    let platform = Dream.query "platform" req in
+    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 "start" req) in
+    let start = to_int 0 (Dream.query req "start") in
-    let count = to_int 10 (Dream.query "count" req) 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"
@@ -322,9 +306,8 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let job_build_tar req =
-    let datadir = Dream.global datadir_global req in
+    let _job_name = Dream.param req "job"
-    let _job_name = Dream.param "job" req
+    and build = Dream.param req "build" in
-    and build = Dream.param "build" req in
     get_uuid build >>= fun build ->
     Dream.sql req (Model.build build)
     |> if_error "Error getting build" >>= fun (build_id, build) ->
@@ -359,9 +342,7 @@ let add_routes ~datadir ~cachedir ~configdir =
         (Fmt.str "Build with same uuid exists: %a\n" Uuidm.pp uuid)
       |> Lwt_result.ok
     | false ->
-      let datadir = Dream.global datadir_global req in
+      (Lwt.return (Dream.field req Authorization.user_info_field |>
-      let cachedir = Dream.global cachedir_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))
       |> if_error "Internal server error"
@@ -370,7 +351,8 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let hash req =
-    Dream.query "sha256" req |> Option.to_result ~none:(`Msg "Missing sha256 query parameter") |> Lwt.return
+    Dream.query req "sha256" |> Option.to_result ~none:(`Msg "Missing sha256 query parameter")
+    |> Lwt.return
     |> if_error ~status:`Bad_Request "Bad request" >>= fun hash_hex ->
     begin try Hex.to_cstruct (`Hex hash_hex) |> Lwt_result.return
       with Invalid_argument e -> Lwt_result.fail (`Msg ("Bad hex: " ^ e))
@@ -384,9 +366,8 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let compare_builds req =
-    let datadir = Dream.global datadir_global req in
+    let build_left = Dream.param req "build_left" in
-    let build_left = Dream.param "build_left" req in
+    let build_right = Dream.param req "build_right" 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 ->
@@ -429,10 +410,10 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let upload_binary req =
-    let job = Dream.param "job" req in
+    let job = Dream.param req "job" in
-    let platform = Dream.param "platform" req in
+    let platform = Dream.param req "platform" in
     let binary_name =
-      Dream.query "binary_name" req
+      Dream.query req "binary_name"
       |> Option.map Fpath.of_string
       |> Option.value ~default:(Ok Fpath.(v job + "bin"))
     in
@@ -453,14 +434,12 @@ let add_routes ~datadir ~cachedir ~configdir =
         (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 cachedir = Dream.global cachedir_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.local Authorization.user_info_local req |>
+      (Lwt.return (Dream.field req Authorization.user_info_field |>
                    Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) ->
        Dream.sql req (Model.add_build ~datadir ~cachedir ~configdir user_id exec))
       |> if_error "Internal server error"
@@ -484,7 +463,7 @@ let add_routes ~datadir ~cachedir ~configdir =
 
   let w f req = or_error_response (f req) in
 
-  Dream.router [
+  [
     Dream.get "/" (w builds);
     Dream.get "/job" (w redirect_parent);
     Dream.get "/job/:job" (w job);

lib/dream_tar.ml

@@ -1,16 +1,16 @@
 open Lwt.Infix
 
 module Writer = struct
-  type out_channel = Dream.response
+  type out_channel = Dream.stream
   type 'a t = 'a Lwt.t
-  let really_write response cs =
+  let really_write stream cs =
-    Dream.write response (Cstruct.to_string cs)
+    Dream.write stream (Cstruct.to_string cs)
 end
 
 module HW = Tar.HeaderWriter(Lwt)(Writer)
 
-let write_block (header : Tar.Header.t) lpath response =
+let write_block (header : Tar.Header.t) lpath stream =
-  HW.write ~level:Tar.Header.Ustar header response >>= fun () ->
+  HW.write ~level:Tar.Header.Ustar header stream >>= fun () ->
   Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string lpath) >>= fun ic ->
   let buf_len = 4 * 1024 * 1024 in
   let buf = Bytes.create buf_len in
@@ -19,11 +19,11 @@ let write_block (header : Tar.Header.t) lpath response =
     if r = 0 then
       Lwt.return_unit
     else
-      Dream.write response (Bytes.sub_string buf 0 r) >>= fun () ->
+      Dream.write stream (Bytes.sub_string buf 0 r) >>= fun () ->
       loop ()
   in
   loop () >>= fun () ->
-  Dream.write_buffer response (Cstruct.to_bigarray (Tar.Header.zero_padding header))
+  Dream.write stream (Cstruct.to_string (Tar.Header.zero_padding header))
 
 let header_of_file mod_time (file : Builder_db.file) =
   let file_mode = if Fpath.is_prefix Fpath.(v "bin/") file.filepath then
@@ -33,11 +33,12 @@ let header_of_file mod_time (file : Builder_db.file) =
   in
   Tar.Header.make ~file_mode ~mod_time (Fpath.to_string file.filepath) (Int64.of_int file.size)
 
-let tar_response datadir finish (files : Builder_db.file list) (response : Dream.response) =
+let tar_response datadir finish (files : Builder_db.file list) (stream : Dream.stream) =
   Lwt_list.iter_s (fun file ->
       let hdr = header_of_file finish file in
-      write_block hdr Fpath.(datadir // file.localpath) response)
+      write_block hdr Fpath.(datadir // file.localpath) stream)
     files >>= fun () ->
-  Writer.really_write response Tar.Header.zero_block >>= fun () ->
+  Writer.really_write stream Tar.Header.zero_block >>= fun () ->
-  Writer.really_write response Tar.Header.zero_block >>= fun () ->
+  Writer.really_write stream Tar.Header.zero_block >>= fun () ->
-  Dream.close_stream response
+  Dream.flush stream >>= fun () ->
+  Dream.close stream