robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
Reviewed-on: https://git.robur.io/robur/builder-web/pulls/103
This commit is contained in:
Reynir Björnsson 2022-05-12 15:06:38 +00:00
commit a85be8730c
34 changed files with 1419 additions and 1674 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
bin/builder_db_app.ml
View file

@ -1,3 +1,5 @@
open Caqti_request.Infix
let ( let* ) = Result.bind let ( let* ) = Result.bind
let ( let+ ) x f = Result.map f x 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; Format.eprintf "Database error: %a\n" Caqti_error.pp e;
exit exit_code exit exit_code
let foreign_keys =
Caqti_request.exec
Caqti_type.unit
"PRAGMA foreign_keys = ON"
let defer_foreign_keys = let defer_foreign_keys =
Caqti_request.exec Caqti_type.unit ->. Caqti_type.unit @@
Caqti_type.unit "PRAGMA defer_foreign_keys = ON"
"PRAGMA defer_foreign_keys = ON"
let connect uri = let connect uri =
let* (module Db : Caqti_blocking.CONNECTION) = Caqti_blocking.connect uri in let* (module Db : Caqti_blocking.CONNECTION) = Caqti_blocking.connect ~tweaks_version:(1,8) uri in
let* () = Db.exec foreign_keys () in
let* () = Db.exec defer_foreign_keys () in let* () = Db.exec defer_foreign_keys () in
Ok (module Db : Caqti_blocking.CONNECTION) Ok (module Db : Caqti_blocking.CONNECTION)
@ -179,19 +174,16 @@ let job_remove () datadir jobname =
or_die 1 r or_die 1 r
let input_ids = let input_ids =
Caqti_request.collect Caqti_type.unit ->* Builder_db.Rep.cstruct @@
Caqti_type.unit "SELECT DISTINCT input_id FROM build WHERE input_id IS NOT NULL"
Builder_db.Rep.cstruct
"SELECT DISTINCT input_id FROM build WHERE input_id IS NOT NULL"
let main_artifact_hash = let main_artifact_hash =
Caqti_request.collect Builder_db.Rep.cstruct ->*
Builder_db.Rep.cstruct Caqti_type.tup3 Builder_db.Rep.cstruct Builder_db.Rep.uuid Caqti_type.string @@
(Caqti_type.tup3 Builder_db.Rep.cstruct Builder_db.Rep.uuid Caqti_type.string) {|
{| SELECT a.sha256, b.uuid, j.name FROM build_artifact a, build b, job j
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
WHERE b.input_id = ? AND a.id = b.main_binary AND b.job = j.id |}
|}
let verify_input_id () dbpath = let verify_input_id () dbpath =
let r = let r =
@ -219,26 +211,25 @@ let verify_input_id () dbpath =
or_die 1 r or_die 1 r
let num_build_artifacts = let num_build_artifacts =
Caqti_request.find Caqti_type.unit ->! Caqti_type.int @@
Caqti_type.unit "SELECT count(*) FROM build_artifact"
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 = let build_artifacts : (unit, string * Uuidm.t * (Fpath.t * Fpath.t * Cstruct.t * int64), [ `One | `Zero | `Many ]) Caqti_request.t =
Caqti_request.collect Caqti_type.unit ->*
Caqti_type.unit Caqti_type.(tup3 string Builder_db.Rep.uuid
Caqti_type.(tup3 string Builder_db.Rep.uuid (tup4 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct int64)) (tup4 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct int64))
{| SELECT job.name, b.uuid, a.filepath, a.localpath, a.sha256, a.size @@
FROM build_artifact a, build b, job {| SELECT job.name, b.uuid, a.filepath, a.localpath, a.sha256, a.size
WHERE a.build = b.id AND b.job = job.id |} 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 = let script_and_console : (unit, _, [`One | `Zero | `Many ]) Caqti_request.t =
Caqti_request.collect Caqti_type.unit ->*
Caqti_type.unit Caqti_type.(tup4 string Builder_db.Rep.uuid Builder_db.Rep.fpath Builder_db.Rep.fpath)
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 {| SELECT job.name, b.uuid, b.console, b.script
FROM build b, job FROM build b, job
WHERE job.id = b.job |} WHERE job.id = b.job |}
module FpathSet = Set.Make(Fpath) module FpathSet = Set.Make(Fpath)

5
bin/builder_web_app.ml
View file

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

20
bin/migrations/grej.ml
View file

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

82
bin/migrations/m20210126.ml
View file

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

10
bin/migrations/m20210202.ml
View file

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

51
bin/migrations/m20210216.ml
View file

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

162
bin/migrations/m20210218.ml
View file

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

17
bin/migrations/m20210308.ml
View file

