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

Merge pull request #2 from robur-coop/caqti.2.1.1

Browse source 
Update to Caqti.2.1.1
This commit is contained in:
Reynir Björnsson 2024-08-13 16:47:59 +02:00 committed by GitHub
commit 9216d980b6
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
25 changed files with 119 additions and 123 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
bin/builder_db_app.ml
View file

@ -301,7 +301,7 @@ let input_ids =
let main_artifact_hash = let main_artifact_hash =
Builder_db.Rep.cstruct ->* Builder_db.Rep.cstruct ->*
Caqti_type.tup3 Builder_db.Rep.cstruct Builder_db.Rep.uuid Caqti_type.string @@ Caqti_type.t3 Builder_db.Rep.cstruct Builder_db.Rep.uuid Caqti_type.string @@
{| {|
SELECT a.sha256, b.uuid, j.name FROM build_artifact a, build b, job j SELECT a.sha256, b.uuid, j.name FROM build_artifact a, build b, job j
WHERE b.input_id = ? AND a.id = b.main_binary AND b.job = j.id WHERE b.input_id = ? AND a.id = b.main_binary AND b.job = j.id
@ -336,10 +336,10 @@ let num_build_artifacts =
Caqti_type.unit ->! Caqti_type.int @@ Caqti_type.unit ->! Caqti_type.int @@
"SELECT count(*) FROM build_artifact" "SELECT count(*) FROM build_artifact"
let build_artifacts : (unit, string * Uuidm.t * (Fpath.t * Cstruct.t * int64), [ `One | `Zero | `Many ]) Caqti_request.t = let build_artifacts : (unit, string * Uuidm.t * Fpath.t * Cstruct.t * int64, [ `One | `Zero | `Many ]) Caqti_request.t =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup3 string Builder_db.Rep.uuid Caqti_type.(t5 string Builder_db.Rep.uuid Builder_db.Rep.fpath
(tup3 Builder_db.Rep.fpath Builder_db.Rep.cstruct int64)) Builder_db.Rep.cstruct int64)
@@ @@
{| SELECT job.name, b.uuid, a.filepath, a.sha256, a.size {| SELECT job.name, b.uuid, a.filepath, a.sha256, a.size
FROM build_artifact a, build b, job FROM build_artifact a, build b, job
@ -347,7 +347,7 @@ let build_artifacts : (unit, string * Uuidm.t * (Fpath.t * Cstruct.t * int64), [
let script_and_console : (unit, _, [`One | `Zero | `Many ]) Caqti_request.t = let script_and_console : (unit, _, [`One | `Zero | `Many ]) Caqti_request.t =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup4 string Builder_db.Rep.uuid Builder_db.Rep.fpath Builder_db.Rep.fpath) Caqti_type.(t4 string Builder_db.Rep.uuid Builder_db.Rep.fpath Builder_db.Rep.fpath)
@@ @@
{| SELECT job.name, b.uuid, b.console, b.script {| SELECT job.name, b.uuid, b.console, b.script
FROM build b, job FROM build b, job
@ -387,7 +387,7 @@ let verify_data_dir () datadir =
| _ -> Logs.err (fun m -> m "path is not of form <job>/<uuid>/...: %a" Fpath.pp path) | _ -> Logs.err (fun m -> m "path is not of form <job>/<uuid>/...: %a" Fpath.pp path)
in in
let* () = let* () =
Db.iter_s build_artifacts (fun (_job, _uuid, (_fpath, sha256, size)) -> Db.iter_s build_artifacts (fun (_job, _uuid, _fpath, sha256, size) ->
progress (); progress ();
if not (FpathSet.mem (artifact_path sha256) !files_tracked) then if not (FpathSet.mem (artifact_path sha256) !files_tracked) then
let abs_path = Fpath.(v datadir // artifact_path sha256) in let abs_path = Fpath.(v datadir // artifact_path sha256) in
@ -557,7 +557,7 @@ module Verify_cache_dir = struct
in in
Caqti_type.custom ~encode ~decode Caqti_type.custom ~encode ~decode
Caqti_type.( Caqti_type.(
tup4 t4
Builder_db.Rep.uuid Builder_db.Rep.uuid
string string
(option Builder_db.Rep.cstruct) (option Builder_db.Rep.cstruct)

4
bin/migrations/m20210126.ml
View file

@ -18,11 +18,11 @@ let all_builds =
"SELECT id FROM build" "SELECT id FROM build"
let bin_artifact = let bin_artifact =
Caqti_type.int64 ->* Caqti_type.(tup2 int64 string) @@ Caqti_type.int64 ->* Caqti_type.(t2 int64 string) @@
"SELECT id, filepath FROM build_artifact WHERE build = ? AND filepath LIKE 'bin/%'" "SELECT id, filepath FROM build_artifact WHERE build = ? AND filepath LIKE 'bin/%'"
let set_main_binary = let set_main_binary =
Caqti_type.(tup2 int64 (option string)) ->. Caqti_type.unit @@ Caqti_type.(t2 int64 (option string)) ->. Caqti_type.unit @@
"UPDATE build SET main_binary = $2 WHERE id = $1" "UPDATE build SET main_binary = $2 WHERE id = $1"
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =

8
bin/migrations/m20210218.ml
View file

@ -37,21 +37,21 @@ let new_build_file =
|} |}
let collect_build_artifact = let collect_build_artifact =
Caqti_type.unit ->* Caqti_type.(tup3 int64 (tup3 string string octets) int64) @@ Caqti_type.unit ->* Caqti_type.(t3 int64 (t3 string string octets) int64) @@
"SELECT id, filepath, localpath, sha256, build FROM build_artifact" "SELECT id, filepath, localpath, sha256, build FROM build_artifact"
let collect_build_file = let collect_build_file =
Caqti_type.unit ->* Caqti_type.(tup3 int64 (tup3 string string octets) int64) @@ Caqti_type.unit ->* Caqti_type.(t3 int64 (t3 string string octets) int64) @@
"SELECT id, filepath, localpath, sha256, build FROM build_file" "SELECT id, filepath, localpath, sha256, build FROM build_file"
let insert_new_build_artifact = let insert_new_build_artifact =
Caqti_type.(tup3 int64 (tup4 string string octets int64) int64) ->. Caqti_type.unit @@ Caqti_type.(t3 int64 (t4 string string octets int64) int64) ->. Caqti_type.unit @@
{| INSERT INTO new_build_artifact (id, filepath, localpath, sha256, size, build) {| INSERT INTO new_build_artifact (id, filepath, localpath, sha256, size, build)
VALUES (?, ?, ?, ?, ?, ?) VALUES (?, ?, ?, ?, ?, ?)
|} |}
let insert_new_build_file = let insert_new_build_file =
Caqti_type.(tup3 int64 (tup4 string string octets int64) int64) ->. Caqti_type.unit @@ Caqti_type.(t3 int64 (t4 string string octets int64) int64) ->. Caqti_type.unit @@
{| INSERT INTO new_build_file (id, filepath, localpath, sha256, size, build) {| INSERT INTO new_build_file (id, filepath, localpath, sha256, size, build)
VALUES (?, ?, ?, ?, ?, ?) VALUES (?, ?, ?, ?, ?, ?)
|} |}

2
bin/migrations/m20210308.ml
View file

@ -3,7 +3,7 @@ module Rep = Builder_db.Rep
open Grej.Infix open Grej.Infix
let broken_builds = let broken_builds =
Caqti_type.unit ->* Caqti_type.tup3 (Rep.id `build) Rep.uuid Caqti_type.string @@ Caqti_type.unit ->* Caqti_type.t3 (Rep.id `build) Rep.uuid Caqti_type.string @@
{| SELECT b.id, b.uuid, job.name FROM build b, job {| 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 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 (SELECT COUNT( * ) FROM build_artifact a

4
bin/migrations/m20210531.ml
View file

@ -7,11 +7,11 @@ let rollback_doc = "add datadir prefix to build_artifact.localpath"
open Grej.Infix open Grej.Infix
let build_artifacts = let build_artifacts =
Caqti_type.unit ->* Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath @@ Caqti_type.unit ->* Caqti_type.t2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath @@
"SELECT id, localpath FROM build_artifact" "SELECT id, localpath FROM build_artifact"
let build_artifact_update_localpath = let build_artifact_update_localpath =
Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath ->. Caqti_type.unit @@ Caqti_type.t2 Builder_db.Rep.untyped_id Builder_db.Rep.fpath ->. Caqti_type.unit @@
"UPDATE build_artifact SET localpath = $2 WHERE id = $1" "UPDATE build_artifact SET localpath = $2 WHERE id = $1"
(* We are not migrating build_file because it is unused *) (* We are not migrating build_file because it is unused *)

34
bin/migrations/m20210602.ml
View file

@ -54,20 +54,20 @@ let old_build =
let collect_old_build = let collect_old_build =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup3 Builder_db.Rep.untyped_id Caqti_type.(t3 Builder_db.Rep.untyped_id
(tup3 (tup4 string int64 int64 int64) (t3 (t4 string int64 int64 int64)
(tup4 int64 int (option int) (option string)) (t4 int64 int (option int) (option string))
(tup3 octets string (option string))) (t3 octets string (option string)))
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, {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg,
console, script, main_binary, job console, script, main_binary, job
FROM build |} FROM build |}
let insert_new_build = let insert_new_build =
Caqti_type.(tup3 Builder_db.Rep.untyped_id Caqti_type.(t3 Builder_db.Rep.untyped_id
(tup3 (tup4 string int64 int64 int64) (t3 (t4 string int64 int64 int64)
(tup4 int64 int (option int) (option string)) (t4 int64 int (option int) (option string))
(tup3 octets string (option Builder_db.Rep.untyped_id))) (t3 octets string (option Builder_db.Rep.untyped_id)))
Builder_db.Rep.untyped_id) ->. Caqti_type.unit @@ Builder_db.Rep.untyped_id) ->. Caqti_type.unit @@
{| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, {| 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) result_code, result_msg, console, script, main_binary, job)
@ -82,7 +82,7 @@ let rename_build =
"ALTER TABLE new_build RENAME TO build" "ALTER TABLE new_build RENAME TO build"
let find_main_artifact_id = let find_main_artifact_id =
Caqti_type.(tup2 Builder_db.Rep.untyped_id string) ->! Builder_db.Rep.untyped_id @@ Caqti_type.(t2 Builder_db.Rep.untyped_id string) ->! Builder_db.Rep.untyped_id @@
"SELECT id FROM build_artifact WHERE build = $1 AND filepath = $2" "SELECT id FROM build_artifact WHERE build = $1 AND filepath = $2"
let find_main_artifact_filepath = let find_main_artifact_filepath =
@ -91,20 +91,20 @@ let find_main_artifact_filepath =
let collect_new_build = let collect_new_build =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup3 Builder_db.Rep.untyped_id Caqti_type.(t3 Builder_db.Rep.untyped_id
(tup3 (tup4 string int64 int64 int64) (t3 (t4 string int64 int64 int64)
(tup4 int64 int (option int) (option string)) (t4 int64 int (option int) (option string))
(tup3 octets string (option Builder_db.Rep.untyped_id))) (t3 octets string (option Builder_db.Rep.untyped_id)))
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, {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg,
console, script, main_binary, job console, script, main_binary, job
FROM build |} FROM build |}
let insert_old_build = let insert_old_build =
Caqti_type.(tup3 Builder_db.Rep.untyped_id Caqti_type.(t3 Builder_db.Rep.untyped_id
(tup3 (tup4 string int64 int64 int64) (t3 (t4 string int64 int64 int64)
(tup4 int64 int (option int) (option string)) (t4 int64 int (option int) (option string))
(tup3 octets string (option string))) (t3 octets string (option string)))
Builder_db.Rep.untyped_id) ->. Caqti_type.unit @@ Builder_db.Rep.untyped_id) ->. Caqti_type.unit @@
{| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, {| 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) result_code, result_msg, console, script, main_binary, job)

8
bin/migrations/m20210608.ml
View file

@ -34,21 +34,21 @@ let old_user =
let collect_old_user = let collect_old_user =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64)) @@ Caqti_type.(t4 int64 string (t2 octets octets) (t3 int64 int64 int64)) @@
"SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p FROM user" "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p FROM user"
let collect_new_user = let collect_new_user =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool)) @@ Caqti_type.(t4 int64 string (t2 octets octets) (t4 int64 int64 int64 bool)) @@
"SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted FROM user" "SELECT id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted FROM user"
let insert_new_user = let insert_new_user =
Caqti_type.(tup4 int64 string (tup2 octets octets) (tup4 int64 int64 int64 bool)) ->. Caqti_type.(t4 int64 string (t2 octets octets) (t4 int64 int64 int64 bool)) ->.
Caqti_type.unit @@ Caqti_type.unit @@
"INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) VALUES (?, ?, ?, ?, ?, ?, ?, ?)" "INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
let insert_old_user = let insert_old_user =
Caqti_type.(tup4 int64 string (tup2 octets octets) (tup3 int64 int64 int64)) ->. Caqti_type.(t4 int64 string (t2 octets octets) (t3 int64 int64 int64)) ->.
Caqti_type.unit @@ Caqti_type.unit @@
"INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p) VALUES (?, ?, ?, ?, ?, ?, ?)" "INSERT INTO new_user (id, username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p) VALUES (?, ?, ?, ?, ?, ?, ?)"

4
bin/migrations/m20210629.ml
View file

@ -42,7 +42,7 @@ let latest_successful_build =
let build_artifacts = let build_artifacts =
Builder_db.Rep.untyped_id ->* Builder_db.Rep.untyped_id ->*
Caqti_type.tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@ Caqti_type.t2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@
{| SELECT a.filepath, a.localpath {| SELECT a.filepath, a.localpath
FROM build_artifact a FROM build_artifact a
WHERE a.build = ? WHERE a.build = ?
@ -106,7 +106,7 @@ let insert_tag =
"INSERT INTO tag (tag) VALUES (?)" "INSERT INTO tag (tag) VALUES (?)"
let insert_job_tag = let insert_job_tag =
Caqti_type.(tup3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id) ->. Caqti_type.(t3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id) ->.
Caqti_type.unit @@ Caqti_type.unit @@
"INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)" "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"

4
bin/migrations/m20210630.ml
View file

@ -20,7 +20,7 @@ let latest_successful_build =
let build_artifacts = let build_artifacts =
Builder_db.Rep.untyped_id ->* Builder_db.Rep.untyped_id ->*
Caqti_type.tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@ Caqti_type.t2 Builder_db.Rep.fpath Builder_db.Rep.fpath @@
{| SELECT a.filepath, a.localpath {| SELECT a.filepath, a.localpath
FROM build_artifact a FROM build_artifact a
WHERE a.build = ? WHERE a.build = ?
@ -31,7 +31,7 @@ let insert_tag =
"INSERT INTO tag (tag) VALUES (?)" "INSERT INTO tag (tag) VALUES (?)"
let insert_job_tag = let insert_job_tag =
Caqti_type.(tup3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id) ->. Caqti_type.(t3 Builder_db.Rep.untyped_id string Builder_db.Rep.untyped_id) ->.
Caqti_type.unit @@ Caqti_type.unit @@
"INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)" "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"

4
bin/migrations/m20210706.ml
View file

@ -55,7 +55,7 @@ let drop_input_id_from_build =
let builds = let builds =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup4 Caqti_type.t4
Builder_db.Rep.untyped_id Builder_db.Rep.untyped_id
Builder_db.Rep.cstruct Builder_db.Rep.cstruct
Builder_db.Rep.cstruct Builder_db.Rep.cstruct
@ -68,7 +68,7 @@ let builds =
|} |}
let set_input_id = let set_input_id =
Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.cstruct ->. Caqti_type.unit @@ Caqti_type.t2 Builder_db.Rep.untyped_id Builder_db.Rep.cstruct ->. Caqti_type.unit @@
"UPDATE build SET input_id = $2 WHERE id = $1" "UPDATE build SET input_id = $2 WHERE id = $1"
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) = let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =

2
bin/migrations/m20210707a.ml
View file

@ -2,7 +2,7 @@ open Grej.Infix
let orb_left_in_builds = let orb_left_in_builds =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@ Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
{| SELECT id, localpath FROM build_artifact {| SELECT id, localpath FROM build_artifact
WHERE filepath = 'orb.deb' OR filepath = 'orb.txz' WHERE filepath = 'orb.deb' OR filepath = 'orb.txz'
|} |}

4
bin/migrations/m20210707b.ml
View file

@ -2,7 +2,7 @@ open Grej.Infix
let deb_debug_left_in_builds = let deb_debug_left_in_builds =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup4 (Builder_db.Rep.id `build_artifact) (Builder_db.Rep.id `build) Caqti_type.t4 (Builder_db.Rep.id `build_artifact) (Builder_db.Rep.id `build)
Builder_db.Rep.fpath Builder_db.Rep.fpath @@ Builder_db.Rep.fpath Builder_db.Rep.fpath @@
{| SELECT id, build, localpath, filepath FROM build_artifact {| SELECT id, build, localpath, filepath FROM build_artifact
WHERE filepath LIKE '%.deb.debug' WHERE filepath LIKE '%.deb.debug'
@ -17,7 +17,7 @@ let get_localpath =
"SELECT localpath FROM build_artifact WHERE id = ?" "SELECT localpath FROM build_artifact WHERE id = ?"
let update_paths = let update_paths =
Caqti_type.tup3 (Builder_db.Rep.id `build_artifact) Caqti_type.t3 (Builder_db.Rep.id `build_artifact)
Builder_db.Rep.fpath Builder_db.Rep.fpath ->. Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
Caqti_type.unit @@ Caqti_type.unit @@
"UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1" "UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1"

8
bin/migrations/m20210707c.ml
View file

@ -2,7 +2,7 @@ open Grej.Infix
let all_builds_with_binary : (unit, [`build] Builder_db.Rep.id * [`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t = let all_builds_with_binary : (unit, [`build] Builder_db.Rep.id * [`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact) Caqti_type.t4 (Builder_db.Rep.id `build) (Builder_db.Rep.id `build_artifact)
Builder_db.Rep.fpath Builder_db.Rep.fpath @@ Builder_db.Rep.fpath Builder_db.Rep.fpath @@
"SELECT b.id, b.main_binary, a.filepath, a.localpath FROM build b, build_artifact a WHERE b.main_binary = a.id AND b.main_binary IS NOT NULL" "SELECT b.id, b.main_binary, a.filepath, a.localpath FROM build b, build_artifact a WHERE b.main_binary = a.id AND b.main_binary IS NOT NULL"
@ -11,14 +11,14 @@ let build_not_stripped : ([`build] Builder_db.Rep.id, [`build_artifact] Builder_
"SELECT id FROM build_artifact WHERE build = ? AND filepath LIKE '%.debug'" "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 ]) Caqti_request.t = 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) Caqti_type.t3 (Builder_db.Rep.id `build_artifact)
Builder_db.Rep.fpath Builder_db.Rep.fpath ->. Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
Caqti_type.unit @@ Caqti_type.unit @@
"UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1" "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]) Caqti_request.t = 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) Caqti_type.(t2 (t3 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct)
(tup2 Caqti_type.int64 (Builder_db.Rep.id `build))) ->. (t2 Caqti_type.int64 (Builder_db.Rep.id `build))) ->.
Caqti_type.unit @@ Caqti_type.unit @@
"INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?)" "INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?)"

4
bin/migrations/m20210707d.ml
View file

@ -2,11 +2,11 @@ open Grej.Infix
let all_build_artifacts_with_dot_slash : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t = let all_build_artifacts_with_dot_slash : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@ Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
"SELECT id, filepath FROM build_artifact WHERE filepath LIKE './%'" "SELECT id, filepath FROM build_artifact WHERE filepath LIKE './%'"
let update_path : ([`build_artifact] Builder_db.Rep.id * Fpath.t, unit, [< `Zero | `One | `Many > `Zero ]) Caqti_request.t = let update_path : ([`build_artifact] Builder_db.Rep.id * Fpath.t, unit, [< `Zero | `One | `Many > `Zero ]) Caqti_request.t =
Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath ->. Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath ->.
Caqti_type.unit @@ Caqti_type.unit @@
"UPDATE build_artifact SET filepath = $2 WHERE id = $1" "UPDATE build_artifact SET filepath = $2 WHERE id = $1"

8
bin/migrations/m20210712a.ml
View file

@ -40,11 +40,11 @@ let copy_old_build =
let old_build_execution_result = let old_build_execution_result =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) @@ Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) @@
"SELECT id, result_kind, result_code FROM build" "SELECT id, result_kind, result_code FROM build"
let update_new_build_execution_result = let update_new_build_execution_result =
Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int) ->. Caqti_type.unit @@ Caqti_type.(t2 (Builder_db.Rep.id (`build : [ `build ])) int) ->. Caqti_type.unit @@
"UPDATE new_build SET result_code = $2 WHERE id = $1" "UPDATE new_build SET result_code = $2 WHERE id = $1"
let old_build = let old_build =
@ -83,11 +83,11 @@ let copy_new_build =
let new_build_execution_result = let new_build_execution_result =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int) @@ Caqti_type.(t2 (Builder_db.Rep.id (`build : [ `build ])) int) @@
"SELECT id, result_code FROM build" "SELECT id, result_code FROM build"
let update_old_build_execution_result = let update_old_build_execution_result =
Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) ->. Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ])) int (option int)) ->.
Caqti_type.unit @@ Caqti_type.unit @@
"UPDATE new_build SET result_kind = $2, result_code = $3 WHERE id = $1" "UPDATE new_build SET result_kind = $2, result_code = $3 WHERE id = $1"

4
bin/migrations/m20210712b.ml
View file

@ -2,12 +2,12 @@ open Grej.Infix
let all_build_artifacts_like_hashes : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t = let all_build_artifacts_like_hashes : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@ Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
"SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%.build-hashes'" "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%.build-hashes'"
let all_build_artifacts_like_readme : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t = let all_build_artifacts_like_readme : (unit, [`build_artifact] Builder_db.Rep.id * Fpath.t, [ `Zero | `One | `Many ]) Caqti_request.t =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@ Caqti_type.t2 (Builder_db.Rep.id `build_artifact) Builder_db.Rep.fpath @@
"SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%README.md'" "SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%README.md'"
let fixup datadir (module Db : Caqti_blocking.CONNECTION) = let fixup datadir (module Db : Caqti_blocking.CONNECTION) =

10
bin/migrations/m20210712c.ml
View file

@ -95,24 +95,24 @@ let copy_from_new_build =
let old_build_console_script = let old_build_console_script =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup4 (Builder_db.Rep.id (`build : [ `build ])) Caqti_type.(t4 (Builder_db.Rep.id (`build : [ `build ]))
(tup2 string Builder_db.Rep.uuid) Builder_db.Rep.cstruct string) @@ (t2 string Builder_db.Rep.uuid) Builder_db.Rep.cstruct string) @@
"SELECT b.id, job.name, b.uuid, b.console, b.script FROM build b, job WHERE b.job = job.id" "SELECT b.id, job.name, b.uuid, b.console, b.script FROM build b, job WHERE b.job = job.id"
let update_new_build_console_script = let update_new_build_console_script =
Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ]))
Builder_db.Rep.fpath Builder_db.Rep.fpath) ->. Builder_db.Rep.fpath Builder_db.Rep.fpath) ->.
Caqti_type.unit @@ Caqti_type.unit @@
"UPDATE new_build SET console = $2, script = $3 WHERE id = $1" "UPDATE new_build SET console = $2, script = $3 WHERE id = $1"
let new_build_console_script = let new_build_console_script =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup3 (Builder_db.Rep.id (`build : [ `build ])) Caqti_type.t3 (Builder_db.Rep.id (`build : [ `build ]))
Builder_db.Rep.fpath Builder_db.Rep.fpath @@ Builder_db.Rep.fpath Builder_db.Rep.fpath @@
"SELECT id, console, script FROM build" "SELECT id, console, script FROM build"
let update_old_build_console_script = let update_old_build_console_script =
Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.cstruct string) ->. Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.cstruct string) ->.
Caqti_type.unit @@ Caqti_type.unit @@
"UPDATE new_build SET console = $2, script = $3 WHERE id = $1" "UPDATE new_build SET console = $2, script = $3 WHERE id = $1"

4
bin/migrations/m20210910.ml
View file

@ -2,13 +2,13 @@ open Grej.Infix
let mixups = let mixups =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) Caqti_type.t3 (Builder_db.Rep.id (`build : [`build]))
Builder_db.Rep.fpath Builder_db.Rep.fpath @@ Builder_db.Rep.fpath Builder_db.Rep.fpath @@
"SELECT id, console, script FROM build \ "SELECT id, console, script FROM build \
WHERE console LIKE '%/script.txt' AND script LIKE '%/console.txt'" WHERE console LIKE '%/script.txt' AND script LIKE '%/console.txt'"
let fixup = let fixup =
Caqti_type.tup3 (Builder_db.Rep.id (`build : [`build])) Caqti_type.t3 (Builder_db.Rep.id (`build : [`build]))
Builder_db.Rep.fpath Builder_db.Rep.fpath ->. Builder_db.Rep.fpath Builder_db.Rep.fpath ->.
Caqti_type.unit @@ Caqti_type.unit @@
"UPDATE build SET console = $2, script = $3 WHERE id = $1" "UPDATE build SET console = $2, script = $3 WHERE id = $1"

4
bin/migrations/m20211105.ml
View file

@ -73,11 +73,11 @@ let copy_from_new_build =
|} |}
let build_id_and_user = let build_id_and_user =
Caqti_type.unit ->* Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int64) @@ Caqti_type.unit ->* Caqti_type.(t2 (Builder_db.Rep.id (`build : [ `build ])) int64) @@
"SELECT id, user FROM build" "SELECT id, user FROM build"
let update_new_build_platform = let update_new_build_platform =
Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) string) ->. Caqti_type.unit @@ Caqti_type.(t2 (Builder_db.Rep.id (`build : [ `build ])) string) ->. Caqti_type.unit @@
"UPDATE new_build SET platform = $2 WHERE id = $1" "UPDATE new_build SET platform = $2 WHERE id = $1"
let drop_build = let drop_build =

8
bin/migrations/m20220509.ml
View file

@ -23,21 +23,21 @@ let new_uuid_rep =
let uuids_byte_encoded_q = let uuids_byte_encoded_q =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup2 (Builder_db.Rep.id (`build : [`build])) old_uuid_rep @@ Caqti_type.t2 (Builder_db.Rep.id (`build : [`build])) old_uuid_rep @@
"SELECT id, uuid FROM build" "SELECT id, uuid FROM build"
let uuids_hex_encoded_q = let uuids_hex_encoded_q =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.tup2 (Builder_db.Rep.id (`build : [`build])) new_uuid_rep @@ Caqti_type.t2 (Builder_db.Rep.id (`build : [`build])) new_uuid_rep @@
"SELECT id, uuid FROM build" "SELECT id, uuid FROM build"
let migrate_q = let migrate_q =
Caqti_type.tup2 (Builder_db.Rep.id (`build : [`build])) new_uuid_rep ->. Caqti_type.t2 (Builder_db.Rep.id (`build : [`build])) new_uuid_rep ->.
Caqti_type.unit @@ Caqti_type.unit @@
"UPDATE build SET uuid = $2 WHERE id = $1" "UPDATE build SET uuid = $2 WHERE id = $1"
let rollback_q = let rollback_q =
Caqti_type.tup2 (Builder_db.Rep.id (`build : [`build])) old_uuid_rep ->. Caqti_type.t2 (Builder_db.Rep.id (`build : [`build])) old_uuid_rep ->.
Caqti_type.unit @@ Caqti_type.unit @@
"UPDATE build SET uuid = $2 WHERE id = $1" "UPDATE build SET uuid = $2 WHERE id = $1"

4
bin/migrations/m20230914.ml
View file

@ -60,13 +60,13 @@ let copy_old_build_artifact =
|} |}
let new_build_artifact_paths = let new_build_artifact_paths =
Caqti_type.unit ->* Caqti_type.(tup2 string string) @@ Caqti_type.unit ->* Caqti_type.(t2 string string) @@
{| SELECT localpath, '_artifacts/' || substr(lower(hex(sha256)), 1, 2) || '/' || lower(hex(sha256)) {| SELECT localpath, '_artifacts/' || substr(lower(hex(sha256)), 1, 2) || '/' || lower(hex(sha256))
FROM build_artifact FROM build_artifact
|} |}
let old_build_artifact_paths = let old_build_artifact_paths =
Caqti_type.unit ->* Caqti_type.(tup2 string string) @@ Caqti_type.unit ->* Caqti_type.(t2 string string) @@
{| SELECT '_artifacts/' || substr(lower(hex(a.sha256)), 1, 2) || '/' || lower(hex(a.sha256)), {| SELECT '_artifacts/' || substr(lower(hex(a.sha256)), 1, 2) || '/' || lower(hex(a.sha256)),
j.name || '/' || b.uuid || '/output/' || a.filepath j.name || '/' || b.uuid || '/output/' || a.filepath
FROM build_artifact a, job j, build b FROM build_artifact a, job j, build b

4
builder-web.opam
View file

@ -23,7 +23,7 @@ depends: [
"bos" "bos"
"hex" "hex"
"lwt" {>= "5.7.0"} "lwt" {>= "5.7.0"}
"caqti" {>= "1.8.0"} "caqti" {>= "2.1.1"}
"caqti-lwt" "caqti-lwt"
"caqti-driver-sqlite3" "caqti-driver-sqlite3"
"pbkdf" "pbkdf"
@ -46,7 +46,7 @@ depends: [
"uri" "uri"
"fmt" {>= "0.8.7"} "fmt" {>= "0.8.7"}
"cmarkit" {>= "0.3.0"} "cmarkit" {>= "0.3.0"}
"tar" "tar" {< "3.0.0"}
"owee" "owee"
"solo5-elftool" {>= "0.3.0"} "solo5-elftool" {>= "0.3.0"}
"decompress" {>= "1.5.0"} "decompress" {>= "1.5.0"}

76
db/builder_db.ml
View file

@ -57,7 +57,7 @@ module Job = struct
let get_all_with_section_synopsis = let get_all_with_section_synopsis =
Caqti_type.unit ->* Caqti_type.unit ->*
Caqti_type.(tup4 (id `job) string (option string) (option string)) @@ Caqti_type.(t4 (id `job) string (option string) (option string)) @@
{| SELECT j.id, j.name, section.value, synopsis.value {| SELECT j.id, j.name, section.value, synopsis.value
FROM job j, tag section_tag, tag synopsis_tag 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 section ON section.job = j.id AND section.tag = section_tag.id
@ -117,15 +117,15 @@ module Job_tag = struct
"DROP TABLE IF EXISTS job_tag" "DROP TABLE IF EXISTS job_tag"
let add = let add =
Caqti_type.(tup3 (id `tag) string (id `job)) ->. Caqti_type.unit @@ Caqti_type.(t3 (id `tag) string (id `job)) ->. Caqti_type.unit @@
"INSERT INTO job_tag (tag, value, job) VALUES ($1, $2, $3)" "INSERT INTO job_tag (tag, value, job) VALUES ($1, $2, $3)"
let update = let update =
Caqti_type.(tup3 (id `tag) string (id `job)) ->. Caqti_type.unit @@ Caqti_type.(t3 (id `tag) string (id `job)) ->. Caqti_type.unit @@
"UPDATE job_tag SET value = $2 WHERE tag = $1 AND job = $3" "UPDATE job_tag SET value = $2 WHERE tag = $1 AND job = $3"
let get_value = let get_value =
Caqti_type.(tup2 (id `tag) (id `job)) ->? Caqti_type.string @@ Caqti_type.(t2 (id `tag) (id `job)) ->? Caqti_type.string @@
"SELECT value FROM job_tag WHERE tag = ? AND job = ?" "SELECT value FROM job_tag WHERE tag = ? AND job = ?"
let remove_by_job = let remove_by_job =
@ -159,7 +159,7 @@ module Build_artifact = struct
FROM build_artifact WHERE id = ? |} FROM build_artifact WHERE id = ? |}
let get_by_build_uuid = let get_by_build_uuid =
Caqti_type.tup2 uuid fpath ->? Caqti_type.tup2 (id `build_artifact) file @@ Caqti_type.t2 uuid fpath ->? Caqti_type.t2 (id `build_artifact) file @@
{| SELECT build_artifact.id, build_artifact.filepath, {| SELECT build_artifact.id, build_artifact.filepath,
build_artifact.sha256, build_artifact.size build_artifact.sha256, build_artifact.size
FROM build_artifact FROM build_artifact
@ -168,7 +168,7 @@ module Build_artifact = struct
|} |}
let get_all_by_build = let get_all_by_build =
id `build ->* Caqti_type.(tup2 (id `build_artifact) file) @@ id `build ->* Caqti_type.(t2 (id `build_artifact) file) @@
"SELECT id, filepath, sha256, size FROM build_artifact WHERE build = ?" "SELECT id, filepath, sha256, size FROM build_artifact WHERE build = ?"
let exists = let exists =
@ -176,7 +176,7 @@ module Build_artifact = struct
"SELECT EXISTS(SELECT 1 FROM build_artifact WHERE sha256 = ?)" "SELECT EXISTS(SELECT 1 FROM build_artifact WHERE sha256 = ?)"
let add = let add =
Caqti_type.(tup2 file (id `build)) ->. Caqti_type.unit @@ Caqti_type.(t2 file (id `build)) ->. Caqti_type.unit @@
"INSERT INTO build_artifact (filepath, sha256, size, build) \ "INSERT INTO build_artifact (filepath, sha256, size, build) \
VALUES (?, ?, ?, ?)" VALUES (?, ?, ?, ?)"
@ -231,27 +231,23 @@ module Build = struct
let t = let t =
let rep = let rep =
Caqti_type.(tup3 Caqti_type.(t11
(tup4 uuid
uuid Rep.ptime
(tup2 Rep.ptime
Rep.ptime execution_result
Rep.ptime) fpath
(tup2 fpath
execution_result string
fpath) (option (Rep.id `build_artifact))
(tup4 (option Rep.cstruct)
fpath
string
(option (Rep.id `build_artifact))
(option Rep.cstruct)))
(id `user) (id `user)
(id `job)) (id `job))
in in
let encode { uuid; start; finish; result; console; script; platform; main_binary; input_id; user_id; job_id } = 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) Ok (uuid, start, finish, result, console, script, platform, main_binary, input_id, user_id, job_id)
in in
let decode ((uuid, (start, finish), (result, console), (script, platform, main_binary, input_id)), user_id, job_id) = 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 } Ok { uuid; start; finish; result; console; script; platform; main_binary; input_id; user_id; job_id }
in in
Caqti_type.custom ~encode ~decode rep Caqti_type.custom ~encode ~decode rep
@ -286,7 +282,7 @@ module Build = struct
"DROP TABLE IF EXISTS build" "DROP TABLE IF EXISTS build"
let get_by_uuid = let get_by_uuid =
Rep.uuid ->? Caqti_type.tup2 (id `build) t @@ Rep.uuid ->? Caqti_type.t2 (id `build) t @@
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, result_code, result_msg,
console, script, platform, main_binary, input_id, user, job console, script, platform, main_binary, input_id, user, job
@ -295,7 +291,7 @@ module Build = struct
|} |}
let get_all = let get_all =
id `job ->* Caqti_type.tup2 (id `build) t @@ id `job ->* Caqti_type.t2 (id `build) t @@
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, console, result_code, result_msg, console,
script, platform, main_binary, input_id, user, job script, platform, main_binary, input_id, user, job
@ -305,7 +301,7 @@ module Build = struct
|} |}
let get_all_failed = let get_all_failed =
Caqti_type.(tup3 int int (option string)) ->* Caqti_type.tup2 Caqti_type.string t @@ 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, {| 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.result_code, b.result_msg, b.console, b.script, b.platform,
b.main_binary, b.input_id, b.user, b.job b.main_binary, b.input_id, b.user, b.job
@ -318,7 +314,7 @@ module Build = struct
|} |}
let get_all_artifact_sha = let get_all_artifact_sha =
Caqti_type.(tup2 (id `job) (option string)) ->* Rep.cstruct @@ Caqti_type.(t2 (id `job) (option string)) ->* Rep.cstruct @@
{| SELECT DISTINCT a.sha256 {| SELECT DISTINCT a.sha256
FROM build_artifact a, build b FROM build_artifact a, build b
WHERE b.job = $1 AND b.main_binary = a.id WHERE b.job = $1 AND b.main_binary = a.id
@ -327,7 +323,7 @@ module Build = struct
|} |}
let get_failed_builds = let get_failed_builds =
Caqti_type.(tup2 (id `job) (option string)) ->* t @@ Caqti_type.(t2 (id `job) (option string)) ->* t @@
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps, {| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, console, script, result_code, result_msg, console, script,
platform, main_binary, input_id, user, job platform, main_binary, input_id, user, job
@ -339,7 +335,7 @@ module Build = struct
|} |}
let get_latest_successful_with_binary = let get_latest_successful_with_binary =
Caqti_type.(tup2 (id `job) string) ->? Caqti_type.tup3 (id `build) t file @@ Caqti_type.(t2 (id `job) string) ->? Caqti_type.t3 (id `build) t file @@
{| SELECT b.id, {| SELECT b.id,
b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, 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.result_code, b.result_msg, b.console, b.script,
@ -353,7 +349,7 @@ module Build = struct
|} |}
let get_builds_older_than = let get_builds_older_than =
Caqti_type.(tup3 (id `job) (option string) Rep.ptime) ->* Caqti_type.tup2 (id `build) t @@ 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, {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, console, script, result_code, result_msg, console, script,
platform, main_binary, input_id, user, job platform, main_binary, input_id, user, job
@ -365,7 +361,7 @@ module Build = struct
|} |}
let get_builds_excluding_latest_n = let get_builds_excluding_latest_n =
Caqti_type.(tup3 (id `job) (option string) int) ->* Caqti_type.tup2 (id `build) t @@ 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, {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, console, script, result_code, result_msg, console, script,
platform, main_binary, input_id, user, job platform, main_binary, input_id, user, job
@ -378,7 +374,7 @@ module Build = struct
(* "LIMIT -1 OFFSET n" is all rows except the first n *) (* "LIMIT -1 OFFSET n" is all rows except the first n *)
let get_nth_latest_successful = let get_nth_latest_successful =
Caqti_type.(tup3 (id `job) (option string) int) ->? Caqti_type.tup2 (id `build) t @@ 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, {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, console, script, result_code, result_msg, console, script,
platform, main_binary, input_id, user, job platform, main_binary, input_id, user, job
@ -391,7 +387,7 @@ module Build = struct
|} |}
let get_latest_successful = let get_latest_successful =
Caqti_type.(tup2 (id `job) (option string)) ->? t @@ Caqti_type.(t2 (id `job) (option string)) ->? t @@
{| SELECT {| SELECT
b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, 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.result_code, b.result_msg, b.console, b.script,
@ -504,7 +500,7 @@ module Build = struct
|} |}
let get_with_main_binary_by_hash = let get_with_main_binary_by_hash =
Rep.cstruct ->! Caqti_type.tup2 t file_opt @@ Rep.cstruct ->! Caqti_type.t2 t file_opt @@
{| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, {| 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.result_code, b.result_msg, b.console, b.script,
b.platform, b.main_binary, b.input_id, b.user, b.job, b.platform, b.main_binary, b.input_id, b.user, b.job,
@ -517,7 +513,7 @@ module Build = struct
|} |}
let get_with_jobname_by_hash = let get_with_jobname_by_hash =
Rep.cstruct ->? Caqti_type.tup2 Caqti_type.string t @@ Rep.cstruct ->? Caqti_type.t2 Caqti_type.string t @@
{| SELECT job.name, {| SELECT job.name,
b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
b.result_code, b.result_msg, b.result_code, b.result_msg,
@ -531,7 +527,7 @@ module Build = struct
|} |}
let set_main_binary = let set_main_binary =
Caqti_type.tup2 (id `build) (id `build_artifact) ->. Caqti_type.unit @@ Caqti_type.t2 (id `build) (id `build_artifact) ->. Caqti_type.unit @@
"UPDATE build SET main_binary = $2 WHERE id = $1" "UPDATE build SET main_binary = $2 WHERE id = $1"
let remove = let remove =
@ -559,7 +555,7 @@ module User = struct
"DROP TABLE IF EXISTS user" "DROP TABLE IF EXISTS user"
let get_user = let get_user =
Caqti_type.string ->? Caqti_type.tup2 (id `user) user_info @@ Caqti_type.string ->? Caqti_type.t2 (id `user) user_info @@
{| SELECT id, username, password_hash, password_salt, {| SELECT id, username, password_hash, password_salt,
scrypt_n, scrypt_r, scrypt_p, restricted scrypt_n, scrypt_r, scrypt_p, restricted
FROM user FROM user
@ -613,15 +609,15 @@ module Access_list = struct
"DROP TABLE IF EXISTS access_list" "DROP TABLE IF EXISTS access_list"
let get = let get =
Caqti_type.tup2 (id `user) (id `job) ->! id `access_list @@ Caqti_type.t2 (id `user) (id `job) ->! id `access_list @@
"SELECT id FROM access_list WHERE user = ? AND job = ?" "SELECT id FROM access_list WHERE user = ? AND job = ?"
let add = let add =
Caqti_type.tup2 (id `user) (id `job) ->. Caqti_type.unit @@ Caqti_type.t2 (id `user) (id `job) ->. Caqti_type.unit @@
"INSERT INTO access_list (user, job) VALUES (?, ?)" "INSERT INTO access_list (user, job) VALUES (?, ?)"
let remove = let remove =
Caqti_type.tup2 (id `user) (id `job) ->. Caqti_type.unit @@ Caqti_type.t2 (id `user) (id `job) ->. Caqti_type.unit @@
"DELETE FROM access_list WHERE user = ? AND job = ?" "DELETE FROM access_list WHERE user = ? AND job = ?"
let remove_by_job = let remove_by_job =

14
db/representation.ml
View file

@ -47,7 +47,7 @@ let ptime =
let encode t = Ok (Ptime.Span.to_d_ps (Ptime.to_span t)) in let encode t = Ok (Ptime.Span.to_d_ps (Ptime.to_span t)) in
let decode (d, ps) = Ok (Ptime.v (d, ps)) let decode (d, ps) = Ok (Ptime.v (d, ps))
in in
let rep = Caqti_type.(tup2 int int64) in let rep = Caqti_type.(t2 int int64) in
Caqti_type.custom ~encode ~decode rep Caqti_type.custom ~encode ~decode rep
let fpath = let fpath =
@ -66,10 +66,10 @@ let file =
Ok (filepath, sha256, size) in Ok (filepath, sha256, size) in
let decode (filepath, sha256, size) = let decode (filepath, sha256, size) =
Ok { filepath; sha256; size } in Ok { filepath; sha256; size } in
Caqti_type.custom ~encode ~decode Caqti_type.(tup3 fpath cstruct int) Caqti_type.custom ~encode ~decode Caqti_type.(t3 fpath cstruct int)
let file_opt = let file_opt =
let rep = Caqti_type.(tup3 (option fpath) (option cstruct) (option int)) in let rep = Caqti_type.(t3 (option fpath) (option cstruct) (option int)) in
let encode = function let encode = function
| Some { filepath; sha256; size } -> | Some { filepath; sha256; size } ->
Ok (Some filepath, Some sha256, Some size) Ok (Some filepath, Some sha256, Some size)
@ -108,7 +108,7 @@ let execution_result =
else else
Error "bad encoding (unknown number)" Error "bad encoding (unknown number)"
in in
let rep = Caqti_type.(tup2 int (option string)) in let rep = Caqti_type.(t2 int (option string)) in
Caqti_type.custom ~encode ~decode rep Caqti_type.custom ~encode ~decode rep
let console = let console =
@ -117,16 +117,16 @@ let console =
Caqti_type.custom ~encode ~decode cstruct Caqti_type.custom ~encode ~decode cstruct
let user_info = let user_info =
let rep = Caqti_type.(tup4 string cstruct cstruct (tup4 int int int bool)) in let rep = Caqti_type.(t7 string cstruct cstruct int int int bool) in
let encode { Builder_web_auth.username; let encode { Builder_web_auth.username;
password_hash = `Scrypt (password_hash, password_salt, { password_hash = `Scrypt (password_hash, password_salt, {
Builder_web_auth.scrypt_n; scrypt_r; scrypt_p Builder_web_auth.scrypt_n; scrypt_r; scrypt_p
}); });
restricted; } restricted; }
= =
Ok (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p, restricted)) Ok (username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted)
in in
let decode (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p, restricted)) = let decode (username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) =
Ok { Builder_web_auth.username; Ok { Builder_web_auth.username;
password_hash = password_hash =
`Scrypt (password_hash, password_salt, `Scrypt (password_hash, password_salt,

2
lib/builder_web.ml
View file

@ -26,7 +26,7 @@ let init_datadir datadir =
let init dbpath datadir = let init dbpath datadir =
Result.bind (init_datadir datadir) @@ fun () -> Result.bind (init_datadir datadir) @@ fun () ->
Lwt_main.run ( Lwt_main.run (
Caqti_lwt.connect Caqti_lwt_unix.connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ()) (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_lwt.CONNECTION) -> >>= fun (module Db : Caqti_lwt.CONNECTION) ->
Db.find Builder_db.get_application_id () >>= fun application_id -> Db.find Builder_db.get_application_id () >>= fun application_id ->