Remove rresult

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

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 =
let* (module Db : Caqti_blocking.CONNECTION) =
connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ())
>>= fun (module Db : Caqti_blocking.CONNECTION) ->
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 ->
let* builds = Db.collect_list Builder_db.Build.get_all job_id in
let* () =
List.fold_left (fun r (build_id, build) ->
r >>= fun () ->
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));
Db.exec Builder_db.Build_artifact.remove_by_build build_id >>= fun () ->
let* () = Db.exec Builder_db.Build_artifact.remove_by_build build_id in
Db.exec Builder_db.Build.remove build_id)
(Ok ())
builds >>= fun () ->
Db.exec Builder_db.Job.remove job_id >>= fun () ->
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,13 +193,13 @@ 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 ->
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', _) ->
@ -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,6 +280,7 @@ 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
let* () =
Db.iter_s build_artifacts (fun (job, uuid, (fpath, lpath, sha, size)) ->
progress ();
verify_job_and_uuid ~fpath job uuid lpath;
@ -279,15 +294,16 @@ let verify_data_dir () datadir =
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 () ->
) ()
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

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

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

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 () ->

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 =

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 () ->

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 () ->

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

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 =

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) ->

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 ->

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 () ->

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 () ->

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 () ->

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 () ->

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 () ->

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 () ->

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 () ->

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

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

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

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

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 () ->

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 ->

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 () ->

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) ->

View file

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

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 ->
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")) >>= fun () ->
Bos.OS.Dir.create ~path:false (Model.staging datadir) >>| fun _ -> ()
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 ->

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))

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 () =

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))