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

Remove rresult

Browse source
This commit is contained in:
Reynir Björnsson 2021-10-20 11:10:43 +02:00 committed by Robur
parent 045dbcf23d
commit a9ff2dd033
31 changed files with 178 additions and 152 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

208
bin/builder_db.ml
View file

@ -1,4 +1,5 @@
open Rresult.R.Infix
let ( let* ) = Result.bind
let ( let+ ) x f = Result.map f x
let or_die exit_code = function
| Ok r -> r
@ -20,17 +21,18 @@ let defer_foreign_keys =
"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 () ->
let* (module Db : Caqti_blocking.CONNECTION) = Caqti_blocking.connect uri in
let* () = Db.exec foreign_keys () in
let* () = Db.exec defer_foreign_keys () in
Ok (module Db : Caqti_blocking.CONNECTION)
let do_migrate dbpath =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ())
in
List.fold_left
(fun r migrate ->
r >>= fun () ->
let* () = r in
Logs.debug (fun m -> m "Executing migration query: %a" Caqti_request.pp migrate);
Db.exec migrate ())
(Ok ())
@ -42,9 +44,9 @@ let 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) ->
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
print_string "Password: ";
flush stdout;
(* FIXME: getpass *)
@ -65,9 +67,9 @@ 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) ->
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
Db.iter_s Builder_db.User.get_all
(fun username -> Ok (print_endline username))
()
@ -76,21 +78,22 @@ let user_list () dbpath =
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 () ->
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
let* () = Db.exec Builder_db.Access_list.remove_all_by_username username in
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
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
let* () = Db.exec Builder_db.Access_list.remove_all_by_username username in
let* user = Db.find_opt Builder_db.User.get_user username in
match user with
| None -> Error (`Msg "user not found")
| Some (_, user_info) ->
let password_hash = `Scrypt (Cstruct.empty, Cstruct.empty, Builder_web_auth.scrypt_params ()) in
@ -101,26 +104,34 @@ let user_disable () dbpath username =
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 ->
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
let* (user_id, _) =
Result.bind (Db.find_opt Builder_db.User.get_user username)
(Option.to_result ~none:(`Msg "unknown user"))
in
let* job_id =
Result.bind (Db.find_opt Builder_db.Job.get_id_by_name jobname)
(Option.to_result ~none:(`Msg "job not found"))
in
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 ->
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
let* (user_id, _) =
Result.bind (Db.find_opt Builder_db.User.get_user username)
(Option.to_result ~none:(`Msg "unknown user"))
in
let* (job_id) =
Result.bind (Db.find_opt Builder_db.Job.get_id_by_name jobname)
(Option.to_result ~none:(`Msg "job not found"))
in
Db.exec Builder_db.Access_list.remove (user_id, job_id)
in
or_die 1 r
@ -128,36 +139,39 @@ let access_remove () dbpath username jobname =
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
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
let* job_id_opt = Db.find_opt Builder_db.Job.get_id_by_name jobname in
match job_id_opt with
| 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* () = Db.start () in
let* () = Db.exec defer_foreign_keys () in
let r =
Db.collect_list Builder_db.Build.get_all job_id >>= fun builds ->
List.fold_left (fun r (build_id, build) ->
r >>= fun () ->
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));
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 () ->
let* builds = Db.collect_list Builder_db.Build.get_all job_id in
let* () =
List.fold_left (fun r (build_id, build) ->
let* () = r in
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));
let* () = Db.exec Builder_db.Build_artifact.remove_by_build build_id in
Db.exec Builder_db.Build.remove build_id)
(Ok ())
builds
in
let* () = Db.exec Builder_db.Job.remove job_id in
Db.commit ()
in
match r with
| Ok () -> Ok ()
| Error _ as e ->
Logs.warn (fun m -> m "Error: rolling back...");
Db.rollback () >>= fun () ->
let* () = Db.rollback () in
e
in
or_die 1 r
@ -179,28 +193,28 @@ let main_artifact_hash =
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 ->
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
let* input_ids = Db.collect_list input_ids () in
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* () = acc in
let+ hashes = Db.collect_list main_artifact_hash input_id in
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
@ -241,10 +255,10 @@ 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 ->
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
in
let* num_build_artifacts = Db.find num_build_artifacts () in
Logs.info (fun m -> m "total: %d artifacts" num_build_artifacts);
let progress =
let idx = ref 0 in
@ -266,28 +280,30 @@ let verify_data_dir () datadir =
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 ->
files_tracked := FpathSet.add lpath !files_tracked;
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 () ->
let* () =
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 ->
files_tracked := FpathSet.add lpath !files_tracked;
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 ()
) ()
in
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 _ ->
let* _ = Bos.OS.File.must_exist console_file in
let* _ = Bos.OS.File.must_exist script_file in
files_tracked := FpathSet.add console (FpathSet.add script !files_tracked);
Ok ()) ()
in

