From a9ff2dd033cf7ad96b0f7752c5dff3e31fa7c77c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Wed, 20 Oct 2021 11:10:43 +0200 Subject: [PATCH] Remove rresult --- bin/builder_db.ml | 208 ++++++++++++++------------- bin/migrations/builder_migrations.ml | 8 +- bin/migrations/grej.ml | 18 ++- bin/migrations/m20210126.ml | 4 +- bin/migrations/m20210202.ml | 2 +- bin/migrations/m20210216.ml | 4 +- bin/migrations/m20210218.ml | 4 +- bin/migrations/m20210308.ml | 2 +- bin/migrations/m20210427.ml | 2 +- bin/migrations/m20210531.ml | 4 +- bin/migrations/m20210602.ml | 4 +- bin/migrations/m20210608.ml | 2 +- bin/migrations/m20210609.ml | 2 +- bin/migrations/m20210625.ml | 2 +- bin/migrations/m20210629.ml | 2 +- bin/migrations/m20210630.ml | 2 +- bin/migrations/m20210701.ml | 2 +- bin/migrations/m20210706.ml | 2 +- bin/migrations/m20210707a.ml | 2 +- bin/migrations/m20210707b.ml | 4 +- bin/migrations/m20210707c.ml | 2 +- bin/migrations/m20210707d.ml | 2 +- bin/migrations/m20210712a.ml | 4 +- bin/migrations/m20210712b.ml | 2 +- bin/migrations/m20210712c.ml | 6 +- bin/migrations/m20210910.ml | 2 +- builder-web.opam | 1 - lib/builder_web.ml | 21 +-- lib/dune | 2 +- test/builder_db.ml | 6 +- test/dune | 2 +- 31 files changed, 178 insertions(+), 152 deletions(-) diff --git a/bin/builder_db.ml b/bin/builder_db.ml index dace924..5630dc5 100644 --- a/bin/builder_db.ml +++ b/bin/builder_db.ml @@ -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 //output/: %a" Fpath.pp path)) | _ -> Logs.err (fun m -> m "path is not of form //...: %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 diff --git a/bin/migrations/builder_migrations.ml b/bin/migrations/builder_migrations.ml index 19761a7..9ddd6a9 100644 --- a/bin/migrations/builder_migrations.ml +++ b/bin/migrations/builder_migrations.ml @@ -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 diff --git a/bin/migrations/grej.ml b/bin/migrations/grej.ml index dbc79fc..0facbc3 100644 --- a/bin/migrations/grej.ml +++ b/bin/migrations/grej.ml @@ -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 diff --git a/bin/migrations/m20210126.ml b/bin/migrations/m20210126.ml index 13735a2..19a6f46 100644 --- a/bin/migrations/m20210126.ml +++ b/bin/migrations/m20210126.ml @@ -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 () -> diff --git a/bin/migrations/m20210202.ml b/bin/migrations/m20210202.ml index 6702ed8..06c6423 100644 --- a/bin/migrations/m20210202.ml +++ b/bin/migrations/m20210202.ml @@ -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 = diff --git a/bin/migrations/m20210216.ml b/bin/migrations/m20210216.ml index 7cd0c68..7daa8d6 100644 --- a/bin/migrations/m20210216.ml +++ b/bin/migrations/m20210216.ml @@ -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 () -> diff --git a/bin/migrations/m20210218.ml b/bin/migrations/m20210218.ml index ffca0f4..01ea7dc 100644 --- a/bin/migrations/m20210218.ml +++ b/bin/migrations/m20210218.ml @@ -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 () -> diff --git a/bin/migrations/m20210308.ml b/bin/migrations/m20210308.ml index bc24cbc..0a02b0c 100644 --- a/bin/migrations/m20210308.ml +++ b/bin/migrations/m20210308.ml @@ -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 diff --git a/bin/migrations/m20210427.ml b/bin/migrations/m20210427.ml index 57db5af..a3338ff 100644 --- a/bin/migrations/m20210427.ml +++ b/bin/migrations/m20210427.ml @@ -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 = diff --git a/bin/migrations/m20210531.ml b/bin/migrations/m20210531.ml index 6c334c3..359c719 100644 --- a/bin/migrations/m20210531.ml +++ b/bin/migrations/m20210531.ml @@ -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) -> diff --git a/bin/migrations/m20210602.ml b/bin/migrations/m20210602.ml index c2c0be1..808c5d4 100644 --- a/bin/migrations/m20210602.ml +++ b/bin/migrations/m20210602.ml @@ -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 -> diff --git a/bin/migrations/m20210608.ml b/bin/migrations/m20210608.ml index afcf576..c3cccc9 100644 --- a/bin/migrations/m20210608.ml +++ b/bin/migrations/m20210608.ml @@ -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 () -> diff --git a/bin/migrations/m20210609.ml b/bin/migrations/m20210609.ml index 0fcfd8d..5bc7e34 100644 --- a/bin/migrations/m20210609.ml +++ b/bin/migrations/m20210609.ml @@ -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 () -> diff --git a/bin/migrations/m20210625.ml b/bin/migrations/m20210625.ml index 906c731..1f88908 100644 --- a/bin/migrations/m20210625.ml +++ b/bin/migrations/m20210625.ml @@ -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 () -> diff --git a/bin/migrations/m20210629.ml b/bin/migrations/m20210629.ml index 110e1d0..2a546e4 100644 --- a/bin/migrations/m20210629.ml +++ b/bin/migrations/m20210629.ml @@ -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 () -> diff --git a/bin/migrations/m20210630.ml b/bin/migrations/m20210630.ml index cf16dd6..b59d644 100644 --- a/bin/migrations/m20210630.ml +++ b/bin/migrations/m20210630.ml @@ -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 () -> diff --git a/bin/migrations/m20210701.ml b/bin/migrations/m20210701.ml index 493ec83..25a30c5 100644 --- a/bin/migrations/m20210701.ml +++ b/bin/migrations/m20210701.ml @@ -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 () -> diff --git a/bin/migrations/m20210706.ml b/bin/migrations/m20210706.ml index 40e1dc4..1ca5867 100644 --- a/bin/migrations/m20210706.ml +++ b/bin/migrations/m20210706.ml @@ -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 () -> diff --git a/bin/migrations/m20210707a.ml b/bin/migrations/m20210707a.ml index 13f94fc..ba098ba 100644 --- a/bin/migrations/m20210707a.ml +++ b/bin/migrations/m20210707a.ml @@ -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 diff --git a/bin/migrations/m20210707b.ml b/bin/migrations/m20210707b.ml index e112090..49978cc 100644 --- a/bin/migrations/m20210707b.ml +++ b/bin/migrations/m20210707b.ml @@ -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 diff --git a/bin/migrations/m20210707c.ml b/bin/migrations/m20210707c.ml index ba4ab36..f31651a 100644 --- a/bin/migrations/m20210707c.ml +++ b/bin/migrations/m20210707c.ml @@ -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 diff --git a/bin/migrations/m20210707d.ml b/bin/migrations/m20210707d.ml index ba9ce19..0561133 100644 --- a/bin/migrations/m20210707d.ml +++ b/bin/migrations/m20210707d.ml @@ -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 diff --git a/bin/migrations/m20210712a.ml b/bin/migrations/m20210712a.ml index 3efec10..e730d2f 100644 --- a/bin/migrations/m20210712a.ml +++ b/bin/migrations/m20210712a.ml @@ -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 () -> diff --git a/bin/migrations/m20210712b.ml b/bin/migrations/m20210712b.ml index 0c26dbb..4927d52 100644 --- a/bin/migrations/m20210712b.ml +++ b/bin/migrations/m20210712b.ml @@ -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 -> diff --git a/bin/migrations/m20210712c.ml b/bin/migrations/m20210712c.ml index dc15211..6fa84d9 100644 --- a/bin/migrations/m20210712c.ml +++ b/bin/migrations/m20210712c.ml @@ -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 () -> diff --git a/bin/migrations/m20210910.ml b/bin/migrations/m20210910.ml index 18c5177..191517f 100644 --- a/bin/migrations/m20210910.ml +++ b/bin/migrations/m20210910.ml @@ -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) -> diff --git a/builder-web.opam b/builder-web.opam index 36e0b9a..2b55fa3 100644 --- a/builder-web.opam +++ b/builder-web.opam @@ -37,7 +37,6 @@ depends: [ "tyxml" "ptime" "duration" - "rresult" "mirage-crypto" "asn1-combinators" "logs" diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 13ab83f..9e61726 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -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 -> diff --git a/lib/dune b/lib/dune index 836101f..5c950f8 100644 --- a/lib/dune +++ b/lib/dune @@ -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)) diff --git a/test/builder_db.ml b/test/builder_db.ml index 9eafca0..2890769 100644 --- a/test/builder_db.ml +++ b/test/builder_db.ml @@ -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 () = diff --git a/test/dune b/test/dune index 68a0b92..d728f6c 100644 --- a/test/dune +++ b/test/dune @@ -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))