diff --git a/bin/builder_db_app.ml b/bin/builder_db_app.ml index 08ab6d9..684ee43 100644 --- a/bin/builder_db_app.ml +++ b/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 - "PRAGMA defer_foreign_keys = ON" + 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* () = Db.exec foreign_keys () in + let* (module Db : Caqti_blocking.CONNECTION) = Caqti_blocking.connect ~tweaks_version:(1,8) uri in let* () = Db.exec defer_foreign_keys () in Ok (module Db : Caqti_blocking.CONNECTION) @@ -179,19 +174,16 @@ let job_remove () datadir jobname = or_die 1 r let input_ids = - Caqti_request.collect - Caqti_type.unit - Builder_db.Rep.cstruct - "SELECT DISTINCT input_id FROM build WHERE input_id IS NOT NULL" + Caqti_type.unit ->* Builder_db.Rep.cstruct @@ + "SELECT DISTINCT input_id FROM build WHERE input_id IS NOT NULL" let main_artifact_hash = - Caqti_request.collect - Builder_db.Rep.cstruct - (Caqti_type.tup3 Builder_db.Rep.cstruct Builder_db.Rep.uuid Caqti_type.string) - {| - SELECT a.sha256, b.uuid, j.name FROM build_artifact a, build b, job j - WHERE b.input_id = ? AND a.id = b.main_binary AND b.job = j.id - |} + Builder_db.Rep.cstruct ->* + Caqti_type.tup3 Builder_db.Rep.cstruct Builder_db.Rep.uuid Caqti_type.string @@ + {| + SELECT a.sha256, b.uuid, j.name FROM build_artifact a, build b, job j + WHERE b.input_id = ? AND a.id = b.main_binary AND b.job = j.id + |} let verify_input_id () dbpath = let r = @@ -219,26 +211,25 @@ let verify_input_id () dbpath = or_die 1 r let num_build_artifacts = - Caqti_request.find - Caqti_type.unit - Caqti_type.int - "SELECT count(*) FROM build_artifact" + Caqti_type.unit ->! Caqti_type.int @@ + "SELECT count(*) FROM build_artifact" let build_artifacts : (unit, string * Uuidm.t * (Fpath.t * Fpath.t * Cstruct.t * int64), [ `One | `Zero | `Many ]) Caqti_request.t = - Caqti_request.collect - Caqti_type.unit - Caqti_type.(tup3 string Builder_db.Rep.uuid (tup4 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct int64)) - {| SELECT job.name, b.uuid, a.filepath, a.localpath, a.sha256, a.size - FROM build_artifact a, build b, job - WHERE a.build = b.id AND b.job = job.id |} + Caqti_type.unit ->* + Caqti_type.(tup3 string Builder_db.Rep.uuid + (tup4 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct int64)) + @@ + {| SELECT job.name, b.uuid, a.filepath, a.localpath, a.sha256, a.size + FROM build_artifact a, build b, job + WHERE a.build = b.id AND b.job = job.id |} let script_and_console : (unit, _, [`One | `Zero | `Many ]) Caqti_request.t = - Caqti_request.collect - Caqti_type.unit - Caqti_type.(tup4 string Builder_db.Rep.uuid Builder_db.Rep.fpath Builder_db.Rep.fpath) - {| SELECT job.name, b.uuid, b.console, b.script - FROM build b, job - WHERE job.id = b.job |} + Caqti_type.unit ->* + Caqti_type.(tup4 string Builder_db.Rep.uuid Builder_db.Rep.fpath Builder_db.Rep.fpath) + @@ + {| SELECT job.name, b.uuid, b.console, b.script + FROM build b, job + WHERE job.id = b.job |} module FpathSet = Set.Make(Fpath) diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 0b246de..78c3e42 100644 --- a/bin/builder_web_app.ml +++ b/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 - @@ Builder_web.not_found + @@ Dream.router (Builder_web.routes ~datadir ~cachedir ~configdir) open Cmdliner diff --git a/bin/migrations/grej.ml b/bin/migrations/grej.ml index 0facbc3..77984bd 100644 --- a/bin/migrations/grej.ml +++ b/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 - (Printf.sprintf "PRAGMA user_version = %Ld" version) + Caqti_type.unit ->. Caqti_type.unit @@ + 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 - (Printf.sprintf "PRAGMA foreign_keys = %s" on) + Caqti_type.unit ->. Caqti_type.unit @@ + Printf.sprintf "PRAGMA foreign_keys = %s" on diff --git a/bin/migrations/m20210126.ml b/bin/migrations/m20210126.ml index 6c06c00..d413b9c 100644 --- a/bin/migrations/m20210126.ml +++ b/bin/migrations/m20210126.ml @@ -3,32 +3,27 @@ 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 - (Printf.sprintf "PRAGMA application_id = %ld" Builder_db.application_id) + Caqti_type.unit ->. Caqti_type.unit @@ + Printf.sprintf "PRAGMA application_id = %ld" Builder_db.application_id let alter_build = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "ALTER TABLE build ADD COLUMN main_binary TEXT" + 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 - "SELECT id FROM build" + 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) - "SELECT id, filepath FROM build_artifact WHERE build = ? AND filepath LIKE 'bin/%'" + 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)) - "UPDATE build SET main_binary = $2 WHERE id = $1" + Caqti_type.(tup2 int64 (option string)) ->. Caqti_type.unit @@ + "UPDATE build SET main_binary = $2 WHERE id = $1" let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = let open Grej.Infix in @@ -52,39 +47,36 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = Db.exec (Grej.set_version new_version) () let rename_build = - Caqti_request.exec - Caqti_type.unit - "ALTER TABLE build RENAME TO __tmp_build" + Caqti_type.unit ->. Caqti_type.unit @@ + "ALTER TABLE build RENAME TO __tmp_build" let create_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_kind TINYINT NOT NULL, - result_code INTEGER, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_kind TINYINT NOT NULL, + result_code INTEGER, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + job INTEGER NOT NULL, - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let rollback_data = - Caqti_request.exec - Caqti_type.unit - {| INSERT INTO build - SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, - result_kind, result_code, result_msg, console, script, job - FROM __tmp_build - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| INSERT INTO build + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, + result_kind, result_code, result_msg, console, script, job + FROM __tmp_build + |} let rollback _datadir (module Db : Caqti_blocking.CONNECTION) = let open Grej.Infix in diff --git a/bin/migrations/m20210202.ml b/bin/migrations/m20210202.ml index 06c6423..29e4b40 100644 --- a/bin/migrations/m20210202.ml +++ b/bin/migrations/m20210202.ml @@ -7,18 +7,16 @@ open Grej.Infix let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = let job_build_idx = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "CREATE INDEX job_build_idx ON build(job)"; + Caqti_type.unit ->. Caqti_type.unit @@ + "CREATE INDEX job_build_idx ON build(job)"; in Grej.check_version ~user_version:1L (module Db) >>= fun () -> Db.exec job_build_idx () let rollback _datadir (module Db : Caqti_blocking.CONNECTION) = let q = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "DROP INDEX IF EXISTS job_build_idx" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP INDEX IF EXISTS job_build_idx" in Grej.check_version ~user_version:1L (module Db) >>= fun () -> Db.exec q () diff --git a/bin/migrations/m20210216.ml b/bin/migrations/m20210216.ml index 7daa8d6..154cd5a 100644 --- a/bin/migrations/m20210216.ml +++ b/bin/migrations/m20210216.ml @@ -4,46 +4,43 @@ 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 - "DROP TABLE user" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE user" let new_user = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - {| CREATE TABLE user ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - username VARCHAR(255) NOT NULL UNIQUE, - password_hash BLOB NOT NULL, - password_salt BLOB NOT NULL, - scrypt_n INTEGER NOT NULL, - scrypt_r INTEGER NOT NULL, - scrypt_p INTEGER NOT NULL - ) - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE user ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + username VARCHAR(255) NOT NULL UNIQUE, + password_hash BLOB NOT NULL, + password_salt BLOB NOT NULL, + scrypt_n INTEGER NOT NULL, + scrypt_r INTEGER NOT NULL, + scrypt_p INTEGER NOT NULL + ) + |} let old_user = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE user ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - username VARCHAR(255) NOT NULL UNIQUE, - password_hash BLOB NOT NULL, - password_salt BLOB NOT NULL, - password_iter INTEGER NOT NULL - ) - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE user ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + username VARCHAR(255) NOT NULL UNIQUE, + password_hash BLOB NOT NULL, + password_salt BLOB NOT NULL, + password_iter INTEGER NOT NULL + ) + |} 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 () -> diff --git a/bin/migrations/m20210218.ml b/bin/migrations/m20210218.ml index 01ea7dc..57384e6 100644 --- a/bin/migrations/m20210218.ml +++ b/bin/migrations/m20210218.ml @@ -4,86 +4,75 @@ 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" -let new_build_artifact = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - {| CREATE TABLE new_build_artifact ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - filepath TEXT NOT NULL, -- the path as in the build - localpath TEXT NOT NULL, -- local path to the file on disk - sha256 BLOB NOT NULL, - size INTEGER NOT NULL, - build INTEGER NOT NULL, +open Grej.Infix - FOREIGN KEY(build) REFERENCES build(id), - UNIQUE(build, filepath) - ) - |} +let new_build_artifact = + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build_artifact ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + filepath TEXT NOT NULL, -- the path as in the build + localpath TEXT NOT NULL, -- local path to the file on disk + sha256 BLOB NOT NULL, + size INTEGER NOT NULL, + build INTEGER NOT NULL, + + FOREIGN KEY(build) REFERENCES build(id), + UNIQUE(build, filepath) + ) + |} let new_build_file = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - {| CREATE TABLE new_build_file ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - filepath TEXT NOT NULL, -- the path as in the build - localpath TEXT NOT NULL, -- local path to the file on disk - sha256 BLOB NOT NULL, - size INTEGER NOT NULL, - build INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build_file ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + filepath TEXT NOT NULL, -- the path as in the build + localpath TEXT NOT NULL, -- local path to the file on disk + sha256 BLOB NOT NULL, + size INTEGER NOT NULL, + build INTEGER NOT NULL, - FOREIGN KEY(build) REFERENCES build(id), - UNIQUE(build, filepath) - ) - |} + FOREIGN KEY(build) REFERENCES build(id), + UNIQUE(build, filepath) + ) + |} let collect_build_artifact = - Caqti_request.collect ~oneshot:true - Caqti_type.unit - Caqti_type.(tup3 int64 (tup3 string string octets) int64) - "SELECT id, filepath, localpath, sha256, build FROM build_artifact" + 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) - "SELECT id, filepath, localpath, sha256, build FROM build_file" + 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) - {| INSERT INTO new_build_artifact (id, filepath, localpath, sha256, size, build) - VALUES (?, ?, ?, ?, ?, ?) - |} + Caqti_type.(tup3 int64 (tup4 string string octets int64) int64) ->. Caqti_type.unit @@ + {| 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) - {| INSERT INTO new_build_file (id, filepath, localpath, sha256, size, build) - VALUES (?, ?, ?, ?, ?, ?) - |} + Caqti_type.(tup3 int64 (tup4 string string octets int64) int64) ->. Caqti_type.unit @@ + {| INSERT INTO new_build_file (id, filepath, localpath, sha256, size, build) + VALUES (?, ?, ?, ?, ?, ?) + |} let drop_build_artifact = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "DROP TABLE build_artifact" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE build_artifact" let drop_build_file = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "DROP TABLE build_file" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE build_file" let rename_build_artifact = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "ALTER TABLE new_build_artifact RENAME TO build_artifact" + 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 - "ALTER TABLE new_build_file RENAME TO build_file" + 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,47 +99,42 @@ 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 - {| CREATE TABLE new_build_artifact ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - filepath TEXT NOT NULL, -- the path as in the build - localpath TEXT NOT NULL, -- local path to the file on disk - sha256 BLOB NOT NULL, - build INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build_artifact ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + filepath TEXT NOT NULL, -- the path as in the build + localpath TEXT NOT NULL, -- local path to the file on disk + sha256 BLOB NOT NULL, + build INTEGER NOT NULL, - FOREIGN KEY(build) REFERENCES build(id), - UNIQUE(build, filepath) - ) - |} + FOREIGN KEY(build) REFERENCES build(id), + UNIQUE(build, filepath) + ) + |} let old_build_file = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - {| CREATE TABLE new_build_file ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - filepath TEXT NOT NULL, -- the path as in the build - localpath TEXT NOT NULL, -- local path to the file on disk - sha256 BLOB NOT NULL, - build INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build_file ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + filepath TEXT NOT NULL, -- the path as in the build + localpath TEXT NOT NULL, -- local path to the file on disk + sha256 BLOB NOT NULL, + build INTEGER NOT NULL, - FOREIGN KEY(build) REFERENCES build(id), - UNIQUE(build, filepath) - ) - |} + FOREIGN KEY(build) REFERENCES build(id), + UNIQUE(build, filepath) + ) + |} let copy_build_artifact = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "INSERT INTO new_build_artifact SELECT id, filepath, localpath, sha256, build FROM build_artifact" + 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 - "INSERT INTO new_build_file SELECT id, filepath, localpath, sha256, build FROM build_file" + 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 () -> diff --git a/bin/migrations/m20210308.ml b/bin/migrations/m20210308.ml index faac6f5..abca0b9 100644 --- a/bin/migrations/m20210308.ml +++ b/bin/migrations/m20210308.ml @@ -1,17 +1,16 @@ 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) - {| SELECT b.id, b.uuid, job.name FROM build b, job - WHERE result_kind = 0 AND result_code = 0 AND main_binary IS NOT NULL AND job.id = b.job AND - (SELECT COUNT( * ) FROM build_artifact a - WHERE a.build = b.id and a.filepath = b.main_binary) = 0 - |} + Caqti_type.unit ->* Caqti_type.tup3 (Rep.id `build) Rep.uuid Caqti_type.string @@ + {| SELECT b.id, b.uuid, job.name FROM build b, job + WHERE result_kind = 0 AND result_code = 0 AND main_binary IS NOT NULL AND job.id = b.job AND + (SELECT COUNT( * ) FROM build_artifact a + WHERE a.build = b.id and a.filepath = b.main_binary) = 0 + |} let fixup datadir (module Db : Caqti_blocking.CONNECTION) = - let 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 diff --git a/bin/migrations/m20210427.ml b/bin/migrations/m20210427.ml index a3338ff..240bd76 100644 --- a/bin/migrations/m20210427.ml +++ b/bin/migrations/m20210427.ml @@ -7,14 +7,12 @@ open Grej.Infix let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = let idx_build_job_start = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)" + 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 - "DROP INDEX IF EXISTS job_build_idx" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP INDEX IF EXISTS job_build_idx" in Grej.check_version ~user_version:old_version (module Db) >>= fun () -> Db.exec rm_job_build_idx () >>= fun () -> @@ -22,14 +20,12 @@ 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 - "CREATE INDEX job_build_idx ON build(job)" + 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 - "DROP INDEX IF EXISTS idx_build_job_start" + 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 () -> Db.exec rm_idx_build_job_start () >>= fun () -> diff --git a/bin/migrations/m20210531.ml b/bin/migrations/m20210531.ml index 6e15bbc..99d3e7a 100644 --- a/bin/migrations/m20210531.ml +++ b/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) - "SELECT id, localpath FROM build_artifact" + 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.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath ->. Caqti_type.unit @@ "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) -> diff --git a/bin/migrations/m20210602.ml b/bin/migrations/m20210602.ml index 75effd9..3889d4d 100644 --- a/bin/migrations/m20210602.ml +++ b/bin/migrations/m20210602.ml @@ -3,117 +3,114 @@ 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 - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)" + 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 - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_kind TINYINT NOT NULL, - result_code INTEGER, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_kind TINYINT NOT NULL, + result_code INTEGER, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + job INTEGER NOT NULL, - FOREIGN KEY(main_binary) REFERENCES build_artifact(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let old_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_kind TINYINT NOT NULL, - result_code INTEGER, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary TEXT, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_kind TINYINT NOT NULL, + result_code INTEGER, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary TEXT, + job INTEGER NOT NULL, - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let collect_old_build = - Caqti_request.collect ~oneshot:true - Caqti_type.unit - Caqti_type.(tup3 Builder_db.Rep.untyped_id - (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option string))) - Builder_db.Rep.untyped_id) - {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg, - console, script, main_binary, job - FROM build |} + Caqti_type.unit ->* + Caqti_type.(tup3 Builder_db.Rep.untyped_id + (tup3 (tup4 string int64 int64 int64) + (tup4 int64 int (option int) (option string)) + (tup3 octets string (option string))) + Builder_db.Rep.untyped_id) @@ + {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg, + console, script, main_binary, job + FROM build |} let insert_new_build = - Caqti_request.exec ~oneshot:true - Caqti_type.(tup3 Builder_db.Rep.untyped_id - (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option Builder_db.Rep.untyped_id))) - Builder_db.Rep.untyped_id) - {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, - result_code, result_msg, console, script, main_binary, job) - VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |} + Caqti_type.(tup3 Builder_db.Rep.untyped_id + (tup3 (tup4 string int64 int64 int64) + (tup4 int64 int (option int) (option string)) + (tup3 octets string (option Builder_db.Rep.untyped_id))) + Builder_db.Rep.untyped_id) ->. 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 - "SELECT id FROM build_artifact WHERE build = $1 AND filepath = $2" + 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.(tup3 Builder_db.Rep.untyped_id - (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option Builder_db.Rep.untyped_id))) - Builder_db.Rep.untyped_id) - {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg, - console, script, main_binary, job - FROM build |} + Caqti_type.unit ->* + Caqti_type.(tup3 Builder_db.Rep.untyped_id + (tup3 (tup4 string int64 int64 int64) + (tup4 int64 int (option int) (option string)) + (tup3 octets string (option Builder_db.Rep.untyped_id))) + Builder_db.Rep.untyped_id) @@ + {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg, + console, script, main_binary, job + FROM build |} let insert_old_build = - Caqti_request.exec ~oneshot:true - Caqti_type.(tup3 Builder_db.Rep.untyped_id - (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option string))) - Builder_db.Rep.untyped_id) - {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, - result_code, result_msg, console, script, main_binary, job) - VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |} + Caqti_type.(tup3 Builder_db.Rep.untyped_id + (tup3 (tup4 string int64 int64 int64) + (tup4 int64 int (option int) (option string)) + (tup3 octets string (option string))) + Builder_db.Rep.untyped_id) ->. 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 -> diff --git a/bin/migrations/m20210608.ml b/bin/migrations/m20210608.ml index c3cccc9..ac75c32 100644 --- a/bin/migrations/m20210608.ml +++ b/bin/migrations/m20210608.ml @@ -3,87 +3,79 @@ 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 - {| CREATE TABLE new_user ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - username VARCHAR(255) NOT NULL UNIQUE, - password_hash BLOB NOT NULL, - password_salt BLOB NOT NULL, - scrypt_n INTEGER NOT NULL, - scrypt_r INTEGER NOT NULL, - scrypt_p INTEGER NOT NULL, - restricted BOOLEAN NOT NULL - ) - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_user ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + username VARCHAR(255) NOT NULL UNIQUE, + password_hash BLOB NOT NULL, + password_salt BLOB NOT NULL, + scrypt_n INTEGER NOT NULL, + scrypt_r INTEGER NOT NULL, + scrypt_p INTEGER NOT NULL, + restricted BOOLEAN NOT NULL + ) + |} let old_user = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_user ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - username VARCHAR(255) NOT NULL UNIQUE, - password_hash BLOB NOT NULL, - password_salt BLOB NOT NULL, - scrypt_n INTEGER NOT NULL, - scrypt_r INTEGER NOT NULL, - scrypt_p INTEGER NOT NULL - ) - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_user ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + username VARCHAR(255) NOT NULL UNIQUE, + password_hash BLOB NOT NULL, + password_salt BLOB NOT NULL, + scrypt_n INTEGER NOT NULL, + scrypt_r INTEGER NOT NULL, + scrypt_p INTEGER NOT NULL + ) + |} let collect_old_user = - Caqti_request.collect - Caqti_type.unit - Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64)) - "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p FROM user" + Caqti_type.unit ->* + Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64)) @@ + "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p FROM user" let collect_new_user = - Caqti_request.collect - Caqti_type.unit - Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool)) - "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted FROM user" + Caqti_type.unit ->* + Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool)) @@ + "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted FROM user" let insert_new_user = - Caqti_request.exec - Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool)) - "INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) VALUES (?, ?, ?, ?, ?, ?, ?, ?)" + 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)) - "INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p) VALUES (?, ?, ?, ?, ?, ?, ?)" + 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 - {| CREATE TABLE access_list ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - user INTEGER NOT NULL, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE access_list ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + user INTEGER NOT NULL, + job INTEGER NOT NULL, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id), - UNIQUE(user, job) - ) - |} + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id), + UNIQUE(user, job) + ) + |} let rollback_access_list = - Caqti_request.exec - Caqti_type.unit - "DROP TABLE IF EXISTS access_list" - -open Grej.Infix + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE IF EXISTS access_list" let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = Grej.check_version ~user_version:old_version (module Db) >>= fun () -> diff --git a/bin/migrations/m20210609.ml b/bin/migrations/m20210609.ml index 5bc7e34..73c5c8d 100644 --- a/bin/migrations/m20210609.ml +++ b/bin/migrations/m20210609.ml @@ -3,100 +3,92 @@ 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 - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)" + 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 - "INSERT INTO user (username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) \ - VALUES ('nologin', x'', x'', 16384, 8, 1, true)" + 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 - "DELETE FROM user WHERE username = 'nologin'" + Caqti_type.unit ->. Caqti_type.unit @@ + "DELETE FROM user WHERE username = 'nologin'" let new_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_kind TINYINT NOT NULL, - result_code INTEGER, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_kind TINYINT NOT NULL, + result_code INTEGER, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, - FOREIGN KEY(main_binary) REFERENCES build_artifact(id), - FOREIGN KEY(job) REFERENCES job(id), - FOREIGN KEY(user) REFERENCES user(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id), + FOREIGN KEY(job) REFERENCES job(id), + FOREIGN KEY(user) REFERENCES user(id) + ) + |} let old_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_kind TINYINT NOT NULL, - result_code INTEGER, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_kind TINYINT NOT NULL, + result_code INTEGER, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + job INTEGER NOT NULL, - FOREIGN KEY(main_binary) REFERENCES build_artifact(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let insert_from_old_build = - Caqti_request.exec ~oneshot:true - (Builder_db.Rep.id (`user : [`user])) - {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, - result_kind, result_code, result_msg, console, - script, main_binary, job, user) - SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, - result_code, result_msg, console, script, main_binary, job, ? - FROM build |} + Builder_db.Rep.id (`user : [`user]) ->. Caqti_type.unit @@ + {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, + result_kind, result_code, result_msg, console, + script, main_binary, job, user) + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, + result_code, result_msg, console, script, main_binary, job, ? + FROM build |} let insert_from_new_build = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, - result_kind, result_code, result_msg, console, - script, main_binary, job) - SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, - result_code, result_msg, console, script, main_binary, job - FROM build |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, + result_kind, result_code, result_msg, console, + script, main_binary, job) + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, + result_code, result_msg, console, script, main_binary, job + FROM build |} let drop_build = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "DROP TABLE build" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE build" let rename_build = - Caqti_request.exec ~oneshot:true - Caqti_type.unit - "ALTER TABLE new_build RENAME TO build" - -open Grej.Infix + Caqti_type.unit ->. Caqti_type.unit @@ + "ALTER TABLE new_build RENAME TO build" let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = Grej.check_version ~user_version:old_version (module Db) >>= fun () -> diff --git a/bin/migrations/m20210625.ml b/bin/migrations/m20210625.ml index 1f88908..9d2e27c 100644 --- a/bin/migrations/m20210625.ml +++ b/bin/migrations/m20210625.ml @@ -3,28 +3,26 @@ let identifier = "2021-06-25" let migrate_doc = "drop build_file table" let rollback_doc = "recreate build_file table" -let build_file = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE build_file ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - filepath TEXT NOT NULL, -- the path as in the build - localpath TEXT NOT NULL, -- local path to the file on disk - sha256 BLOB NOT NULL, - size INTEGER NOT NULL, - build INTEGER NOT NULL, +open Grej.Infix - FOREIGN KEY(build) REFERENCES build(id), - UNIQUE(build, filepath) - ) - |} +let build_file = + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE build_file ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + filepath TEXT NOT NULL, -- the path as in the build + localpath TEXT NOT NULL, -- local path to the file on disk + sha256 BLOB NOT NULL, + size INTEGER NOT NULL, + build INTEGER NOT NULL, + + FOREIGN KEY(build) REFERENCES build(id), + UNIQUE(build, filepath) + ) + |} let drop_build_file = - Caqti_request.exec - Caqti_type.unit - "DROP TABLE build_file" - -open Grej.Infix + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE build_file" let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = Grej.check_version ~user_version:old_version (module Db) >>= fun () -> diff --git a/bin/migrations/m20210629.ml b/bin/migrations/m20210629.ml index 4181b52..2dc2e8d 100644 --- a/bin/migrations/m20210629.ml +++ b/bin/migrations/m20210629.ml @@ -3,55 +3,50 @@ 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 - {| CREATE TABLE tag ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - tag VARCHAR(255) NOT NULL UNIQUE - ) - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE tag ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + tag VARCHAR(255) NOT NULL UNIQUE + ) + |} let job_tag = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE job_tag ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - tag INTEGER NOT NULL, - value TEXT NOT NULL, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE job_tag ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + tag INTEGER NOT NULL, + value TEXT NOT NULL, + job INTEGER NOT NULL, - FOREIGN KEY(job) REFERENCES job(id), - FOREIGN KEY(tag) REFERENCES tag(id), - UNIQUE(tag, job) - ) - |} + FOREIGN KEY(job) REFERENCES job(id), + FOREIGN KEY(tag) REFERENCES tag(id), + UNIQUE(tag, job) + ) + |} let jobs = - Caqti_request.collect - Caqti_type.unit - Builder_db.Rep.untyped_id - "SELECT id FROM job" + 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 - {| SELECT b.id - FROM build b - WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0 - ORDER BY b.start_d DESC, b.start_ps DESC - LIMIT 1 - |} + Builder_db.Rep.untyped_id ->? Builder_db.Rep.untyped_id @@ + {| SELECT b.id + FROM build b + WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0 + ORDER BY b.start_d DESC, b.start_ps DESC + LIMIT 1 + |} let build_artifacts = - Caqti_request.collect - Builder_db.Rep.untyped_id - Caqti_type.(tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath) - {| SELECT a.filepath, a.localpath - FROM build_artifact a - WHERE a.build = ? - |} + Builder_db.Rep.untyped_id ->* + Caqti_type.tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@ + {| SELECT a.filepath, a.localpath + FROM build_artifact a + WHERE a.build = ? + |} let infer_section_and_synopsis artifacts = @@ -99,32 +94,25 @@ let infer_section_and_synopsis artifacts = Some section, infer_synopsis_and_descr opam_switch let remove_tag = - Caqti_request.exec - Caqti_type.unit - "DROP TABLE tag" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE tag" let remove_job_tag = - Caqti_request.exec - Caqti_type.unit - "DROP TABLE job_tag" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE job_tag" let insert_tag = - Caqti_request.exec - Caqti_type.string - "INSERT INTO tag (tag) VALUES (?)" + Caqti_type.string ->. Caqti_type.unit @@ + "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) - "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)" + 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 - "SELECT id FROM tag where tag = ?" - -open Grej.Infix + Caqti_type.string ->! Builder_db.Rep.untyped_id @@ + "SELECT id FROM tag where tag = ?" let migrate datadir (module Db : Caqti_blocking.CONNECTION) = Grej.check_version ~user_version:old_version (module Db) >>= fun () -> diff --git a/bin/migrations/m20210630.ml b/bin/migrations/m20210630.ml index b59d644..555f881 100644 --- a/bin/migrations/m20210630.ml +++ b/bin/migrations/m20210630.ml @@ -3,59 +3,49 @@ 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 - "SELECT id FROM job" + 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 - {| SELECT b.id - FROM build b - WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0 - ORDER BY b.start_d DESC, b.start_ps DESC - LIMIT 1 - |} + Builder_db.Rep.untyped_id ->? Builder_db.Rep.untyped_id @@ + {| SELECT b.id + FROM build b + WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0 + ORDER BY b.start_d DESC, b.start_ps DESC + LIMIT 1 + |} let build_artifacts = - Caqti_request.collect - Builder_db.Rep.untyped_id - Caqti_type.(tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath) - {| SELECT a.filepath, a.localpath - FROM build_artifact a - WHERE a.build = ? - |} + Builder_db.Rep.untyped_id ->* + Caqti_type.tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@ + {| SELECT a.filepath, a.localpath + FROM build_artifact a + WHERE a.build = ? + |} let insert_tag = - Caqti_request.exec - Caqti_type.string - "INSERT INTO tag (tag) VALUES (?)" + Caqti_type.string ->. Caqti_type.unit @@ + "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) - "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)" + 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 - "SELECT id FROM tag where tag = ?" + 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 - "DELETE FROM job_tag where tag = ?" + Builder_db.Rep.untyped_id ->. Caqti_type.unit @@ + "DELETE FROM job_tag where tag = ?" let remove_tag = - Caqti_request.exec - Builder_db.Rep.untyped_id - "DELETE FROM tag where id = ?" - -open Grej.Infix + Builder_db.Rep.untyped_id ->. Caqti_type.unit @@ + "DELETE FROM tag where id = ?" let migrate datadir (module Db : Caqti_blocking.CONNECTION) = Grej.check_version ~user_version:old_version (module Db) >>= fun () -> diff --git a/bin/migrations/m20210701.ml b/bin/migrations/m20210701.ml index 25a30c5..c500482 100644 --- a/bin/migrations/m20210701.ml +++ b/bin/migrations/m20210701.ml @@ -3,76 +3,71 @@ 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 - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)" + 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 - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_kind TINYINT NOT NULL, - result_code INTEGER, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_kind TINYINT NOT NULL, + result_code INTEGER, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, - FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let old_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_kind TINYINT NOT NULL, - result_code INTEGER, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_kind TINYINT NOT NULL, + result_code INTEGER, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, - FOREIGN KEY(main_binary) REFERENCES build_artifact(id), - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id), + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let copy_build = - Caqti_request.exec - Caqti_type.unit - "INSERT INTO new_build SELECT * from build" + Caqti_type.unit ->. Caqti_type.unit @@ + "INSERT INTO new_build SELECT * from build" let drop_build = - Caqti_request.exec - Caqti_type.unit - "DROP TABLE build" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE build" let rename_build = - Caqti_request.exec - Caqti_type.unit - "ALTER TABLE new_build RENAME TO build" - -open Grej.Infix + Caqti_type.unit ->. Caqti_type.unit @@ + "ALTER TABLE new_build RENAME TO build" let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = Grej.check_version ~user_version:old_version (module Db) >>= fun () -> diff --git a/bin/migrations/m20210706.ml b/bin/migrations/m20210706.ml index 7248ee9..2ee9c7b 100644 --- a/bin/migrations/m20210706.ml +++ b/bin/migrations/m20210706.ml @@ -3,81 +3,73 @@ 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 - {| ALTER TABLE build ADD COLUMN input_id BLOB |} + Caqti_type.unit ->. Caqti_type.unit @@ + "ALTER TABLE build ADD COLUMN input_id BLOB" let idx_build_job_start = - Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)" + 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 - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_kind TINYINT NOT NULL, - result_code INTEGER, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_kind TINYINT NOT NULL, + result_code INTEGER, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, - FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let copy_build = - Caqti_request.exec - Caqti_type.unit - "INSERT INTO new_build SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg, console, script, main_binary, user, job FROM build" + 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 - "DROP TABLE build" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE build" let rename_build = - Caqti_request.exec - Caqti_type.unit - "ALTER TABLE new_build RENAME TO build" + 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 - {| ALTER TABLE build DROP COLUMN input_id |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| ALTER TABLE build DROP COLUMN input_id |} let builds = - Caqti_request.collect - Caqti_type.unit - (Caqti_type.tup4 - Builder_db.Rep.untyped_id - Builder_db.Rep.cstruct - Builder_db.Rep.cstruct - Builder_db.Rep.cstruct) - {| SELECT b.id, opam.sha256, env.sha256, system.sha256 - FROM build b, build_artifact opam, build_artifact env, build_artifact system - WHERE opam.filepath = 'opam-switch' AND env.filepath = 'build-environment' - AND system.filepath = 'system-packages' - AND opam.build = b.id AND env.build = b.id AND system.build = b.id - |} + Caqti_type.unit ->* + Caqti_type.tup4 + Builder_db.Rep.untyped_id + Builder_db.Rep.cstruct + Builder_db.Rep.cstruct + Builder_db.Rep.cstruct @@ + {| SELECT b.id, opam.sha256, env.sha256, system.sha256 + FROM build b, build_artifact opam, build_artifact env, build_artifact system + WHERE opam.filepath = 'opam-switch' AND env.filepath = 'build-environment' + AND system.filepath = 'system-packages' + AND opam.build = b.id AND env.build = b.id AND system.build = b.id + |} let set_input_id = - Caqti_request.exec - (Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.cstruct) - "UPDATE build SET input_id = $2 WHERE id = $1" - -open Grej.Infix + Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.cstruct ->. Caqti_type.unit @@ + "UPDATE build SET input_id = $2 WHERE id = $1" let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = Grej.check_version ~user_version:old_version (module Db) >>= fun () -> diff --git a/bin/migrations/m20210707a.ml b/bin/migrations/m20210707a.ml index ba098ba..d80cfbd 100644 --- a/bin/migrations/m20210707a.ml +++ b/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.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' - |} + Caqti_type.unit ->* + Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@ + {| SELECT id, localpath FROM build_artifact + WHERE filepath = 'orb.deb' OR filepath = 'orb.txz' + |} let fixup datadir (module Db : Caqti_blocking.CONNECTION) = - let open Grej.Infix in Grej.check_version ~user_version:12L (module Db) >>= fun () -> Db.rev_collect_list orb_left_in_builds () >>= fun leftover_orb -> Grej.list_iter_result diff --git a/bin/migrations/m20210707b.ml b/bin/migrations/m20210707b.ml index cfde55d..48447d7 100644 --- a/bin/migrations/m20210707b.ml +++ b/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.tup4 (Builder_db.Rep.id `build_artifact) (Builder_db.Rep.id `build) Builder_db.Rep.fpath Builder_db.Rep.fpath) - {| SELECT id, build, localpath, filepath FROM build_artifact - WHERE filepath LIKE '%.deb.debug' - |} + Caqti_type.unit ->* + Caqti_type.tup4 (Builder_db.Rep.id `build_artifact) (Builder_db.Rep.id `build) + Builder_db.Rep.fpath Builder_db.Rep.fpath @@ + {| SELECT id, build, localpath, filepath FROM build_artifact + WHERE filepath LIKE '%.deb.debug' + |} let get_main_binary = - Caqti_request.find_opt - (Builder_db.Rep.id `build) - (Builder_db.Rep.id `build_artifact) - "SELECT main_binary FROM build WHERE id = ?" + 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 - "SELECT localpath FROM build_artifact WHERE id = ?" + 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) Builder_db.Rep.fpath Builder_db.Rep.fpath) - "UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1" + Caqti_type.tup3 (Builder_db.Rep.id `build_artifact) + Builder_db.Rep.fpath Builder_db.Rep.fpath ->. + Caqti_type.unit @@ + "UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1" let 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 diff --git a/bin/migrations/m20210707c.ml b/bin/migrations/m20210707c.ml index 8e4956e..12bc7d3 100644 --- a/bin/migrations/m20210707c.ml +++ b/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.tup4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath) - "SELECT b.id, b.main_binary, a.filepath, a.localpath FROM build b, build_artifact a WHERE b.main_binary = a.id AND b.main_binary IS NOT NULL" + Caqti_type.unit ->* + Caqti_type.tup4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact) + Builder_db.Rep.fpath Builder_db.Rep.fpath @@ + "SELECT b.id, b.main_binary, a.filepath, a.localpath FROM build b, build_artifact a WHERE b.main_binary = a.id AND b.main_binary IS NOT NULL" -let build_not_stripped : ([`build] Builder_db.Rep.id, [`build_artifact] Builder_db.Rep.id, [< `Zero | `One | `Many > `Zero `One ]) Caqti_request.t = - Caqti_request.find_opt - (Builder_db.Rep.id `build) - (Builder_db.Rep.id `build_artifact) - {| SELECT id FROM build_artifact WHERE build = ? AND filepath LIKE '%.debug' |} +let build_not_stripped : ([`build] Builder_db.Rep.id, [`build_artifact] Builder_db.Rep.id, [ `Zero | `One ]) Caqti_request.t = + Builder_db.Rep.id `build ->? Builder_db.Rep.id `build_artifact @@ + "SELECT id FROM build_artifact WHERE build = ? AND filepath LIKE '%.debug'" -let update_paths : ([`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, unit, [< `Zero | `One | `Many > `Zero ]) Caqti_request.t = - Caqti_request.exec - (Caqti_type.tup3 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath) - "UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1" +let update_paths : ([`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, unit, [ `Zero ]) Caqti_request.t = + Caqti_type.tup3 (Builder_db.Rep.id `build_artifact) + Builder_db.Rep.fpath Builder_db.Rep.fpath ->. + Caqti_type.unit @@ + "UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1" -let add_artifact : ((Fpath.t * Fpath.t * Cstruct.t) * (int64 * [`build] Builder_db.Rep.id), unit, [< `Zero | `One | `Many > `Zero]) Caqti_request.t = - Caqti_request.exec - Caqti_type.(tup2 (tup3 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct) (tup2 Caqti_type.int64 (Builder_db.Rep.id `build))) - {| INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?) |} +let add_artifact : ((Fpath.t * Fpath.t * Cstruct.t) * (int64 * [`build] Builder_db.Rep.id), unit, [ `Zero]) Caqti_request.t = + 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))) ->. + 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 diff --git a/bin/migrations/m20210707d.ml b/bin/migrations/m20210707d.ml index 14b31bd..c1cd938 100644 --- a/bin/migrations/m20210707d.ml +++ b/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.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath) - "SELECT id, filepath FROM build_artifact WHERE filepath LIKE './%'" + Caqti_type.unit ->* + Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@ + "SELECT id, filepath FROM build_artifact WHERE filepath LIKE './%'" let update_path : ([`build_artifact] Builder_db.Rep.id * Fpath.t, unit, [< `Zero | `One | `Many > `Zero ]) Caqti_request.t = - Caqti_request.exec - (Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath) - "UPDATE build_artifact SET filepath = $2 WHERE id = $1" + 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 diff --git a/bin/migrations/m20210712a.ml b/bin/migrations/m20210712a.ml index 7a50ed9..8409242 100644 --- a/bin/migrations/m20210712a.ml +++ b/bin/migrations/m20210712a.ml @@ -3,108 +3,101 @@ 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" -let new_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_code INTEGER NOT NULL, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, - input_id BLOB, -- sha256 (sha256 || sha256 || sha256) +open Grej.Infix - FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} +let new_build = + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_code INTEGER NOT NULL, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, + input_id BLOB, -- sha256 (sha256 || sha256 || sha256) + + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let copy_old_build = - Caqti_request.exec - Caqti_type.unit - {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, - result_code, result_msg, console, script, main_binary, user, job, input_id) - SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg, - console, script, main_binary, user, job, input_id - FROM build - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, + result_code, result_msg, console, script, main_binary, user, job, input_id) + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg, + console, script, main_binary, user, job, input_id + FROM build + |} let old_build_execution_result = - Caqti_request.collect - Caqti_type.unit - Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) - "SELECT id, result_kind, result_code FROM build" + Caqti_type.unit ->* + Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) @@ + "SELECT id, result_kind, result_code FROM build" let update_new_build_execution_result = - Caqti_request.exec - Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int) - "UPDATE new_build SET result_code = $2 WHERE id = $1" + Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int) ->. Caqti_type.unit @@ + "UPDATE new_build SET result_code = $2 WHERE id = $1" let old_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_kind INTEGER NOT NULL, - result_code INTEGER, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, - input_id BLOB, -- sha256 (sha256 || sha256 || sha256) + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_kind INTEGER NOT NULL, + result_code INTEGER, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, + input_id BLOB, -- sha256 (sha256 || sha256 || sha256) - FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let copy_new_build = - Caqti_request.exec - Caqti_type.unit - {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, - result_kind, result_msg, console, script, main_binary, user, job, input_id) - SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg, - console, script, main_binary, user, job, input_id - FROM build - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, + result_kind, result_msg, console, script, main_binary, user, job, input_id) + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg, + console, script, main_binary, user, job, input_id + FROM build + |} let new_build_execution_result = - Caqti_request.collect - Caqti_type.unit - Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int) - "SELECT id, result_code FROM build" + Caqti_type.unit ->* + Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int) @@ + "SELECT id, result_code FROM build" let update_old_build_execution_result = - Caqti_request.exec - Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) - "UPDATE new_build SET result_kind = $2, result_code = $3 WHERE id = $1" + 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 - "DROP TABLE build" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE build" let rename_build = - Caqti_request.exec - Caqti_type.unit - "ALTER TABLE new_build RENAME TO build" + Caqti_type.unit ->. Caqti_type.unit @@ + "ALTER TABLE new_build RENAME TO build" let execution_new_of_old kind code = match kind, code with @@ -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 - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)") + 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 - "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0") + 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") () >>= fun () -> - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_input_id ON build(input_id)") + 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 - "CREATE INDEX idx_build_main_binary ON build(main_binary)") + 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 - "CREATE INDEX idx_build_artifact_sha256 ON build_artifact(sha256)") + 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_request.exec Caqti_type.unit - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)") + Db.exec (Caqti_type.unit ->. Caqti_type.unit @@ + "DROP INDEX idx_build_artifact_sha256") () >>= fun () -> + Db.exec (Caqti_type.unit ->. Caqti_type.unit @@ + "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)") () >>= fun () -> Db.exec (Grej.set_version old_version) () diff --git a/bin/migrations/m20210712b.ml b/bin/migrations/m20210712b.ml index 4927d52..91a4c22 100644 --- a/bin/migrations/m20210712b.ml +++ b/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.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath) - "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%.build-hashes'" + Caqti_type.unit ->* + Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@ + "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%.build-hashes'" let all_build_artifacts_like_readme : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t = - Caqti_request.collect ~oneshot:true - Caqti_type.unit - (Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath) - "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%README.md'" + Caqti_type.unit ->* + Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@ + "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%README.md'" let fixup datadir (module Db : Caqti_blocking.CONNECTION) = - let open Grej.Infix in Grej.check_version ~user_version:13L (module Db) >>= fun () -> Db.rev_collect_list all_build_artifacts_like_hashes () >>= fun build_artifacts_build_hashes -> Db.rev_collect_list all_build_artifacts_like_readme () >>= fun build_artifacts_readme -> diff --git a/bin/migrations/m20210712c.ml b/bin/migrations/m20210712c.ml index 7e36cee..6c36035 100644 --- a/bin/migrations/m20210712c.ml +++ b/bin/migrations/m20210712c.ml @@ -28,107 +28,101 @@ module Asn = struct end let new_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_code INTEGER NOT NULL, - result_msg TEXT, - console TEXT NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, - input_id BLOB, -- sha256 (sha256 || sha256 || sha256) + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_code INTEGER NOT NULL, + result_msg TEXT, + console TEXT NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, + input_id BLOB, -- sha256 (sha256 || sha256 || sha256) - FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let old_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_code INTEGER NOT NULL, - result_msg TEXT, - console BLOB NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, - input_id BLOB, -- sha256 (sha256 || sha256 || sha256) + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_code INTEGER NOT NULL, + result_msg TEXT, + console BLOB NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, + input_id BLOB, -- sha256 (sha256 || sha256 || sha256) - FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let copy_from_old_build = - Caqti_request.exec - Caqti_type.unit - {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, - result_code, result_msg, console, script, main_binary, user, job, input_id) - SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, - '', '', main_binary, user, job, input_id - FROM build - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, + result_code, result_msg, console, script, main_binary, user, job, input_id) + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, + '', '', main_binary, user, job, input_id + FROM build + |} let copy_from_new_build = - Caqti_request.exec - Caqti_type.unit - {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, - result_code, result_msg, console, script, main_binary, user, job, input_id) - SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, - x'', '', main_binary, user, job, input_id - FROM build - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, + result_code, result_msg, console, script, main_binary, user, job, input_id) + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, + x'', '', main_binary, user, job, input_id + FROM build + |} let old_build_console_script = - Caqti_request.collect - Caqti_type.unit - Caqti_type.(tup4 (Builder_db.Rep.id (`build : [ `build ])) - (tup2 string Builder_db.Rep.uuid) Builder_db.Rep.cstruct string) - "SELECT b.id, job.name, b.uuid, b.console, b.script FROM build b, job WHERE b.job = job.id" + Caqti_type.unit ->* + Caqti_type.(tup4 (Builder_db.Rep.id (`build : [ `build ])) + (tup2 string Builder_db.Rep.uuid) Builder_db.Rep.cstruct string) @@ + "SELECT b.id, job.name, b.uuid, b.console, b.script FROM build b, job WHERE b.job = job.id" let update_new_build_console_script = - Caqti_request.exec - Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath) - "UPDATE new_build SET console = $2, script = $3 WHERE id = $1" + Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) + Builder_db.Rep.fpath Builder_db.Rep.fpath) ->. + Caqti_type.unit @@ + "UPDATE new_build SET console = $2, script = $3 WHERE id = $1" let new_build_console_script = - Caqti_request.collect - Caqti_type.unit - Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath) - "SELECT id, console, script FROM build" + Caqti_type.unit ->* + Caqti_type.tup3 (Builder_db.Rep.id (`build : [ `build ])) + Builder_db.Rep.fpath Builder_db.Rep.fpath @@ + "SELECT id, console, script FROM build" let update_old_build_console_script = - Caqti_request.exec - Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.cstruct string) - "UPDATE new_build SET console = $2, script = $3 WHERE id = $1" + 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 - "DROP TABLE build" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE build" let rename_build = - Caqti_request.exec - Caqti_type.unit - "ALTER TABLE new_build RENAME TO build" + Caqti_type.unit ->. Caqti_type.unit @@ + "ALTER TABLE new_build RENAME TO build" let console_to_string console = Asn.console_of_cs console @@ -187,17 +181,18 @@ 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 - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)") + 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 - "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0") + 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") () >>= fun () -> - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_input_id ON build(input_id)") + 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 - "CREATE INDEX idx_build_main_binary ON build(main_binary)") + 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 - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)") + 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 - "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0") + 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") () >>= fun () -> - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_input_id ON build(input_id)") + 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 - "CREATE INDEX idx_build_main_binary ON build(main_binary)") + 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) () diff --git a/bin/migrations/m20210910.ml b/bin/migrations/m20210910.ml index f21478c..9a0b564 100644 --- a/bin/migrations/m20210910.ml +++ b/bin/migrations/m20210910.ml @@ -1,16 +1,19 @@ +open Grej.Infix + let mixups = - Caqti_request.collect ~oneshot:true - Caqti_type.unit - (Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) Builder_db.Rep.fpath Builder_db.Rep.fpath) -"SELECT id, console, script FROM build WHERE console LIKE '%/script.txt' AND script LIKE '%/console.txt'" + Caqti_type.unit ->* + Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) + Builder_db.Rep.fpath Builder_db.Rep.fpath @@ + "SELECT id, console, script FROM build \ + WHERE console LIKE '%/script.txt' AND script LIKE '%/console.txt'" let fixup = - Caqti_request.exec ~oneshot:true - (Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) Builder_db.Rep.fpath Builder_db.Rep.fpath) - "UPDATE build SET console = $2, script = $3 WHERE id = $1" + Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) + Builder_db.Rep.fpath Builder_db.Rep.fpath ->. + Caqti_type.unit @@ + "UPDATE build SET console = $2, script = $3 WHERE id = $1" 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) -> diff --git a/bin/migrations/m20211105.ml b/bin/migrations/m20211105.ml index a270526..600bc67 100644 --- a/bin/migrations/m20211105.ml +++ b/bin/migrations/m20211105.ml @@ -6,96 +6,87 @@ and rollback_doc = "remove platform from build" open Grej.Syntax let new_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_code INTEGER NOT NULL, - result_msg TEXT, - console TEXT NOT NULL, - script TEXT NOT NULL, - platform TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, - input_id BLOB, -- sha256 (sha256 || sha256 || sha256) + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_code INTEGER NOT NULL, + result_msg TEXT, + console TEXT NOT NULL, + script TEXT NOT NULL, + platform TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, + input_id BLOB, -- sha256 (sha256 || sha256 || sha256) - FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let old_build = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE new_build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_code INTEGER NOT NULL, - result_msg TEXT, - console TEXT NOT NULL, - script TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, - input_id BLOB, -- sha256 (sha256 || sha256 || sha256) + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE new_build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_code INTEGER NOT NULL, + result_msg TEXT, + console TEXT NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, + input_id BLOB, -- sha256 (sha256 || sha256 || sha256) - FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let copy_from_old_build = - Caqti_request.exec - Caqti_type.unit - {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, - result_code, result_msg, console, script, platform, main_binary, user, job, input_id) - SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, - console, script, 'PLACEHOLDER-PLATFORM', main_binary, user, job, input_id - FROM build - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, + result_code, result_msg, console, script, platform, main_binary, user, job, input_id) + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, + console, script, 'PLACEHOLDER-PLATFORM', main_binary, user, job, input_id + FROM build + |} let copy_from_new_build = - Caqti_request.exec - Caqti_type.unit - {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, - result_code, result_msg, console, script, main_binary, user, job, input_id) - SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, - console, script, main_binary, user, job, input_id - FROM build - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps, + result_code, result_msg, console, script, main_binary, user, job, input_id) + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, + console, script, main_binary, user, job, input_id + FROM build + |} let build_id_and_user = - Caqti_request.collect - Caqti_type.unit - Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int64) - "SELECT id, user FROM build" + 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) - "UPDATE new_build SET platform = $2 WHERE id = $1" + Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) string) ->. Caqti_type.unit @@ + "UPDATE new_build SET platform = $2 WHERE id = $1" let drop_build = - Caqti_request.exec - Caqti_type.unit - "DROP TABLE build" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE build" let rename_build = - Caqti_request.exec - Caqti_type.unit - "ALTER TABLE new_build RENAME TO build" + Caqti_type.unit ->. Caqti_type.unit @@ + "ALTER TABLE new_build RENAME TO build" (* 1|reynir @@ -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* () = - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)") - () - in - let* () = - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0") - () - in - let* () = - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_input_id ON build(input_id)") - () - in - let* () = - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_main_binary ON build(main_binary)") - () - in + let* () = Db.exec idx_build_job_start () in + let* () = Db.exec idx_build_failed () in + let* () = Db.exec idx_build_input_id () in + let* () = Db.exec idx_build_main_binary () in 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* () = - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)") - () - in - let* () = - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0") - () - in - let* () = - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_input_id ON build(input_id)") - () - in - let* () = - Db.exec (Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_main_binary ON build(main_binary)") - () - in + let* () = Db.exec idx_build_job_start () in + let* () = Db.exec idx_build_failed () in + let* () = Db.exec idx_build_input_id () in + let* () = Db.exec idx_build_main_binary () in Db.exec (Grej.set_version old_version) () diff --git a/builder-web.opam b/builder-web.opam index e2cf4bf..a16a480 100644 --- a/builder-web.opam +++ b/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" diff --git a/db/builder_db.ml b/db/builder_db.ml index 1f15a7b..1c44c41 100644 --- a/db/builder_db.ml +++ b/db/builder_db.ml @@ -1,5 +1,6 @@ module Rep = Representation open Rep +open Caqti_request.Infix let application_id = 1234839235l @@ -18,211 +19,171 @@ 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 - "PRAGMA application_id" + Caqti_type.unit ->! Caqti_type.int32 @@ + "PRAGMA application_id" let get_version = - Caqti_request.find - Caqti_type.unit - Caqti_type.int64 - "PRAGMA user_version" + Caqti_type.unit ->! Caqti_type.int64 @@ + "PRAGMA user_version" let set_application_id = - Caqti_request.exec - Caqti_type.unit - (Printf.sprintf "PRAGMA application_id = %ld" application_id) + Caqti_type.unit ->. Caqti_type.unit @@ + Printf.sprintf "PRAGMA application_id = %ld" application_id let set_current_version = - Caqti_request.exec - Caqti_type.unit - (Printf.sprintf "PRAGMA user_version = %Ld" current_version) + Caqti_type.unit ->. Caqti_type.unit @@ + Printf.sprintf "PRAGMA user_version = %Ld" current_version module Job = struct let migrate = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE job ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - name VARCHAR(255) NOT NULL UNIQUE - ) - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE job ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + name VARCHAR(255) NOT NULL UNIQUE + ) + |} let rollback = - Caqti_request.exec - Caqti_type.unit - {| DROP TABLE IF EXISTS job |} + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE IF EXISTS job" let get = - Caqti_request.find - (id `job) - Caqti_type.string - "SELECT name FROM job WHERE id = ?" + 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) - "SELECT id FROM job WHERE name = ?" + 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.(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 - LEFT JOIN job_tag synopsis ON synopsis.job = j.id AND synopsis.tag = synopsis_tag.id - WHERE section_tag.tag = 'section' AND synopsis_tag.tag = 'synopsis' - ORDER BY section.value, j.name ASC - |} + Caqti_type.unit ->* + 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 + LEFT JOIN job_tag synopsis ON synopsis.job = j.id AND synopsis.tag = synopsis_tag.id + WHERE section_tag.tag = 'section' AND synopsis_tag.tag = 'synopsis' + ORDER BY section.value, j.name ASC + |} let try_add = - Caqti_request.exec - Caqti_type.string - "INSERT OR IGNORE INTO job (name) VALUES (?)" + Caqti_type.string ->. Caqti_type.unit @@ + "INSERT OR IGNORE INTO job (name) VALUES (?)" let remove = - Caqti_request.exec - (id `job) - "DELETE FROM job WHERE id = ?" + id `job ->. Caqti_type.unit @@ + "DELETE FROM job WHERE id = ?" end module Tag = struct let migrate = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE tag ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - tag VARCHAR(255) NOT NULL UNIQUE - ) - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE tag ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + tag VARCHAR(255) NOT NULL UNIQUE + ) + |} 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 - "INSERT OR IGNORE INTO tag (tag) VALUES (?)" + Caqti_type.string ->. Caqti_type.unit @@ + "INSERT OR IGNORE INTO tag (tag) VALUES (?)" end module Job_tag = struct let migrate = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE job_tag ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - tag INTEGER NOT NULL, - value TEXT NOT NULL, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE job_tag ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + tag INTEGER NOT NULL, + value TEXT NOT NULL, + job INTEGER NOT NULL, - FOREIGN KEY(job) REFERENCES job(id), - FOREIGN KEY(tag) REFERENCES tag(id), - UNIQUE(tag, job) - ) - |} + FOREIGN KEY(job) REFERENCES job(id), + FOREIGN KEY(tag) REFERENCES tag(id), + UNIQUE(tag, job) + ) + |} let 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)) - "INSERT INTO job_tag (tag, value, job) VALUES ($1, $2, $3)" + Caqti_type.(tup3 (id `tag) string (id `job)) ->. Caqti_type.unit @@ + "INSERT INTO job_tag (tag, value, job) VALUES ($1, $2, $3)" let update = - Caqti_request.exec - Caqti_type.(tup3 (id `tag) string (id `job)) - "UPDATE job_tag SET value = $2 WHERE tag = $1 AND job = $3" + Caqti_type.(tup3 (id `tag) string (id `job)) ->. Caqti_type.unit @@ + "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 - "SELECT value FROM job_tag WHERE tag = ? AND job = ?" + 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) - "DELETE FROM job_tag WHERE job = ?" + id `job ->. Caqti_type.unit @@ + "DELETE FROM job_tag WHERE job = ?" end module Build_artifact = struct let migrate = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE build_artifact ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - filepath TEXT NOT NULL, -- the path as in the build - localpath TEXT NOT NULL, -- local path to the file on disk - sha256 BLOB NOT NULL, - size INTEGER NOT NULL, - build INTEGER NOT NULL, + Caqti_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 + localpath TEXT NOT NULL, -- local path to the file on disk + sha256 BLOB NOT NULL, + size INTEGER NOT NULL, + build INTEGER NOT NULL, - FOREIGN KEY(build) REFERENCES build(id), - UNIQUE(build, filepath) - ) - |} + FOREIGN KEY(build) REFERENCES build(id), + UNIQUE(build, filepath) + ) + |} let rollback = - Caqti_request.exec - Caqti_type.unit - "DROP TABLE IF EXISTS build_artifact" + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE IF EXISTS build_artifact" let get = - Caqti_request.find - (id `build_artifact) - file - {| SELECT filepath, localpath, sha256, size - FROM build_artifact WHERE id = ? |} + 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) - {| SELECT build_artifact.id, build_artifact.filepath, - build_artifact.localpath, build_artifact.sha256, build_artifact.size - FROM build_artifact - INNER JOIN build ON build.id = build_artifact.build - WHERE build.uuid = ? AND build_artifact.filepath = ? - |} + 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 + INNER JOIN build ON build.id = build_artifact.build + WHERE build.uuid = ? AND build_artifact.filepath = ? + |} let get_all_by_build = - Caqti_request.collect - (id `build) - Caqti_type.(tup2 - (id `build_artifact) - file) - "SELECT id, filepath, localpath, sha256, size FROM build_artifact WHERE build = ?" + 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)) - "INSERT INTO build_artifact (filepath, localpath, sha256, size, build) - VALUES (?, ?, ?, ?, ?)" + Caqti_type.(tup2 file (id `build)) ->. Caqti_type.unit @@ + "INSERT INTO build_artifact (filepath, localpath, sha256, size, build) \ + VALUES (?, ?, ?, ?, ?)" let remove_by_build = - Caqti_request.exec - (id `build) - "DELETE FROM build_artifact WHERE build = ?" + id `build ->. Caqti_type.unit @@ + "DELETE FROM build_artifact WHERE build = ?" let remove = - Caqti_request.exec - (id `build_artifact) - "DELETE FROM build_artifact WHERE id = ?" + id `build_artifact ->. Caqti_type.unit @@ + "DELETE FROM build_artifact WHERE id = ?" end module Build = struct @@ -268,409 +229,348 @@ module Build = struct Caqti_type.custom ~encode ~decode rep let migrate = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE build ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - uuid VARCHAR(36) NOT NULL UNIQUE, - start_d INTEGER NOT NULL, - start_ps INTEGER NOT NULL, - finish_d INTEGER NOT NULL, - finish_ps INTEGER NOT NULL, - result_code INTEGER NOT NULL, - result_msg TEXT, - console TEXT NOT NULL, - script TEXT NOT NULL, - platform TEXT NOT NULL, - main_binary INTEGER, - user INTEGER NOT NULL, - job INTEGER NOT NULL, - input_id BLOB, -- sha256 (sha256 || sha256 || sha256) + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE build ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + uuid VARCHAR(36) NOT NULL UNIQUE, + start_d INTEGER NOT NULL, + start_ps INTEGER NOT NULL, + finish_d INTEGER NOT NULL, + finish_ps INTEGER NOT NULL, + result_code INTEGER NOT NULL, + result_msg TEXT, + console TEXT NOT NULL, + script TEXT NOT NULL, + platform TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, + input_id BLOB, -- sha256 (sha256 || sha256 || sha256) - FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id) - ) - |} + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id) + ) + |} let rollback = - Caqti_request.exec - Caqti_type.unit - {| DROP TABLE IF EXISTS build |} + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP TABLE IF EXISTS build" let get_by_uuid = - Caqti_request.find_opt - 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 - FROM build - WHERE uuid = ? - |} + 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 + FROM build + WHERE uuid = ? + |} let get_all = - Caqti_request.collect - (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 - FROM build - WHERE job = ? - ORDER BY start_d DESC, start_ps DESC - |} + 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 + FROM build + WHERE job = ? + ORDER BY start_d DESC, start_ps DESC + |} let get_all_failed = - Caqti_request.collect - 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 - FROM build b - INNER JOIN job ON job.id = b.job - WHERE b.result_code <> 0 AND ($3 IS NULL OR b.platform = $3) - ORDER BY start_d DESC, start_ps DESC - LIMIT $2 - OFFSET $1 - |} + 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 + FROM build b + INNER JOIN job ON job.id = b.job + WHERE b.result_code <> 0 AND ($3 IS NULL OR b.platform = $3) + ORDER BY start_d DESC, start_ps DESC + LIMIT $2 + OFFSET $1 + |} let get_all_artifact_sha = - Caqti_request.collect - 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 - AND ($2 IS NULL OR b.platform = $2) - ORDER BY b.start_d DESC, b.start_ps DESC - |} + 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 + AND ($2 IS NULL OR b.platform = $2) + ORDER BY b.start_d DESC, b.start_ps DESC + |} let get_failed_builds = - Caqti_request.collect - 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 - FROM build - WHERE job = $1 AND result_code <> 0 - AND ($2 IS NULL OR platform = $2) - ORDER BY start_d DESC, start_ps DESC - |} + 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 + FROM build + WHERE job = $1 AND result_code <> 0 + AND ($2 IS NULL OR platform = $2) + ORDER BY start_d DESC, start_ps DESC + |} let get_latest_successful_with_binary = - Caqti_request.find_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, - b.platform, b.main_binary, b.input_id, b.user, b.job, - a.filepath, a.localpath, a.sha256, a.size - FROM build b - LEFT JOIN build_artifact a ON - b.main_binary = a.id - WHERE b.job = $1 AND b.platform = $2 AND b.result_code = 0 - ORDER BY b.start_d DESC, b.start_ps DESC - LIMIT 1 - |} + 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, + b.platform, b.main_binary, b.input_id, b.user, b.job, + a.filepath, a.localpath, a.sha256, a.size + FROM build b + LEFT JOIN build_artifact a ON + b.main_binary = a.id + WHERE b.job = $1 AND b.platform = $2 AND b.result_code = 0 + ORDER BY b.start_d DESC, b.start_ps DESC + LIMIT 1 + |} let get_latest_successful = - Caqti_request.find_opt - 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, - b.platform, b.main_binary, b.input_id, b.user, b.job - FROM build b - WHERE b.job = $1 AND b.result_code = 0 - AND ($2 IS NULL OR b.platform = $2) - ORDER BY b.start_d DESC, b.start_ps DESC - LIMIT 1 - |} + 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, + b.platform, b.main_binary, b.input_id, b.user, b.job + FROM build b + WHERE b.job = $1 AND b.result_code = 0 + AND ($2 IS NULL OR b.platform = $2) + ORDER BY b.start_d DESC, b.start_ps DESC + LIMIT 1 + |} let get_previous_successful_different_output = - Caqti_request.find_opt - (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 - FROM build b, build b0, build_artifact a, build_artifact a0 - WHERE b0.id = ? AND b0.job = b.job AND - b.platform = b0.platform AND - b.result_code = 0 AND - a.id = b.main_binary AND a0.id = b0.main_binary AND - a.sha256 <> a0.sha256 AND - (b0.start_d > b.start_d OR b0.start_d = b.start_d AND b0.start_ps > b.start_ps) - ORDER BY b.start_d DESC, b.start_ps DESC - LIMIT 1 - |} + 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 + FROM build b, build b0, build_artifact a, build_artifact a0 + WHERE b0.id = ? AND b0.job = b.job AND + b.platform = b0.platform AND + b.result_code = 0 AND + a.id = b.main_binary AND a0.id = b0.main_binary AND + a.sha256 <> a0.sha256 AND + (b0.start_d > b.start_d OR b0.start_d = b.start_d AND b0.start_ps > b.start_ps) + ORDER BY b.start_d DESC, b.start_ps DESC + LIMIT 1 + |} let get_next_successful_different_output = - Caqti_request.find_opt - (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 - FROM build b, build b0, build_artifact a, build_artifact a0 - WHERE b0.id = ? AND b0.job = b.job AND - b.platform = b0.platform AND - b.result_code = 0 AND - a.id = b.main_binary AND a0.id = b0.main_binary AND - a.sha256 <> a0.sha256 AND - (b0.start_d < b.start_d OR b0.start_d = b.start_d AND b0.start_ps < b.start_ps) - ORDER BY b.start_d ASC, b.start_ps ASC - LIMIT 1 - |} + 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 + FROM build b, build b0, build_artifact a, build_artifact a0 + WHERE b0.id = ? AND b0.job = b.job AND + b.platform = b0.platform AND + b.result_code = 0 AND + a.id = b.main_binary AND a0.id = b0.main_binary AND + a.sha256 <> a0.sha256 AND + (b0.start_d < b.start_d OR b0.start_d = b.start_d AND b0.start_ps < b.start_ps) + ORDER BY b.start_d ASC, b.start_ps ASC + LIMIT 1 + |} let get_same_input_same_output_builds = - Caqti_request.collect - (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 - 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 - AND b.main_binary = a.id AND b.id <> b0.id AND b0.input_id = b.input_id - ORDER BY b.start_d DESC, b.start_ps DESC - |} + 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 + 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 + AND b.main_binary = a.id AND b.id <> b0.id AND b0.input_id = b.input_id + ORDER BY b.start_d DESC, b.start_ps DESC + |} let get_same_input_different_output_hashes = - Caqti_request.collect - (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 - AND b.main_binary = a.id AND b.id <> b0.id AND b0.input_id = b.input_id - ORDER BY b.start_d DESC, b.start_ps DESC - |} + 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 + AND b.main_binary = a.id AND b.id <> b0.id AND b0.input_id = b.input_id + ORDER BY b.start_d DESC, b.start_ps DESC + |} let get_different_input_same_output_input_ids = - Caqti_request.collect - (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 - AND b.main_binary = a.id AND b0.input_id <> b.input_id - |} + 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 + AND b.main_binary = a.id AND b0.input_id <> b.input_id + |} let get_one_by_input_id = - Caqti_request.find - 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 - FROM build - WHERE input_id = ? - ORDER BY start_d DESC, start_ps DESC - LIMIT 1 - |} + 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 + FROM build + WHERE input_id = ? + ORDER BY start_d DESC, start_ps DESC + LIMIT 1 + |} let get_platforms_for_job = - Caqti_request.collect - (id `job) - Caqti_type.string - "SELECT DISTINCT platform FROM build WHERE job = ?" + id `job ->* Caqti_type.string @@ + "SELECT DISTINCT platform FROM build WHERE job = ?" let add = - Caqti_request.exec - 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) - VALUES - (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) - |} + t ->. Caqti_type.unit @@ + {| 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) + VALUES + (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) + |} let get_by_hash = - Caqti_request.find - 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, - b.platform, b.main_binary, b.input_id, b.user, b.job - FROM build_artifact a - INNER JOIN build b ON b.id = a.build - WHERE a.sha256 = ? - ORDER BY b.start_d DESC, b.start_ps DESC - LIMIT 1 - |} + 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, + b.platform, b.main_binary, b.input_id, b.user, b.job + FROM build_artifact a + INNER JOIN build b ON b.id = a.build + WHERE a.sha256 = ? + ORDER BY b.start_d DESC, b.start_ps DESC + LIMIT 1 + |} let get_with_main_binary_by_hash = - Caqti_request.find - 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, - a.filepath, a.localpath, a.sha256, a.size - FROM build_artifact a - INNER JOIN build b ON b.id = a.build - WHERE a.sha256 = ? - ORDER BY b.start_d DESC, b.start_ps DESC - LIMIT 1 - |} + 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, + a.filepath, a.localpath, a.sha256, a.size + FROM build_artifact a + INNER JOIN build b ON b.id = a.build + WHERE a.sha256 = ? + ORDER BY b.start_d DESC, b.start_ps DESC + LIMIT 1 + |} let get_with_jobname_by_hash = - Caqti_request.find_opt - 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, - b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job - FROM build_artifact a - INNER JOIN build b ON b.id = a.build - INNER JOIN job ON job.id = b.job - WHERE a.sha256 = ? - ORDER BY b.start_d DESC, b.start_ps DESC - LIMIT 1 - |} + 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, + b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job + FROM build_artifact a + INNER JOIN build b ON b.id = a.build + INNER JOIN job ON job.id = b.job + WHERE a.sha256 = ? + ORDER BY b.start_d DESC, b.start_ps DESC + LIMIT 1 + |} let set_main_binary = - Caqti_request.exec - (Caqti_type.tup2 (id `build) (id `build_artifact)) - "UPDATE build SET main_binary = $2 WHERE id = $1" + Caqti_type.tup2 (id `build) (id `build_artifact) ->. Caqti_type.unit @@ + "UPDATE build SET main_binary = $2 WHERE id = $1" let remove = - Caqti_request.exec - (id `build) - "DELETE FROM build WHERE id = ?" + id `build ->. Caqti_type.unit @@ + "DELETE FROM build WHERE id = ?" end module User = struct let migrate = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE user ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - username VARCHAR(255) NOT NULL UNIQUE, - password_hash BLOB NOT NULL, - password_salt BLOB NOT NULL, - scrypt_n INTEGER NOT NULL, - scrypt_r INTEGER NOT NULL, - scrypt_p INTEGER NOT NULL, - restricted BOOLEAN NOT NULL - ) - |} + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE user ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + username VARCHAR(255) NOT NULL UNIQUE, + password_hash BLOB NOT NULL, + password_salt BLOB NOT NULL, + scrypt_n INTEGER NOT NULL, + scrypt_r INTEGER NOT NULL, + scrypt_p INTEGER NOT NULL, + restricted BOOLEAN NOT NULL + ) + |} let rollback = - Caqti_request.exec - Caqti_type.unit - "DROP TABLE IF EXISTS user" + 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) - {| SELECT id, username, password_hash, password_salt, - scrypt_n, scrypt_r, scrypt_p, restricted - FROM user - WHERE username = ? - |} + 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 + WHERE username = ? + |} let get_all = - Caqti_request.collect - Caqti_type.unit - Caqti_type.string - "SELECT username FROM user" + Caqti_type.unit ->* Caqti_type.string @@ + "SELECT username FROM user" let add = - Caqti_request.exec - user_info - {| INSERT INTO user (username, password_hash, password_salt, - scrypt_n, scrypt_r, scrypt_p, restricted) - VALUES (?, ?, ?, ?, ?, ?, ?) - |} + user_info ->. Caqti_type.unit @@ + {| 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 - "DELETE FROM user WHERE username = ?" + Caqti_type.string ->. Caqti_type.unit @@ + "DELETE FROM user WHERE username = ?" let update_user = - Caqti_request.exec - user_info - {| UPDATE user - SET password_hash = $2, - password_salt = $3, - scrypt_n = $4, - scrypt_r = $5, - scrypt_p = $6, - restricted = $7 - WHERE username = $1 - |} + user_info ->. Caqti_type.unit @@ + {| UPDATE user + SET password_hash = $2, + password_salt = $3, + scrypt_n = $4, + scrypt_r = $5, + scrypt_p = $6, + restricted = $7 + WHERE username = $1 + |} end module Access_list = struct let migrate = - Caqti_request.exec - Caqti_type.unit - {| CREATE TABLE access_list ( - id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, - user INTEGER NOT NULL, - job INTEGER NOT NULL, + Caqti_type.unit ->. Caqti_type.unit @@ + {| CREATE TABLE access_list ( + id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + user INTEGER NOT NULL, + job INTEGER NOT NULL, - FOREIGN KEY(user) REFERENCES user(id), - FOREIGN KEY(job) REFERENCES job(id), - UNIQUE(user, job) - ) - |} + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(id), + UNIQUE(user, job) + ) + |} let rollback = - Caqti_request.exec - Caqti_type.unit - "DROP TABLE IF EXISTS access_list" + 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) - "SELECT id FROM access_list WHERE user = ? AND job = ?" + 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)) - "INSERT INTO access_list (user, job) VALUES (?, ?)" + Caqti_type.tup2 (id `user) (id `job) ->. Caqti_type.unit @@ + "INSERT INTO access_list (user, job) VALUES (?, ?)" let remove = - Caqti_request.exec - Caqti_type.(tup2 (id `user) (id `job)) - "DELETE FROM access_list WHERE user = ? AND job = ?" + Caqti_type.tup2 (id `user) (id `job) ->. Caqti_type.unit @@ + "DELETE FROM access_list WHERE user = ? AND job = ?" let remove_by_job = - Caqti_request.exec - (id `job) - "DELETE FROM access_list WHERE job = ?" + id `job ->. Caqti_type.unit @@ + "DELETE FROM access_list WHERE job = ?" let remove_all_by_username = - Caqti_request.exec - Caqti_type.string - {| DELETE FROM access_list - WHERE access_list.id IN ( - SELECT access_list.id - FROM access_list - INNER JOIN user ON access_list.user = user.id - WHERE user.username = ? - ) - |} + Caqti_type.string ->. Caqti_type.unit @@ + {| DELETE FROM access_list + WHERE access_list.id IN ( + SELECT access_list.id + FROM access_list + INNER JOIN user ON access_list.user = user.id + WHERE user.username = ? + ) + |} end @@ -682,16 +582,16 @@ let migrate = [ Access_list.migrate; Tag.migrate; Job_tag.migrate; - Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"; - Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0"; - Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_input_id ON build(input_id)"; - Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_main_binary ON build(main_binary)"; - Caqti_request.exec Caqti_type.unit - "CREATE INDEX idx_build_artifact_sha256 ON build_artifact(sha256)"; + Caqti_type.unit ->. Caqti_type.unit @@ + "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"; + 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_type.unit ->. Caqti_type.unit @@ + "CREATE INDEX idx_build_input_id ON build(input_id)"; + Caqti_type.unit ->. Caqti_type.unit @@ + "CREATE INDEX idx_build_main_binary ON build(main_binary)"; + 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 - "DROP INDEX IF EXISTS idx_build_artifact_sha256"; - Caqti_request.exec Caqti_type.unit - "DROP INDEX IF EXISTS idx_build_failed"; - Caqti_request.exec Caqti_type.unit - "DROP INDEX IF EXISTS idx_build_input_id"; - Caqti_request.exec Caqti_type.unit - "DROP INDEX IF EXISTS idx_build_main_binary"; - Caqti_request.exec Caqti_type.unit - "DROP INDEX IF EXISTS idx_build_job_start"; - Caqti_request.exec Caqti_type.unit - "PRAGMA user_version = 0"; - Caqti_request.exec Caqti_type.unit - "PRAGMA application_id = 0"; + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP INDEX IF EXISTS idx_build_artifact_sha256"; + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP INDEX IF EXISTS idx_build_failed"; + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP INDEX IF EXISTS idx_build_input_id"; + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP INDEX IF EXISTS idx_build_main_binary"; + Caqti_type.unit ->. Caqti_type.unit @@ + "DROP INDEX IF EXISTS idx_build_job_start"; + Caqti_type.unit ->. Caqti_type.unit @@ + "PRAGMA user_version = 0"; + Caqti_type.unit ->. Caqti_type.unit @@ + "PRAGMA application_id = 0"; ] diff --git a/db/builder_db.mli b/db/builder_db.mli index 3e16d60..008fc5a 100644 --- a/db/builder_db.mli +++ b/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 - val set_main_binary : ([`build] id * [`build_artifact] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t - val remove : ([`build] id, unit, [< `Many | `One | `Zero > `Zero]) Caqti_request.t + (Cstruct.t, string * t, [ `One | `Zero]) Caqti_request.t + val set_main_binary : ([`build] id * [`build_artifact] id, unit, [ `Zero ]) Caqti_request.t + val remove : ([`build] id, unit, [ `Zero]) Caqti_request.t 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 diff --git a/db/representation.ml b/db/representation.ml index 6379042..c95e0cb 100644 --- a/db/representation.ml +++ b/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 - Caqti_type.unit - any_id + let open Caqti_request.Infix in + Caqti_type.unit ->! any_id @@ "SELECT last_insert_rowid()" diff --git a/lib/authorization.ml b/lib/authorization.ml index 3a24ad3..47dea57 100644 --- a/lib/authorization.ml +++ b/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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 041d457..3440bbb 100644 --- a/lib/builder_web.ml +++ b/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 = - 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 routes ~datadir ~cachedir ~configdir = 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 platform = Dream.query "platform" req in + let job_name = Dream.param req "job" in + let platform = Dream.query req "platform" in (Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) -> Dream.sql req (Model.builds_grouped_by_output 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 platform = Dream.query "platform" req in + let job_name = Dream.param req "job" in + let platform = Dream.query req "platform" in (Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) -> Dream.sql req (Model.builds_grouped_by_output_with_failed job_id platform) >|= fun builds -> (readme, builds)) @@ -164,9 +150,10 @@ let add_routes ~datadir ~cachedir ~configdir = in let redirect_latest req = - let job_name = Dream.param "job" req in - let platform = Dream.query "platform" req in - let path = Dream.path req |> String.concat "/" in + let job_name = Dream.param req "job" in + let platform = Dream.query req "platform" 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 - and build = Dream.param "build" req in + let job_name = Dream.param req "job" + 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 - and build = Dream.param "build" req - and cachedir = Dream.global cachedir_global req in + let _job_name = Dream.param req "job" + and build = Dream.param req "build" in get_uuid build >>= fun uuid -> - (try_load_cached_visualization ~cachedir ~uuid viz_typ - |> if_error "Error getting cached visualization") + try_load_cached_visualization ~cachedir ~uuid viz_typ + |> 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 "job" req - and build = Dream.param "build" req in + let job_name = Dream.param req "job" + and build = Dream.param req "build" 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 "job" req - and build = Dream.param "build" req - and filepath = Dream.path req |> String.concat "/" in - let if_none_match = Dream.header "if-none-match" req in + let _job_name = Dream.param req "job" + and build = Dream.param req "build" + (* FIXME *) + and filepath = begin[@alert "-deprecated"] Dream.path req |> String.concat "/" end in + let if_none_match = Dream.header req "if-none-match" in (* 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 "job" req - and build = Dream.param "build" req in + let _job_name = Dream.param req "job" + and build = Dream.param req "build" 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 count = to_int 10 (Dream.query "count" req) in + let start = to_int 0 (Dream.query req "start") in + let count = to_int 10 (Dream.query req "count") in Dream.sql req (Model.failed_builds ~start ~count platform) |> if_error "Error getting data" ~log:(fun e -> Log.warn (fun m -> m "Error getting failed builds: %a" @@ -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 "job" req - and build = Dream.param "build" req in + let _job_name = Dream.param req "job" + and build = Dream.param req "build" in get_uuid build >>= fun build -> Dream.sql req (Model.build build) |> if_error "Error getting build" >>= fun (build_id, build) -> @@ -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 - let cachedir = Dream.global cachedir_global req 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" @@ -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 "build_left" req in - let build_right = Dream.param "build_right" req in + let build_left = Dream.param req "build_left" in + let build_right = Dream.param req "build_right" 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 platform = Dream.param "platform" req in + let job = Dream.param req "job" 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); diff --git a/lib/dream_tar.ml b/lib/dream_tar.ml index 56f4f67..3588700 100644 --- a/lib/dream_tar.ml +++ b/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 = - Dream.write response (Cstruct.to_string cs) + let really_write stream cs = + Dream.write stream (Cstruct.to_string cs) end module HW = Tar.HeaderWriter(Lwt)(Writer) -let write_block (header : Tar.Header.t) lpath response = - HW.write ~level:Tar.Header.Ustar header response >>= fun () -> +let write_block (header : Tar.Header.t) lpath stream = + 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 response Tar.Header.zero_block >>= fun () -> - Dream.close_stream response + Writer.really_write stream Tar.Header.zero_block >>= fun () -> + Writer.really_write stream Tar.Header.zero_block >>= fun () -> + Dream.flush stream >>= fun () -> + Dream.close stream