8
bin/migrations/builder_migrations.ml
View file

@ -1,5 +1,3 @@
open Rresult.R.Infix
type action = Fpath.t -> Caqti_blocking.connection ->
(unit, [ Caqti_error.call_or_retrieve | `Wrong_version of int32 * int64 | `Msg of string ]) result
@ -13,6 +11,7 @@ module type MIGRATION = sig
val rollback : action
end
let pp_error ppf = function
| #Caqti_error.load_or_connect | #Caqti_error.call_or_retrieve as e ->
Caqti_error.pp ppf e
@ -29,6 +28,7 @@ let or_die exit_code = function
exit exit_code
let do_database_action action () datadir =
let ( let* ) = Result.bind in
let datadir = Fpath.v datadir in
let dbpath = Fpath.(datadir / "builder.sqlite3") in
Logs.debug (fun m -> m "Connecting to database...");
@ -39,7 +39,7 @@ let do_database_action action () datadir =
in
Logs.debug (fun m -> m "Connected!");
let r =
Db.start () >>= fun () ->
let* () = Db.start () in
Logs.debug (fun m -> m "Started database transaction");
match action datadir conn with
| Ok () ->
@ -47,7 +47,7 @@ let do_database_action action () datadir =
Db.commit ()
| Error _ as e ->
Logs.debug (fun m -> m "Rolling back database transaction");
Db.rollback () >>= fun () ->
let* () = Db.rollback () in
e
in
or_die 2 r

18
bin/migrations/grej.ml
View file

