Remove rresult
This commit is contained in:
parent
045dbcf23d
commit
a9ff2dd033
31 changed files with 178 additions and 152 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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) ->
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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 () ->
|
||||
|
|
|
@ -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) ->
|
||||
|
|
|
@ -37,7 +37,6 @@ depends: [
|
|||
"tyxml"
|
||||
"ptime"
|
||||
"duration"
|
||||
"rresult"
|
||||
"mirage-crypto"
|
||||
"asn1-combinators"
|
||||
"logs"
|
||||
|
|
|
@ -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 ->
|
||||
|
|
2
lib/dune
2
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))
|
||||
|
|
|
@ -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 () =
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Reference in a new issue