@ -1,17 +1,16 @@
module Rep = Builder_db.Rep module Rep = Builder_db.Rep
open Grej.Infix
let broken_builds = let broken_builds =
Caqti_request.collect ~oneshot:true Caqti_type.unit ->* Caqti_type.tup3 (Rep.id `build) Rep.uuid Caqti_type.string @@
Caqti_type.unit {| SELECT b.id, b.uuid, job.name FROM build b, job
(Caqti_type.tup3 (Rep.id `build) Rep.uuid Caqti_type.string) WHERE result_kind = 0 AND result_code = 0 AND main_binary IS NOT NULL AND job.id = b.job AND
{| SELECT b.id, b.uuid, job.name FROM build b, job (SELECT COUNT( * ) FROM build_artifact a
WHERE result_kind = 0 AND result_code = 0 AND main_binary IS NOT NULL AND job.id = b.job AND WHERE a.build = b.id and a.filepath = b.main_binary) = 0
(SELECT COUNT( * ) FROM build_artifact a |}
WHERE a.build = b.id and a.filepath = b.main_binary) = 0
|}
let fixup datadir (module Db : Caqti_blocking.CONNECTION) = let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
let open Grej.Infix in
Grej.check_version ~user_version:3L (module Db) >>= fun () -> Grej.check_version ~user_version:3L (module Db) >>= fun () ->
Db.rev_collect_list broken_builds () >>= fun broken_builds -> Db.rev_collect_list broken_builds () >>= fun broken_builds ->
Grej.list_iter_result Grej.list_iter_result

20
bin/migrations/m20210427.ml
View file

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

13
bin/migrations/m20210531.ml
View file

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

164
bin/migrations/m20210602.ml
View file

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

110
bin/migrations/m20210608.ml
View file

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

142
bin/migrations/m20210609.ml
View file

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

36
bin/migrations/m20210625.ml
View file

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

102
bin/migrations/m20210629.ml
View file

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

66
bin/migrations/m20210630.ml
View file

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

109
bin/migrations/m20210701.ml
View file

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

106
bin/migrations/m20210706.ml
View file

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

14
bin/migrations/m20210707a.ml
View file

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

34
bin/migrations/m20210707b.ml
View file

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

36
bin/migrations/m20210707c.ml
View file