@ -1,5 +1,15 @@
(* Grej is utilities *)
open Rresult.R.Infix
module Syntax = struct
let ( let* ) = Result.bind
let ( let+ ) x f = Result.map f x
end
module Infix = struct
let ( >>= ) = Result.bind
let ( >>| ) x f = Result.map f x
end
open Syntax
let set_version version =
Caqti_request.exec ~oneshot:true
@ -10,15 +20,15 @@ let check_version
?application_id:(desired_application_id=Builder_db.application_id)
~user_version:desired_user_version
(module Db : Caqti_blocking.CONNECTION) =
Db.find Builder_db.get_application_id () >>= fun application_id ->
Db.find Builder_db.get_version () >>= fun user_version ->
let* application_id = Db.find Builder_db.get_application_id () in
let* user_version = Db.find Builder_db.get_version () in
if application_id <> desired_application_id || user_version <> desired_user_version
then Error (`Wrong_version (application_id, user_version))
else Ok ()
let list_iter_result f xs =
List.fold_left
(fun r x -> r >>= fun () -> f x)
(fun r x -> let* () = r in f x)
(Ok ())
xs

4
bin/migrations/m20210126.ml
View file

@ -31,7 +31,7 @@ let set_main_binary =
"UPDATE build SET main_binary = ?2 WHERE id = ?1"
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
let open Grej.Infix in
Grej.check_version ~application_id:0l ~user_version:0L (module Db) >>= fun () ->
Db.exec alter_build () >>= fun () ->
Db.collect_list all_builds () >>= fun builds ->
@ -87,7 +87,7 @@ let rollback_data =
|}
let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
let open Grej.Infix in
Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
Db.exec rename_build () >>= fun () ->
Db.exec create_build () >>= fun () ->

2
bin/migrations/m20210202.ml
View file

@ -3,7 +3,7 @@ let identifier = "2021-02-02"
let migrate_doc = "add index job_build_idx on build"
let rollback_doc = "rollback index job_build_idx on build"
open Rresult.R.Infix
open Grej.Infix
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
let job_build_idx =

4
bin/migrations/m20210216.ml
View file

@ -36,14 +36,14 @@ let old_user =
|}
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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 Rresult.R.Infix in
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 () ->

4
bin/migrations/m20210218.ml
View file

@ -83,7 +83,7 @@ let rename_build_file =
"ALTER TABLE new_build_file RENAME TO build_file"
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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 ->
@ -150,7 +150,7 @@ let copy_build_file =
"INSERT INTO new_build_file SELECT id, filepath, localpath, sha256, build FROM build_file"
let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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 () ->

2
bin/migrations/m20210308.ml
View file

@ -11,7 +11,7 @@ let broken_builds =
|}
let fixup _datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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

2
bin/migrations/m20210427.ml
View file

@ -3,7 +3,7 @@ let identifier = "2021-04-27"
let migrate_doc = "add index idx_build_job_start on build"
let rollback_doc = "rollback index idx_build_job_start on build"
open Rresult.R.Infix
open Grej.Infix
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
let idx_build_job_start =

4
bin/migrations/m20210531.ml
View file

@ -18,7 +18,7 @@ let build_artifact_update_localpath =
(* We are not migrating build_file because it is unused *)
let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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 +29,7 @@ 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 Rresult.R.Infix in
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) ->

4
bin/migrations/m20210602.ml
View file

@ -113,7 +113,7 @@ let insert_old_build =
VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |}
let migrate _ (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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 +133,7 @@ let migrate _ (module Db : Caqti_blocking.CONNECTION) =
let rollback _ (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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 ->

2
bin/migrations/m20210608.ml
View file

@ -83,7 +83,7 @@ let rollback_access_list =
Caqti_type.unit
"DROP TABLE IF EXISTS access_list"
open Rresult.R.Infix
open Grej.Infix
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

2
bin/migrations/m20210609.ml
View file

@ -96,7 +96,7 @@ let rename_build =
Caqti_type.unit
"ALTER TABLE new_build RENAME TO build"
open Rresult.R.Infix
open Grej.Infix
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

2
bin/migrations/m20210625.ml
View file

@ -24,7 +24,7 @@ let drop_build_file =
Caqti_type.unit
"DROP TABLE build_file"
open Rresult.R.Infix
open Grej.Infix
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

2
bin/migrations/m20210629.ml
View file

@ -124,7 +124,7 @@ let find_tag =
Builder_db.Rep.untyped_id
"SELECT id FROM tag where tag = ?"
open Rresult.R.Infix
open Grej.Infix
let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

2
bin/migrations/m20210630.ml
View file

@ -55,7 +55,7 @@ let remove_tag =
Builder_db.Rep.untyped_id
"DELETE FROM tag where id = ?"
open Rresult.R.Infix
open Grej.Infix
let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

2
bin/migrations/m20210701.ml
View file

@ -72,7 +72,7 @@ let rename_build =
Caqti_type.unit
"ALTER TABLE new_build RENAME TO build"
open Rresult.R.Infix
open Grej.Infix
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

2
bin/migrations/m20210706.ml
View file

@ -77,7 +77,7 @@ let set_input_id =
(Caqti_type.tup2 Builder_db.Rep.untyped_id Builder_db.Rep.cstruct)
"UPDATE build SET input_id = ?2 WHERE id = ?1"
open Rresult.R.Infix
open Grej.Infix
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->

2
bin/migrations/m20210707a.ml
View file

@ -7,7 +7,7 @@ let orb_left_in_builds =
|}
let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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

4
bin/migrations/m20210707b.ml
View file

@ -24,7 +24,7 @@ let update_paths =
"UPDATE build_artifact SET localpath = ?2, filepath = ?3 WHERE id = ?1"
let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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
@ -45,7 +45,7 @@ let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
Db.exec update_paths (id, new_path path, new_path fpath) >>= fun () ->
let o = Fpath.append datadir path and n = Fpath.append datadir (new_path path) in
Logs.info (fun m -> m "renaming %a to %a" Fpath.pp o Fpath.pp n);
Rresult.R.error_to_msg ~pp_error:Bos.OS.U.pp_error
Result.map_error (fun e -> `Msg (Fmt.str "%a" Bos.OS.U.pp_error e))
(Bos.OS.U.rename o n) >>= fun () ->
later ())
leftover_debug

2
bin/migrations/m20210707c.ml
View file

