module Rep = Representation open Rep open Caqti_request.Infix let application_id = 1234839235l (* Please update this when making changes! And also update packaging/batch-viz.sh and packaging/visualizations.sh. *) let current_version = 18L type 'a id = 'a Rep.id type file = Rep.file = { filepath : Fpath.t; sha256 : string; size : int; } let last_insert_rowid = Rep.last_insert_rowid let get_application_id = Caqti_type.unit ->! Caqti_type.int32 @@ "PRAGMA application_id" let get_version = Caqti_type.unit ->! Caqti_type.int64 @@ "PRAGMA user_version" let set_application_id = Caqti_type.unit ->. Caqti_type.unit @@ Printf.sprintf "PRAGMA application_id = %ld" application_id let set_current_version = Caqti_type.unit ->. Caqti_type.unit @@ Printf.sprintf "PRAGMA user_version = %Ld" current_version module Job = struct let migrate = Caqti_type.unit ->. Caqti_type.unit @@ {| CREATE TABLE job ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, name VARCHAR(255) NOT NULL UNIQUE ) |} let rollback = Caqti_type.unit ->. Caqti_type.unit @@ "DROP TABLE IF EXISTS job" let get = id `job ->! Caqti_type.string @@ "SELECT name FROM job WHERE id = ?" let get_id_by_name = Caqti_type.string ->? id `job @@ "SELECT id FROM job WHERE name = ?" let get_all_with_section_synopsis = Caqti_type.unit ->* Caqti_type.(t4 (id `job) string (option string) (option string)) @@ {| SELECT j.id, j.name, section.value, synopsis.value FROM job j, tag section_tag, tag synopsis_tag LEFT JOIN job_tag section ON section.job = j.id AND section.tag = section_tag.id LEFT JOIN job_tag synopsis ON synopsis.job = j.id AND synopsis.tag = synopsis_tag.id WHERE section_tag.tag = 'section' AND synopsis_tag.tag = 'synopsis' ORDER BY section.value, j.name ASC |} let try_add = Caqti_type.string ->. Caqti_type.unit @@ "INSERT OR IGNORE INTO job (name) VALUES (?)" let remove = id `job ->. Caqti_type.unit @@ "DELETE FROM job WHERE id = ?" end module Tag = struct let migrate = Caqti_type.unit ->. Caqti_type.unit @@ {| CREATE TABLE tag ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, tag VARCHAR(255) NOT NULL UNIQUE ) |} let rollback = Caqti_type.unit ->. Caqti_type.unit @@ "DROP TABLE IF EXISTS tag" let get_id_by_name = Caqti_type.string ->! id `tag @@ "SELECT id FROM tag WHERE tag = ?" let try_add = Caqti_type.string ->. Caqti_type.unit @@ "INSERT OR IGNORE INTO tag (tag) VALUES (?)" end module Job_tag = struct let migrate = 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) ) |} let rollback = Caqti_type.unit ->. Caqti_type.unit @@ "DROP TABLE IF EXISTS job_tag" let add = Caqti_type.(t3 (id `tag) string (id `job)) ->. Caqti_type.unit @@ "INSERT INTO job_tag (tag, value, job) VALUES ($1, $2, $3)" let update = Caqti_type.(t3 (id `tag) string (id `job)) ->. Caqti_type.unit @@ "UPDATE job_tag SET value = $2 WHERE tag = $1 AND job = $3" let get_value = Caqti_type.(t2 (id `tag) (id `job)) ->? Caqti_type.string @@ "SELECT value FROM job_tag WHERE tag = ? AND job = ?" let remove_by_job = id `job ->. Caqti_type.unit @@ "DELETE FROM job_tag WHERE job = ?" end module Build_artifact = struct let migrate = Caqti_type.unit ->. Caqti_type.unit @@ {| CREATE TABLE build_artifact ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, filepath TEXT NOT NULL, -- the path as in the build sha256 BLOB NOT NULL, size INTEGER NOT NULL, build INTEGER NOT NULL, FOREIGN KEY(build) REFERENCES build(id), UNIQUE(build, filepath) ) |} let rollback = Caqti_type.unit ->. Caqti_type.unit @@ "DROP TABLE IF EXISTS build_artifact" let get = id `build_artifact ->! file @@ {| SELECT filepath, sha256, size FROM build_artifact WHERE id = ? |} let get_by_build_uuid = Caqti_type.t2 uuid fpath ->? Caqti_type.t2 (id `build_artifact) file @@ {| SELECT build_artifact.id, build_artifact.filepath, build_artifact.sha256, build_artifact.size FROM build_artifact INNER JOIN build ON build.id = build_artifact.build WHERE build.uuid = ? AND build_artifact.filepath = ? |} let get_all_by_build = id `build ->* Caqti_type.(t2 (id `build_artifact) file) @@ "SELECT id, filepath, sha256, size FROM build_artifact WHERE build = ?" let exists = Caqti_type.octets ->! Caqti_type.bool @@ "SELECT EXISTS(SELECT 1 FROM build_artifact WHERE sha256 = ?)" let add = Caqti_type.(t2 file (id `build)) ->. Caqti_type.unit @@ "INSERT INTO build_artifact (filepath, sha256, size, build) \ VALUES (?, ?, ?, ?)" let remove_by_build = id `build ->. Caqti_type.unit @@ "DELETE FROM build_artifact WHERE build = ?" let remove = id `build_artifact ->. Caqti_type.unit @@ "DELETE FROM build_artifact WHERE id = ?" end module Build = struct type t = { uuid : Uuidm.t; start : Ptime.t; finish : Ptime.t; result : Builder.execution_result; console : Fpath.t; script : Fpath.t; platform : string; main_binary : [`build_artifact] id option; input_id : string option; user_id : [`user] id; job_id : [`job] id; } let pp ppf t = Fmt.pf ppf "@[{ uuid=@ %a;@ \ start=@ %a;@ \ finish=@ %a;@ \ result=@ @[%a@];@ \ console=@ %a;@ \ script=@ %a;@ \ platform=@ %S;@ \ main_binary=@ @[%a@];@ \ input_id=@ @[%a@];@ \ user_id=@ %Lx;@ \ job_id=@ %Lx;@ }@]" Uuidm.pp t.uuid Ptime.pp t.start Ptime.pp t.finish Builder.pp_execution_result t.result Fpath.pp t.console Fpath.pp t.script t.platform Fmt.(Dump.option int64) t.main_binary Fmt.(Dump.option string) t.input_id t.user_id t.job_id let t = let rep = Caqti_type.(t11 uuid Rep.ptime Rep.ptime execution_result fpath fpath string (option (Rep.id `build_artifact)) (option octets) (id `user) (id `job)) in let encode { uuid; start; finish; result; console; script; platform; main_binary; input_id; user_id; job_id } = Ok (uuid, start, finish, result, console, script, platform, main_binary, input_id, user_id, job_id) in let decode (uuid, start, finish, result, console, script, platform, main_binary, input_id, user_id, job_id) = Ok { uuid; start; finish; result; console; script; platform; main_binary; input_id; user_id; job_id } in Caqti_type.custom ~encode ~decode rep let migrate = Caqti_type.unit ->. Caqti_type.unit @@ {| CREATE TABLE build ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, uuid VARCHAR(36) NOT NULL UNIQUE, start_d INTEGER NOT NULL, start_ps INTEGER NOT NULL, finish_d INTEGER NOT NULL, finish_ps INTEGER NOT NULL, result_code INTEGER NOT NULL, result_msg TEXT, console TEXT NOT NULL, script TEXT NOT NULL, platform TEXT NOT NULL, main_binary INTEGER, user INTEGER NOT NULL, job INTEGER NOT NULL, input_id BLOB, -- sha256 (sha256 || sha256 || sha256) FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, FOREIGN KEY(user) REFERENCES user(id), FOREIGN KEY(job) REFERENCES job(id) ) |} let rollback = Caqti_type.unit ->. Caqti_type.unit @@ "DROP TABLE IF EXISTS build" let get_by_uuid = Rep.uuid ->? Caqti_type.t2 (id `build) t @@ {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, console, script, platform, main_binary, input_id, user, job FROM build WHERE uuid = ? |} let get_all = id `job ->* Caqti_type.t2 (id `build) t @@ {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, console, script, platform, main_binary, input_id, user, job FROM build WHERE job = ? ORDER BY start_d DESC, start_ps DESC |} let get_all_failed = Caqti_type.(t3 int int (option string)) ->* Caqti_type.t2 Caqti_type.string t @@ {| SELECT job.name, b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.result_code, b.result_msg, b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job FROM build b INNER JOIN job ON job.id = b.job WHERE b.main_binary IS NULL AND ($3 IS NULL OR b.platform = $3) ORDER BY start_d DESC, start_ps DESC LIMIT $2 OFFSET $1 |} let get_all_artifact_sha = Caqti_type.(t2 (id `job) (option string)) ->* Caqti_type.octets @@ {| SELECT DISTINCT a.sha256 FROM build_artifact a, build b WHERE b.job = $1 AND b.main_binary = a.id AND ($2 IS NULL OR b.platform = $2) ORDER BY b.start_d DESC, b.start_ps DESC |} let get_failed_builds = Caqti_type.(t2 (id `job) (option string)) ->* t @@ {| SELECT uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, console, script, platform, main_binary, input_id, user, job FROM build WHERE job = $1 AND main_binary IS NULL AND ($2 IS NULL OR platform = $2) ORDER BY start_d DESC, start_ps DESC |} let get_latest_successful_with_binary = Caqti_type.(t2 (id `job) string) ->? Caqti_type.t3 (id `build) t file @@ {| SELECT b.id, b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.result_code, b.result_msg, b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job, a.filepath, a.sha256, a.size FROM build b, build_artifact a WHERE b.main_binary = a.id AND b.job = $1 AND b.platform = $2 AND b.main_binary IS NOT NULL ORDER BY b.start_d DESC, b.start_ps DESC LIMIT 1 |} let get_builds_older_than = Caqti_type.(t3 (id `job) (option string) Rep.ptime) ->* Caqti_type.t2 (id `build) t @@ {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, console, script, platform, main_binary, input_id, user, job FROM build WHERE job = $1 AND ($2 IS NULL OR platform = $2) AND (finish_d < $3 OR (finish_d = $3 AND finish_ps <= $4)) ORDER BY start_d DESC, start_ps DESC |} let get_builds_excluding_latest_n = Caqti_type.(t3 (id `job) (option string) int) ->* Caqti_type.t2 (id `build) t @@ {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, console, script, platform, main_binary, input_id, user, job FROM build WHERE job = $1 AND ($2 IS NULL OR platform = $2) ORDER BY start_d DESC, start_ps DESC LIMIT -1 OFFSET $3 |} (* "LIMIT -1 OFFSET n" is all rows except the first n *) let get_nth_latest_successful = Caqti_type.(t3 (id `job) (option string) int) ->? Caqti_type.t2 (id `build) t @@ {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, console, script, platform, main_binary, input_id, user, job FROM build WHERE job = $1 AND ($2 IS NULL OR platform = $2) AND main_binary IS NOT NULL ORDER BY start_d DESC, start_ps DESC LIMIT 1 OFFSET $3 |} let get_latest_successful = Caqti_type.(t2 (id `job) (option string)) ->? t @@ {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.result_code, b.result_msg, b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job FROM build b WHERE b.job = $1 AND ($2 IS NULL OR b.platform = $2) AND b.main_binary IS NOT NULL ORDER BY b.start_d DESC, b.start_ps DESC LIMIT 1 |} let get_previous_successful_different_output = id `build ->? t @@ {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.result_code, b.result_msg, b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job FROM build b, build b0, build_artifact a, build_artifact a0 WHERE b0.id = ? AND b0.job = b.job AND b.platform = b0.platform AND b.main_binary IS NOT NULL AND a.id = b.main_binary AND a0.id = b0.main_binary AND a.sha256 <> a0.sha256 AND (b0.start_d > b.start_d OR b0.start_d = b.start_d AND b0.start_ps > b.start_ps) ORDER BY b.start_d DESC, b.start_ps DESC LIMIT 1 |} let get_next_successful_different_output = id `build ->? t @@ {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.result_code, b.result_msg, b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job FROM build b, build b0, build_artifact a, build_artifact a0 WHERE b0.id = ? AND b0.job = b.job AND b.platform = b0.platform AND b.main_binary IS NOT NULL AND a.id = b.main_binary AND a0.id = b0.main_binary AND a.sha256 <> a0.sha256 AND (b0.start_d < b.start_d OR b0.start_d = b.start_d AND b0.start_ps < b.start_ps) ORDER BY b.start_d ASC, b.start_ps ASC LIMIT 1 |} let get_same_input_same_output_builds = id `build ->* t @@ {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.result_code, b.result_msg, b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job FROM build b0, build_artifact a0, build b, build_artifact a WHERE b0.id = ? AND a0.id = b0.main_binary AND a0.sha256 = a.sha256 AND b.main_binary = a.id AND b.id <> b0.id AND b0.input_id = b.input_id ORDER BY b.start_d DESC, b.start_ps DESC |} let get_same_input_different_output_hashes = id `build ->* Caqti_type.octets @@ {| SELECT DISTINCT a.sha256 FROM build b0, build_artifact a0, build b, build_artifact a WHERE b0.id = ? AND a0.id = b0.main_binary AND a0.sha256 <> a.sha256 AND b.main_binary = a.id AND b.id <> b0.id AND b0.input_id = b.input_id ORDER BY b.start_d DESC, b.start_ps DESC |} let get_different_input_same_output_input_ids = id `build ->* Caqti_type.octets @@ {| SELECT DISTINCT b.input_id FROM build b0, build_artifact a0, build b, build_artifact a WHERE b0.id = ? AND a0.id = b0.main_binary AND a0.sha256 = a.sha256 AND b.main_binary = a.id AND b0.input_id <> b.input_id |} let get_one_by_input_id = Caqti_type.octets ->! t @@ {| SELECT uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, console, script, platform, main_binary, input_id, user, job FROM build WHERE input_id = ? ORDER BY start_d DESC, start_ps DESC LIMIT 1 |} let get_platforms_for_job = id `job ->* Caqti_type.string @@ "SELECT DISTINCT platform FROM build WHERE job = ? ORDER BY platform" let add = t ->. Caqti_type.unit @@ {| INSERT INTO build (uuid, start_d, start_ps, finish_d, finish_ps, result_code, result_msg, console, script, platform, main_binary, input_id, user, job) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |} let get_by_hash = Caqti_type.octets ->! t @@ {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.result_code, b.result_msg, b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job FROM build_artifact a INNER JOIN build b ON b.id = a.build WHERE a.sha256 = ? ORDER BY b.start_d DESC, b.start_ps DESC LIMIT 1 |} let get_with_main_binary_by_hash = Caqti_type.octets ->! Caqti_type.t2 t file_opt @@ {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.result_code, b.result_msg, b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job, a.filepath, a.sha256, a.size FROM build_artifact a INNER JOIN build b ON b.id = a.build WHERE a.sha256 = ? ORDER BY b.start_d DESC, b.start_ps DESC LIMIT 1 |} let get_with_jobname_by_hash = Caqti_type.octets ->? Caqti_type.t2 Caqti_type.string t @@ {| SELECT job.name, b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.result_code, b.result_msg, b.console, b.script, b.platform, b.main_binary, b.input_id, b.user, b.job FROM build_artifact a INNER JOIN build b ON b.id = a.build INNER JOIN job ON job.id = b.job WHERE a.sha256 = ? ORDER BY b.start_d DESC, b.start_ps DESC LIMIT 1 |} let set_main_binary = Caqti_type.t2 (id `build) (id `build_artifact) ->. Caqti_type.unit @@ "UPDATE build SET main_binary = $2 WHERE id = $1" let remove = id `build ->. Caqti_type.unit @@ "DELETE FROM build WHERE id = ?" end module User = struct let migrate = Caqti_type.unit ->. Caqti_type.unit @@ {| CREATE TABLE user ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, username VARCHAR(255) NOT NULL UNIQUE, password_hash BLOB NOT NULL, password_salt BLOB NOT NULL, scrypt_n INTEGER NOT NULL, scrypt_r INTEGER NOT NULL, scrypt_p INTEGER NOT NULL, restricted BOOLEAN NOT NULL ) |} let rollback = Caqti_type.unit ->. Caqti_type.unit @@ "DROP TABLE IF EXISTS user" let get_user = Caqti_type.string ->? Caqti_type.t2 (id `user) user_info @@ {| SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted FROM user WHERE username = ? |} let get_all = Caqti_type.unit ->* Caqti_type.string @@ "SELECT username FROM user" let add = user_info ->. Caqti_type.unit @@ {| INSERT INTO user (username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) VALUES (?, ?, ?, ?, ?, ?, ?) |} let remove_user = Caqti_type.string ->. Caqti_type.unit @@ "DELETE FROM user WHERE username = ?" let update_user = user_info ->. Caqti_type.unit @@ {| UPDATE user SET password_hash = $2, password_salt = $3, scrypt_n = $4, scrypt_r = $5, scrypt_p = $6, restricted = $7 WHERE username = $1 |} end module Access_list = struct let migrate = Caqti_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) ) |} let rollback = Caqti_type.unit ->. Caqti_type.unit @@ "DROP TABLE IF EXISTS access_list" let get = Caqti_type.t2 (id `user) (id `job) ->! id `access_list @@ "SELECT id FROM access_list WHERE user = ? AND job = ?" let add = Caqti_type.t2 (id `user) (id `job) ->. Caqti_type.unit @@ "INSERT INTO access_list (user, job) VALUES (?, ?)" let remove = Caqti_type.t2 (id `user) (id `job) ->. Caqti_type.unit @@ "DELETE FROM access_list WHERE user = ? AND job = ?" let remove_by_job = id `job ->. Caqti_type.unit @@ "DELETE FROM access_list WHERE job = ?" let remove_all_by_username = Caqti_type.string ->. Caqti_type.unit @@ {| DELETE FROM access_list WHERE access_list.id IN ( SELECT access_list.id FROM access_list INNER JOIN user ON access_list.user = user.id WHERE user.username = ? ) |} end let migrate = [ Job.migrate; Build.migrate; Build_artifact.migrate; User.migrate; Access_list.migrate; Tag.migrate; Job_tag.migrate; Caqti_type.unit ->. Caqti_type.unit @@ "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"; Caqti_type.unit ->. Caqti_type.unit @@ "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE main_binary IS NULL"; Caqti_type.unit ->. Caqti_type.unit @@ "CREATE INDEX idx_build_input_id ON build(input_id)"; Caqti_type.unit ->. Caqti_type.unit @@ "CREATE INDEX idx_build_main_binary ON build(main_binary)"; Caqti_type.unit ->. Caqti_type.unit @@ "CREATE INDEX idx_build_artifact_sha256 ON build_artifact(sha256)"; Caqti_type.unit ->. Caqti_type.unit @@ "CREATE INDEX idx_build_artifact_build ON build_artifact(build)"; set_current_version; set_application_id; ] let rollback = [ Job_tag.rollback; Tag.rollback; Access_list.rollback; User.rollback; Build_artifact.rollback; Build.rollback; Job.rollback; Caqti_type.unit ->. Caqti_type.unit @@ "DROP INDEX IF EXISTS idx_build_artifact_build"; Caqti_type.unit ->. Caqti_type.unit @@ "DROP INDEX IF EXISTS idx_build_artifact_sha256"; Caqti_type.unit ->. Caqti_type.unit @@ "DROP INDEX IF EXISTS idx_build_failed"; Caqti_type.unit ->. Caqti_type.unit @@ "DROP INDEX IF EXISTS idx_build_input_id"; Caqti_type.unit ->. Caqti_type.unit @@ "DROP INDEX IF EXISTS idx_build_main_binary"; Caqti_type.unit ->. Caqti_type.unit @@ "DROP INDEX IF EXISTS idx_build_job_start"; Caqti_type.unit ->. Caqti_type.unit @@ "PRAGMA user_version = 0"; Caqti_type.unit ->. Caqti_type.unit @@ "PRAGMA application_id = 0"; ]