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

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
in
Dream.initialize_log ?level ();
Dream.run ~port ~interface:host ~https:false
Dream.run ~port ~interface:host ~tls:false
@@ Dream.logger
@@ Dream.sql_pool ("sqlite3:" ^ dbpath)
@@ Http_status_metrics.handle
@@ Builder_web.Middleware.remove_trailing_url_slash
@@ Builder_web.add_routes ~datadir ~cachedir ~configdir
@@ Builder_web.not_found
@@ Dream.router (Builder_web.routes ~datadir ~cachedir ~configdir)
open Cmdliner

20
bin/migrations/grej.ml
View file

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

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

10
bin/migrations/m20210202.ml
View file

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

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

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

17
bin/migrations/m20210308.ml
View file

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

20
bin/migrations/m20210427.ml
View file

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

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

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

110
bin/migrations/m20210608.ml
View file

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

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

36
bin/migrations/m20210625.ml
View file

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

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

66
bin/migrations/m20210630.ml
View file

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

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

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

14
bin/migrations/m20210707a.ml
View file

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

34
bin/migrations/m20210707b.ml
View file

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

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

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

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

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

190
bin/migrations/m20210712c.ml
View file

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

19
bin/migrations/m20210910.ml
View file

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

203
bin/migrations/m20211105.ml
View file

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

2
builder-web.opam
View file

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

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] *)
let last_insert_rowid =
Caqti_request.find
Caqti_type.unit
any_id
let open Caqti_request.Infix in
Caqti_type.unit ->! any_id @@
"SELECT last_insert_rowid()"

8
lib/authorization.ml
View file

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

99
lib/builder_web.ml
View file

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

25
lib/dream_tar.ml
View file

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