builder-web/bin/builder_db.ml

438 lines
16 KiB
OCaml
Raw Normal View History

open Rresult.R.Infix
let or_die exit_code = function
| Ok r -> r
| Error (`Msg msg) ->
Format.eprintf "Error: %s" msg;
exit exit_code
| Error (#Caqti_error.t as e) ->
Format.eprintf "Database error: %a" 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"
let connect uri =
Caqti_blocking.connect uri >>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.exec foreign_keys () >>= fun () ->
Db.exec defer_foreign_keys () >>= fun () ->
Ok (module Db : Caqti_blocking.CONNECTION)
let do_migrate dbpath =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
List.fold_left
(fun r migrate ->
r >>= fun () ->
Logs.debug (fun m -> m "Executing migration query: %a" Caqti_request.pp migrate);
Db.exec migrate ())
(Ok ())
Builder_db.migrate
let migrate () dbpath =
or_die 1 (do_migrate dbpath)
let user_mod action dbpath scrypt_n scrypt_r scrypt_p username unrestricted =
let scrypt_params = Builder_web_auth.scrypt_params ?scrypt_n ?scrypt_r ?scrypt_p () in
let r =
connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
print_string "Password: ";
flush stdout;
(* FIXME: getpass *)
let password = read_line () in
let restricted = not unrestricted in
let user_info = Builder_web_auth.hash ~scrypt_params ~username ~password ~restricted () in
match action with
| `Add ->
Db.exec Builder_db.User.add user_info
| `Update ->
Db.exec Builder_db.User.update_user user_info
in
or_die 1 r
let user_add () dbpath = user_mod `Add dbpath
let user_update () dbpath = user_mod `Update dbpath
let user_list () dbpath =
let r =
connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.iter_s Builder_db.User.get_all
(fun username -> Ok (print_endline username))
()
in
or_die 1 r
let user_remove () dbpath username =
let r =
connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.exec Builder_db.Access_list.remove_all_by_username username >>= fun () ->
Db.exec Builder_db.User.remove_user username
in
or_die 1 r
let user_disable () dbpath username =
let r =
connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.exec Builder_db.Access_list.remove_all_by_username username >>= fun () ->
Db.find_opt Builder_db.User.get_user username >>= function
| None -> Error (`Msg "user not found")
| Some (_, user_info) ->
let password_hash = `Scrypt (Cstruct.empty, Cstruct.empty, Builder_web_auth.scrypt_params ()) in
let user_info = { user_info with password_hash ; restricted = true } in
Db.exec Builder_db.User.update_user user_info
in
or_die 1 r
let access_add () dbpath username jobname =
let r =
connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.find_opt Builder_db.User.get_user username >>=
Option.to_result ~none:(`Msg "unknown user") >>= fun (user_id, _) ->
Db.find_opt Builder_db.Job.get_id_by_name jobname >>=
Option.to_result ~none:(`Msg "job not found") >>= fun job_id ->
Db.exec Builder_db.Access_list.add (user_id, job_id)
in
or_die 1 r
let access_remove () dbpath username jobname =
let r =
connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.find_opt Builder_db.User.get_user username >>=
Option.to_result ~none:(`Msg "unknown user") >>= fun (user_id, _) ->
Db.find_opt Builder_db.Job.get_id_by_name jobname >>=
Option.to_result ~none:(`Msg "job not found") >>= fun job_id ->
Db.exec Builder_db.Access_list.remove (user_id, job_id)
in
or_die 1 r
let job_remove () datadir jobname =
let dbpath = datadir ^ "/builder.sqlite3" in
let r =
connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.find_opt Builder_db.Job.get_id_by_name jobname >>= function
| None ->
Logs.info (fun m -> m "Job %S doesn't exist or has already been removed." jobname);
Ok ()
| Some job_id ->
Db.start () >>= fun () ->
Db.exec defer_foreign_keys () >>= fun () ->
let r =
2021-08-31 11:59:45 +00:00
Db.collect_list Builder_db.Build.get_all job_id >>= fun builds ->
List.fold_left (fun r (build_id, build) ->
r >>= fun () ->
2021-08-31 11:59:45 +00:00
let dir = Fpath.(v datadir / jobname / Uuidm.to_string build.Builder_db.Build.uuid) in
(match Bos.OS.Dir.delete ~recurse:true dir with
| Ok _ -> ()
| Error `Msg e -> Logs.warn (fun m -> m "failed to remove build directory %a: %s" Fpath.pp dir e));
2021-08-31 11:59:45 +00:00
Db.exec Builder_db.Build_artifact.remove_by_build build_id >>= fun () ->
Db.exec Builder_db.Build.remove build_id)
(Ok ())
builds >>= fun () ->
Db.exec Builder_db.Job.remove job_id >>= fun () ->
Db.commit ()
in
match r with
| Ok () -> Ok ()
| Error _ as e ->
Logs.warn (fun m -> m "Error: rolling back...");
Db.rollback () >>= fun () ->
e
in
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"
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
|}
let verify_input_id () dbpath =
let r =
connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.collect_list input_ids () >>= fun input_ids ->
List.fold_left (fun acc input_id ->
acc >>= fun () ->
Db.collect_list main_artifact_hash input_id >>| fun hashes ->
match hashes with
| (h, uuid, jobname) :: tl ->
List.iter (fun (h', uuid', _) ->
if Cstruct.equal h h' then
()
else
Logs.warn (fun m -> m "job %s input id %a with two different hashes (%a, %a), build %a and %a"
jobname Cstruct.hexdump_pp input_id
Cstruct.hexdump_pp h Cstruct.hexdump_pp h'
Uuidm.pp uuid Uuidm.pp uuid'))
tl
| [] -> ())
(Ok ()) input_ids
in
or_die 1 r
let num_build_artifacts =
Caqti_request.find
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 |}
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 |}
let verify_data_dir () datadir =
let dbpath = datadir ^ "/builder.sqlite3" in
Logs.info (fun m -> m "connecting to %s" dbpath);
let r =
connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
Db.find num_build_artifacts () >>= fun num_build_artifacts ->
Logs.info (fun m -> m "total: %d artifacts" num_build_artifacts);
let progress =
let idx = ref 0 in
fun () -> incr idx; if !idx mod 100 = 0 then Logs.info (fun m -> m "%d" !idx);
in
let verify_job_and_uuid ?fpath job uuid path =
match Fpath.segs path with
| job' :: uuid' :: tl ->
if String.equal job job' then () else Logs.warn (fun m -> m "job names do not match: %s vs %s" job job');
if String.equal (Uuidm.to_string uuid) uuid' then () else Logs.warn (fun m -> m "uuid does not match: %s vs %s" (Uuidm.to_string uuid) uuid');
(match fpath, tl with
| None, _ -> ()
| Some f, "output" :: tl ->
if Fpath.equal (Fpath.v (String.concat "/" tl)) f then
()
else
Logs.err (fun m -> m "path (%a) and fpath (%a) do not match" Fpath.pp path Fpath.pp f)
| Some _, _ ->
Logs.err (fun m -> m "path is not of form <job>/<uuid>/output/<filename>: %a" Fpath.pp path))
| _ -> Logs.err (fun m -> m "path is not of form <job>/<uuid>/...: %a" Fpath.pp path)
in
Db.iter_s build_artifacts (fun (job, uuid, (fpath, lpath, sha, size)) ->
progress ();
verify_job_and_uuid ~fpath job uuid lpath;
let abs_path = Fpath.(v datadir // lpath) in
(match Bos.OS.File.read abs_path with
| Error (`Msg msg) -> Logs.err (fun m -> m "file %a not present: %s" Fpath.pp abs_path msg)
| Ok data ->
let s = Int64.of_int (String.length data) in
if s <> size then Logs.err (fun m -> m "File %a has different size (in DB %Lu on disk %Lu)" Fpath.pp abs_path size s);
let sh = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
if not (Cstruct.equal sha sh) then Logs.err (fun m -> m "File %a has different hash (in DB %a on disk %a" Fpath.pp abs_path Cstruct.hexdump_pp sha Cstruct.hexdump_pp sh)) ;
Ok ()
) () >>= fun () ->
Db.iter_s script_and_console (fun (job, uuid, console, script) ->
verify_job_and_uuid job uuid console;
verify_job_and_uuid job uuid script;
let console_file = Fpath.(v datadir // console)
and script_file = Fpath.(v datadir // script)
in
Bos.OS.File.must_exist console_file >>= fun _ ->
Bos.OS.File.must_exist script_file >>= fun _ ->
Ok ()) ()
in
or_die 1 r
let help man_format cmds = function
| None -> `Help (man_format, None)
| Some cmd ->
if List.mem cmd cmds
then `Help (man_format, Some cmd)
else `Error (true, "Unknown command: " ^ cmd)
let dbpath =
let doc = "sqlite3 database path" in
Cmdliner.Arg.(value &
opt non_dir_file "/var/db/builder-web/builder.sqlite3" &
info ~doc ["dbpath"])
let dbpath_new =
let doc = "sqlite3 database path" in
Cmdliner.Arg.(value &
opt string "/var/db/builder-web/builder.sqlite3" &
info ~doc ["dbpath"])
let datadir =
let doc = "data directory" in
Cmdliner.Arg.(value &
opt dir "/var/db/builder-web/" &
info ~doc ["datadir"])
let jobname =
let doc = "jobname" in
Cmdliner.Arg.(required &
pos 0 (some string) None &
info ~doc ~docv:"JOBNAME" [])
let username =
let doc = "username" in
Cmdliner.Arg.(required &
pos 0 (some string) None &
info ~doc ~docv:"USERNAME" [])
2021-01-21 11:01:47 +00:00
let password_iter =
let doc = "password hash count" in
Cmdliner.Arg.(value &
opt (some int) None &
info ~doc ["hash-count"])
let scrypt_n =
let doc = "scrypt n parameter" in
Cmdliner.Arg.(value &
opt (some int) None &
info ~doc ["scrypt-n"])
let scrypt_r =
let doc = "scrypt r parameter" in
Cmdliner.Arg.(value &
opt (some int) None &
info ~doc ["scrypt-r"])
let scrypt_p =
let doc = "scrypt p parameter" in
Cmdliner.Arg.(value &
opt (some int) None &
info ~doc ["scrypt-p"])
let unrestricted =
let doc = "unrestricted user" in
Cmdliner.Arg.(value & flag & info ~doc [ "unrestricted" ])
let job =
let doc = "job" in
Cmdliner.Arg.(required &
pos 1 (some string) None &
info ~doc ~docv:"JOB" [])
let setup_log =
let setup_log level =
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ());
Logs.debug (fun m -> m "Set log level %s" (Logs.level_to_string level))
in
Cmdliner.Term.(const setup_log $ Logs_cli.level ())
let migrate_cmd =
let doc = "create database and add tables" in
Cmdliner.Term.(pure migrate $ setup_log $ dbpath_new),
Cmdliner.Term.info ~doc "migrate"
let user_add_cmd =
let doc = "add a user" in
(Cmdliner.Term.(pure user_add $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username $ unrestricted),
Cmdliner.Term.info ~doc "user-add")
let user_update_cmd =
let doc = "update a user password" in
(Cmdliner.Term.(pure user_update $ setup_log $ dbpath $ scrypt_n $ scrypt_r $ scrypt_p $ username $ unrestricted),
Cmdliner.Term.info ~doc "user-update")
let user_remove_cmd =
let doc = "remove a user" in
(Cmdliner.Term.(pure user_remove $ setup_log $ dbpath $ username),
Cmdliner.Term.info ~doc "user-remove")
let user_disable_cmd =
let doc = "disable a user" in
(Cmdliner.Term.(pure user_disable $ setup_log $ dbpath $ username),
Cmdliner.Term.info ~doc "user-disable")
let user_list_cmd =
let doc = "list all users" in
(Cmdliner.Term.(pure user_list $ setup_log $ dbpath),
Cmdliner.Term.info ~doc "user-list")
let access_add_cmd =
let doc = "grant access to user and job" in
(Cmdliner.Term.(pure access_add $ setup_log $ dbpath $ username $ job),
Cmdliner.Term.info ~doc "access-add")
let access_remove_cmd =
let doc = "remove access to user and job" in
(Cmdliner.Term.(pure access_remove $ setup_log $ dbpath $ username $ job),
Cmdliner.Term.info ~doc "access-remove")
let job_remove_cmd =
let doc = "remove job and its associated builds and artifacts" in
(Cmdliner.Term.(pure job_remove $ setup_log $ datadir $ jobname),
Cmdliner.Term.info ~doc "job-remove")
let verify_input_id_cmd =
let doc = "verify that the main binary hash of all builds with the same input are equal" in
(Cmdliner.Term.(pure verify_input_id $ setup_log $ dbpath),
Cmdliner.Term.info ~doc "verify-input-id")
let verify_data_dir_cmd =
let doc = "verify that the data directory is consistent with the build_artifact table" in
(Cmdliner.Term.(pure verify_data_dir $ setup_log $ datadir),
Cmdliner.Term.info ~doc "verify-data-dir")
let help_cmd =
let topic =
let doc = "Command to get help on" in
Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"COMMAND" [])
in
let doc = "Builder database help" in
Cmdliner.Term.(ret (const help $ man_format $ choice_names $ topic)),
Cmdliner.Term.info ~doc "help"
let default_cmd =
let doc = "Builder database command" in
Cmdliner.Term.(ret (const help $ man_format $ choice_names $ const None)),
Cmdliner.Term.info ~doc "builder-db"
let () =
Mirage_crypto_rng_unix.initialize ();
Cmdliner.Term.eval_choice
default_cmd
[help_cmd; migrate_cmd;
user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd; user_disable_cmd;
access_add_cmd; access_remove_cmd; job_remove_cmd;
verify_input_id_cmd; verify_data_dir_cmd ]
|> Cmdliner.Term.exit