@ -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 = let all_builds_with_binary : (unit, [`build] Builder_db.Rep.id * [`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t =
Caqti_request.collect ~oneshot:true Caqti_type.unit ->*
Caqti_type.unit Caqti_type.tup4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact)
(Caqti_type.tup4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath) Builder_db.Rep.fpath Builder_db.Rep.fpath @@
"SELECT b.id, b.main_binary, a.filepath, a.localpath FROM build b, build_artifact a WHERE b.main_binary = a.id AND b.main_binary IS NOT NULL" "SELECT b.id, b.main_binary, a.filepath, a.localpath FROM build b, build_artifact a WHERE b.main_binary = a.id AND b.main_binary IS NOT NULL"
let build_not_stripped : ([`build] Builder_db.Rep.id, [`build_artifact] Builder_db.Rep.id, [< `Zero | `One | `Many > `Zero `One ]) Caqti_request.t = let build_not_stripped : ([`build] Builder_db.Rep.id, [`build_artifact] Builder_db.Rep.id, [ `Zero | `One ]) Caqti_request.t =
Caqti_request.find_opt Builder_db.Rep.id `build ->? Builder_db.Rep.id `build_artifact @@
(Builder_db.Rep.id `build) "SELECT id FROM build_artifact WHERE build = ? AND filepath LIKE '%.debug'"
(Builder_db.Rep.id `build_artifact)
{| SELECT id FROM build_artifact WHERE build = ? AND filepath LIKE '%.debug' |}
let update_paths : ([`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, unit, [< `Zero | `One | `Many > `Zero ]) Caqti_request.t = let update_paths : ([`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, unit, [ `Zero ]) Caqti_request.t =
Caqti_request.exec Caqti_type.tup3 (Builder_db.Rep.id `build_artifact)
(Caqti_type.tup3 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath Builder_db.Rep.fpath) Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
"UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1" Caqti_type.unit @@
"UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1"
let add_artifact : ((Fpath.t * Fpath.t * Cstruct.t) * (int64 * [`build] Builder_db.Rep.id), unit, [< `Zero | `One | `Many > `Zero]) Caqti_request.t = let add_artifact : ((Fpath.t * Fpath.t * Cstruct.t) * (int64 * [`build] Builder_db.Rep.id), unit, [ `Zero]) Caqti_request.t =
Caqti_request.exec Caqti_type.(tup2 (tup3 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct)
Caqti_type.(tup2 (tup3 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct) (tup2 Caqti_type.int64 (Builder_db.Rep.id `build))) (tup2 Caqti_type.int64 (Builder_db.Rep.id `build))) ->.
{| INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?) |} Caqti_type.unit @@
"INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?)"
let fixup datadir (module Db : Caqti_blocking.CONNECTION) = let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
let open Grej.Infix in
Grej.check_version ~user_version:12L (module Db) >>= fun () -> Grej.check_version ~user_version:12L (module Db) >>= fun () ->
Db.rev_collect_list all_builds_with_binary () >>= fun builds -> Db.rev_collect_list all_builds_with_binary () >>= fun builds ->
Grej.list_iter_result Grej.list_iter_result

15
bin/migrations/m20210707d.ml
View file

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

187
bin/migrations/m20210712a.ml
View file

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

16
bin/migrations/m20210712b.ml
View file

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

190
bin/migrations/m20210712c.ml
View file

@ -28,107 +28,101 @@ module Asn = struct
end end
let new_build = let new_build =
Caqti_request.exec Caqti_type.unit ->. Caqti_type.unit @@
Caqti_type.unit {| CREATE TABLE new_build (
{| CREATE TABLE new_build ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, uuid VARCHAR(36) NOT NULL UNIQUE,
uuid VARCHAR(36) NOT NULL UNIQUE, start_d INTEGER NOT NULL,
start_d INTEGER NOT NULL, start_ps INTEGER NOT NULL,
start_ps INTEGER NOT NULL, finish_d INTEGER NOT NULL,
finish_d INTEGER NOT NULL, finish_ps INTEGER NOT NULL,
finish_ps INTEGER NOT NULL, result_code INTEGER NOT NULL,
result_code INTEGER NOT NULL, result_msg TEXT,
result_msg TEXT, console TEXT NOT NULL,
console TEXT NOT NULL, script TEXT NOT NULL,
script TEXT NOT NULL, main_binary INTEGER,
main_binary INTEGER, user INTEGER NOT NULL,
user INTEGER NOT NULL, job INTEGER NOT NULL,
job INTEGER NOT NULL, input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
FOREIGN KEY(user) REFERENCES user(id), FOREIGN KEY(user) REFERENCES user(id),
FOREIGN KEY(job) REFERENCES job(id) FOREIGN KEY(job) REFERENCES job(id)
) )
|} |}
let old_build = let old_build =
Caqti_request.exec Caqti_type.unit ->. Caqti_type.unit @@
Caqti_type.unit {| CREATE TABLE new_build (
{| CREATE TABLE new_build ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, uuid VARCHAR(36) NOT NULL UNIQUE,
uuid VARCHAR(36) NOT NULL UNIQUE, start_d INTEGER NOT NULL,
start_d INTEGER NOT NULL, start_ps INTEGER NOT NULL,
start_ps INTEGER NOT NULL, finish_d INTEGER NOT NULL,
finish_d INTEGER NOT NULL, finish_ps INTEGER NOT NULL,
finish_ps INTEGER NOT NULL, result_code INTEGER NOT NULL,
result_code INTEGER NOT NULL, result_msg TEXT,
result_msg TEXT, console BLOB NOT NULL,
console BLOB NOT NULL, script TEXT NOT NULL,
script TEXT NOT NULL, main_binary INTEGER,
main_binary INTEGER, user INTEGER NOT NULL,
user INTEGER NOT NULL, job INTEGER NOT NULL,
job INTEGER NOT NULL, input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
FOREIGN KEY(user) REFERENCES user(id), FOREIGN KEY(user) REFERENCES user(id),
FOREIGN KEY(job) REFERENCES job(id) FOREIGN KEY(job) REFERENCES job(id)
) )
|} |}
let copy_from_old_build = let copy_from_old_build =
Caqti_request.exec Caqti_type.unit ->. Caqti_type.unit @@
Caqti_type.unit {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
{| 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)
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,
SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, '', '', main_binary, user, job, input_id
'', '', main_binary, user, job, input_id FROM build
FROM build |}
|}
let copy_from_new_build = let copy_from_new_build =
Caqti_request.exec Caqti_type.unit ->. Caqti_type.unit @@
Caqti_type.unit {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
{| 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)
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,
SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, x'', '', main_binary, user, job, input_id
x'', '', main_binary, user, job, input_id FROM build
FROM build |}
|}
let old_build_console_script = let old_build_console_script =
Caqti_request.collect Caqti_type.unit ->*
Caqti_type.unit Caqti_type.(tup4 (Builder_db.Rep.id (`build : [ `build ]))
Caqti_type.(tup4 (Builder_db.Rep.id (`build : [ `build ])) (tup2 string Builder_db.Rep.uuid) Builder_db.Rep.cstruct string) @@
(tup2 string Builder_db.Rep.uuid) Builder_db.Rep.cstruct string) "SELECT b.id, job.name, b.uuid, b.console, b.script FROM build b, job WHERE b.job = job.id"
"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 = let update_new_build_console_script =
Caqti_request.exec Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ]))
Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath) Builder_db.Rep.fpath Builder_db.Rep.fpath) ->.
"UPDATE new_build SET console = $2, script = $3 WHERE id = $1" Caqti_type.unit @@
"UPDATE new_build SET console = $2, script = $3 WHERE id = $1"
let new_build_console_script = let new_build_console_script =
Caqti_request.collect Caqti_type.unit ->*
Caqti_type.unit Caqti_type.tup3 (Builder_db.Rep.id (`build : [ `build ]))
Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath) Builder_db.Rep.fpath Builder_db.Rep.fpath @@
"SELECT id, console, script FROM build" "SELECT id, console, script FROM build"
let update_old_build_console_script = let update_old_build_console_script =
Caqti_request.exec Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.cstruct string) ->.
Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.cstruct string) Caqti_type.unit @@
"UPDATE new_build SET console = $2, script = $3 WHERE id = $1" "UPDATE new_build SET console = $2, script = $3 WHERE id = $1"
let drop_build = let drop_build =
Caqti_request.exec Caqti_type.unit ->. Caqti_type.unit @@
Caqti_type.unit "DROP TABLE build"
"DROP TABLE build"
let rename_build = let rename_build =
Caqti_request.exec Caqti_type.unit ->. Caqti_type.unit @@
Caqti_type.unit "ALTER TABLE new_build RENAME TO build"
"ALTER TABLE new_build RENAME TO build"
let console_to_string console = let console_to_string console =
Asn.console_of_cs console Asn.console_of_cs console
@ -187,17 +181,18 @@ let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
console_scripts >>= fun () -> console_scripts >>= fun () ->
Db.exec drop_build () >>= fun () -> Db.exec drop_build () >>= fun () ->
Db.exec rename_build () >>= fun () -> Db.exec rename_build () >>= fun () ->
Db.exec (Caqti_request.exec Caqti_type.unit Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
"CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)") "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
() >>= fun () -> () >>= fun () ->
Db.exec (Caqti_request.exec Caqti_type.unit Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
"CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0") "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
WHERE result_code <> 0")
() >>= fun () -> () >>= fun () ->
Db.exec (Caqti_request.exec Caqti_type.unit Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
"CREATE INDEX idx_build_input_id ON build(input_id)") "CREATE INDEX idx_build_input_id ON build(input_id)")
() >>= fun () -> () >>= fun () ->
Db.exec (Caqti_request.exec Caqti_type.unit Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
"CREATE INDEX idx_build_main_binary ON build(main_binary)") "CREATE INDEX idx_build_main_binary ON build(main_binary)")
() >>= fun () -> () >>= fun () ->
Db.exec (Grej.set_version new_version) () Db.exec (Grej.set_version new_version) ()
@ -212,16 +207,17 @@ let rollback datadir (module Db : Caqti_blocking.CONNECTION) =
console_scripts >>= fun () -> console_scripts >>= fun () ->
Db.exec drop_build () >>= fun () -> Db.exec drop_build () >>= fun () ->
Db.exec rename_build () >>= fun () -> Db.exec rename_build () >>= fun () ->
Db.exec (Caqti_request.exec Caqti_type.unit Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
"CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)") "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
() >>= fun () -> () >>= fun () ->
Db.exec (Caqti_request.exec Caqti_type.unit Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
"CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0") "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) \
WHERE result_code <> 0")
() >>= fun () -> () >>= fun () ->
Db.exec (Caqti_request.exec Caqti_type.unit Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
"CREATE INDEX idx_build_input_id ON build(input_id)") "CREATE INDEX idx_build_input_id ON build(input_id)")
() >>= fun () -> () >>= fun () ->
Db.exec (Caqti_request.exec Caqti_type.unit Db.exec (Caqti_type.unit ->. Caqti_type.unit @@
"CREATE INDEX idx_build_main_binary ON build(main_binary)") "CREATE INDEX idx_build_main_binary ON build(main_binary)")
() >>= fun () -> () >>= fun () ->
Db.exec (Grej.set_version old_version) () Db.exec (Grej.set_version old_version) ()

19
bin/migrations/m20210910.ml
View file

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

203
bin/migrations/m20211105.ml
View file

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

2
builder-web.opam
View file

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

874
db/builder_db.ml
View file

File diff suppressed because it is too large Load diff

86
db/builder_db.mli
View file

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

5
db/representation.ml
View file

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

8
lib/authorization.ml
View file

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

99
lib/builder_web.ml
View file

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

25
lib/dream_tar.ml
View file

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