@ -22,7 +22,7 @@ let add_artifact : ((Fpath.t * Fpath.t * Cstruct.t) * (int64 * [`build] Builder_
{| INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?) |}
let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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

2
bin/migrations/m20210707d.ml
View file

@ -11,7 +11,7 @@ let update_path : ([`build_artifact] Builder_db.Rep.id * Fpath.t, unit, [< `Zero
"UPDATE build_artifact SET filepath = ?2 WHERE id = ?1"
let fixup _datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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

4
bin/migrations/m20210712a.ml
View file

@ -125,9 +125,8 @@ let execution_old_of_new code =
then Ok (3, None)
else Error (`Msg "bad encoding")
open Rresult.R.Infix
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 () ->
@ -156,6 +155,7 @@ 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.exec old_build () >>= fun () ->
Db.exec copy_new_build () >>= fun () ->

2
bin/migrations/m20210712b.ml
View file

@ -12,7 +12,7 @@ let all_build_artifacts_like_readme : (unit, [`build_artifact] Builder_db.Rep.id
"SELECT id, localpath FROM build_artifact WHERE filepath LIKE '%README.md'"
let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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 ->

6
bin/migrations/m20210712c.ml
View file

@ -3,7 +3,7 @@ and identifier = "2021-07-12c"
and migrate_doc = "store script, console on disk"
and rollback_doc = "store script, console in database"
open Rresult.R.Infix
open Grej.Infix
module Asn = struct
let decode_strict codec cs =
@ -132,7 +132,7 @@ let rename_build =
let console_to_string console =
Asn.console_of_cs console
|> Rresult.R.reword_error (fun s -> `Msg s) >>| fun console ->
|> Result.map_error (fun s -> `Msg s) >>| fun console ->
List.rev_map (fun (delta, data) ->
Printf.sprintf "%.3fs:%s\n" (Duration.to_f (Int64.of_int delta)) data)
console
@ -176,8 +176,6 @@ let read_console_and_script datadir console_file script_file =
Bos.OS.File.delete script_file >>= fun () ->
Ok (console, script)
open Rresult.R.Infix
let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
Db.exec new_build () >>= fun () ->

2
bin/migrations/m20210910.ml
View file

@ -10,7 +10,7 @@ let fixup =
"UPDATE build SET console = ?2, script = ?3 WHERE id = ?1"
let fixup _datadir (module Db : Caqti_blocking.CONNECTION) =
let open Rresult.R.Infix in
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) ->

1
builder-web.opam
View file

@ -37,7 +37,6 @@ depends: [
"tyxml"
"ptime"
"duration"
"rresult"
"mirage-crypto"
"asn1-combinators"
"logs"

21
lib/builder_web.ml
View file

@ -13,15 +13,18 @@ let pp_error ppf = function
else Format.fprintf ppf "Wrong database application id: %ld" application_id
let init_datadir datadir =
let open Rresult.R.Infix in
Bos.OS.Dir.exists datadir >>= (fun exists ->
if exists
then Ok ()
else Error (`Msg "Datadir does not exist")) >>= fun () ->
Bos.OS.Dir.create ~path:false (Model.staging datadir) >>| fun _ -> ()
let ( let* ) = Result.bind and ( let+ ) x f = Result.map f x in
let* exists = Bos.OS.Dir.exists datadir in
let* () =
if exists
then Ok ()
else Error (`Msg "Datadir does not exist")
in
let+ _ = Bos.OS.Dir.create ~path:false (Model.staging datadir) in
()
let init dbpath datadir =
Rresult.R.bind (init_datadir datadir) @@ fun () ->
Result.bind (init_datadir datadir) @@ fun () ->
Lwt_main.run (
Caqti_lwt.connect
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
@ -40,7 +43,7 @@ let pp_exec ppf ((job : Builder.script_job), uuid, _, _, _, _, _) =
let safe_seg path =
if Fpath.is_seg path && not (Fpath.is_rel_seg path)
then Ok (Fpath.v path)
else Rresult.R.error_msgf "unsafe path %S" path
else Fmt.kstr (fun s -> Error (`Msg s)) "unsafe path %S" path
(* mime lookup with orb knowledge *)
let mime_lookup path =
@ -178,7 +181,7 @@ let add_routes datadir =
* 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. *)
get_uuid build >>= fun build ->
Fpath.of_string filepath |> Rresult.R.open_error_msg |> Lwt_result.lift
Fpath.of_string filepath |> Lwt_result.lift
|> if_error ~status:`Not_Found "File not found" >>= fun filepath ->
Dream.sql req (Model.build_artifact build filepath)
|> if_error "Error getting build artifact" >>= fun file ->

2
lib/dune
View file

@ -1,3 +1,3 @@
(library
(name builder_web)
(libraries builder builder_db dream tyxml bos rresult duration hex caqti-lwt opamdiff ptime.clock.os omd))
(libraries builder builder_db dream tyxml bos duration hex caqti-lwt opamdiff ptime.clock.os omd))

6
test/builder_db.ml
View file

@ -1,4 +1,5 @@
open Rresult.R.Infix
let ( >>= ) = Result.bind
let ( >>| ) x f = Result.map f x
module type CONN = Caqti_blocking.CONNECTION
@ -165,8 +166,7 @@ let add_test_build user_id (module Db : CONN) =
Db.exec Build.set_main_binary (id, main_binary_id) >>= fun () ->
Db.commit ()
in
Rresult.R.kignore_error
~use:(fun _ -> Db.rollback ())
Result.fold ~ok:Result.ok ~error:(fun _ -> Db.rollback ())
r
let with_build_db f () =

2
test/dune
View file

@ -1,3 +1,3 @@
(test
(name builder_db)
(libraries builder_db caqti.blocking alcotest mirage-crypto-rng.unix rresult))
(libraries builder_db caqti.blocking alcotest mirage-crypto-rng.unix))