diff --git a/dune b/dune index c94366f5..f4c120ce 100644 --- a/dune +++ b/dune @@ -3,7 +3,7 @@ (name main) (package obuilder) (preprocess (pps ppx_deriving.show)) - (libraries lwt lwt.unix fmt fmt.cli fmt.tty tar-unix obuilder cmdliner logs.fmt logs.cli)) + (libraries eio_main fmt fmt.cli fmt.tty tar-unix obuilder cmdliner logs.fmt logs.cli)) ; (rule diff --git a/dune-project b/dune-project index 0f633fb8..c02f8999 100644 --- a/dune-project +++ b/dune-project @@ -25,12 +25,15 @@ (description "OBuilder takes a build script (similar to a Dockerfile) and performs the steps in it in a sandboxed environment.") (depends + (eio (>= 1.3)) + eio_main (lwt (>= 5.7.0)) + lwt_eio astring (fmt (>= 0.8.9)) logs (cmdliner (>= 1.3.0)) - (tar-unix (and (>= 2.6.0) (< 3.0.0))) + (tar-unix (>= 2.6.0)) (yojson (>= 1.6.0)) sexplib ppx_deriving @@ -41,8 +44,8 @@ (obuilder-spec (= :version)) fpath (extunix (>= 0.4.2)) - (ocaml (>= 4.14.2)) - (alcotest-lwt (and (>= 1.7.0) :with-test)))) + (ocaml (>= 5.2.0)) + (alcotest (and (>= 1.7.0) :with-test)))) (package (name obuilder-spec) diff --git a/lib/archive_extract.ml b/lib/archive_extract.ml index aa835f8f..7c7ded5a 100644 --- a/lib/archive_extract.ml +++ b/lib/archive_extract.ml @@ -1,26 +1,15 @@ -open Lwt.Infix - let invoke_fetcher base destdir = Os.with_pipe_between_children @@ fun ~r ~w -> let stdin = `FD_move_safely r in let stdout = `FD_move_safely w in let stderr = stdout in - let fetcher = - Os.exec ~stdout ~stderr ["fetch"; "-q" ; "-o" ; "-" ; base ] - in - let extracter = - Os.sudo ~stdin [ "tar" ; "-C"; destdir ; "-xzpf"; "-" ] - in - fetcher >>= fun () -> - extracter + Os.exec ~stdout ~stderr ["fetch"; "-q" ; "-o" ; "-" ; base ]; + Os.sudo ~stdin [ "tar" ; "-C"; destdir ; "-xzpf"; "-" ] let fetch ~log:_ ~root:_ ~rootfs base = - Lwt.catch - (fun () -> - invoke_fetcher base rootfs >>= fun () -> - let env = [] in - Lwt.return env) - (function - | Sys_error s -> - Fmt.failwith "Archive fetcher encountered a system error: %s" s - | ex -> Lwt.reraise ex) + (try + invoke_fetcher base rootfs; + [] + with + | Sys_error s -> + Fmt.failwith "Archive fetcher encountered a system error: %s" s) diff --git a/lib/btrfs_store.ml b/lib/btrfs_store.ml index 5974dffc..d89c60ab 100644 --- a/lib/btrfs_store.ml +++ b/lib/btrfs_store.ml @@ -1,5 +1,3 @@ -open Lwt.Infix - let strf = Printf.sprintf let running_as_root = Unix.getuid () = 0 @@ -11,7 +9,7 @@ let running_as_root = Unix.getuid () = 0 since being cloned. The counter starts from zero when the in-memory cache value is created (i.e. you cannot compare across restarts). *) type cache = { - lock : Lwt_mutex.t; + lock : Mutex.t; mutable gen : int; } @@ -51,7 +49,7 @@ end let delete_snapshot_if_exists path = match Os.check_dir path with - | `Missing -> Lwt.return_unit + | `Missing -> () | `Present -> Btrfs.subvolume_delete path module Path = struct @@ -76,19 +74,19 @@ let delete t id = delete_snapshot_if_exists (Path.result t id) let purge path = - Sys.readdir path |> Array.to_list |> Lwt_list.iter_s (fun item -> + Sys.readdir path |> Array.to_list |> List.iter (fun item -> let item = path / item in Log.warn (fun f -> f "Removing left-over temporary item %S" item); Btrfs.subvolume_delete item ) let check_kernel_version () = - Os.pread ["uname"; "-r"] >>= fun kver -> + let kver = Os.pread ["uname"; "-r"] in match String.split_on_char '.' kver with | maj :: min :: _ -> begin match int_of_string_opt maj, int_of_string_opt min with | Some maj, Some min when (maj, min) >= (5, 8) -> - Lwt.return_unit + () | Some maj, Some min -> Fmt.failwith "You need at least linux 5.8 to use the btrfs backend, \ but current kernel version is '%d.%d'" maj min @@ -103,7 +101,7 @@ let root t = t.root module Stats = Map.Make (String) let df t = - Lwt_process.pread ("", [| "btrfs"; "filesystem"; "usage"; "-b"; t.root |]) >>= fun output -> + let output = Os.pread ["btrfs"; "filesystem"; "usage"; "-b"; t.root] in let stats = String.split_on_char '\n' output |> List.filter_map (fun s -> @@ -116,52 +114,46 @@ let df t = | _ -> None) |> List.fold_left (fun acc (k, v) -> Stats.add k v acc) Stats.empty in - Lwt.return (100. -. (100. *. (Stats.find "Used" stats /. Stats.find "Device size" stats))) + 100. -. (100. *. (Stats.find "Used" stats /. Stats.find "Device size" stats)) let create root = - check_kernel_version () >>= fun () -> + check_kernel_version (); Os.ensure_dir (root / "result"); Os.ensure_dir (root / "result-tmp"); Os.ensure_dir (root / "state"); Os.ensure_dir (root / "cache"); Os.ensure_dir (root / "cache-tmp"); - purge (root / "result-tmp") >>= fun () -> - purge (root / "cache-tmp") >>= fun () -> - Lwt.return { root; caches = Hashtbl.create 10; next = 0 } + purge (root / "result-tmp"); + purge (root / "cache-tmp"); + { root; caches = Hashtbl.create 10; next = 0 } let build t ?base ~id fn = let result = Path.result t id in let result_tmp = Path.result_tmp t id in assert (not (Sys.file_exists result)); (* Builder should have checked first *) - begin match base with + (match base with | None -> Btrfs.subvolume_create result_tmp - | Some base -> Btrfs.subvolume_snapshot `RW ~src:(Path.result t base) result_tmp - end - >>= fun () -> - Lwt.try_bind - (fun () -> fn result_tmp) - (fun r -> - begin match r with - | Ok () -> Btrfs.subvolume_snapshot `RO ~src:result_tmp result - | Error _ -> Lwt.return_unit - end >>= fun () -> - Btrfs.subvolume_delete result_tmp >>= fun () -> - Lwt.return r - ) - (fun ex -> - Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); - Btrfs.subvolume_delete result_tmp >>= fun () -> - Lwt.reraise ex - ) + | Some base -> Btrfs.subvolume_snapshot `RW ~src:(Path.result t base) result_tmp); + match (try Ok (fn result_tmp) with ex -> Error ex) with + | Ok r -> + (match r with + | Ok () -> Btrfs.subvolume_snapshot `RO ~src:result_tmp result + | Error _ -> ()); + Btrfs.subvolume_delete result_tmp; + r + | Error ex -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); + Btrfs.subvolume_delete result_tmp; + raise ex let result t id = let dir = Path.result t id in match Os.check_dir dir with - | `Present -> Lwt.return_some dir - | `Missing -> Lwt.return_none + | `Present -> Some dir + | `Missing -> None let log_file t id = - result t id >|= function + match result t id with | Some dir -> dir / "log" | None -> (Path.result_tmp t id) / "log" @@ -169,53 +161,52 @@ let get_cache t name = match Hashtbl.find_opt t.caches name with | Some c -> c | None -> - let c = { lock = Lwt_mutex.create (); gen = 0 } in + let c = { lock = Mutex.create (); gen = 0 } in Hashtbl.add t.caches name c; c -let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t = +let cache ~user t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> let tmp = Path.cache_tmp t t.next name in t.next <- t.next + 1; let snapshot = Path.cache t name in (* Create cache if it doesn't already exist. *) - begin match Os.check_dir snapshot with + (match Os.check_dir snapshot with | `Missing -> Btrfs.subvolume_create snapshot - | `Present -> Lwt.return_unit - end >>= fun () -> + | `Present -> ()); (* Create writeable clone. *) let gen = cache.gen in - Btrfs.subvolume_snapshot `RW ~src:snapshot tmp >>= fun () -> - begin match user with + Btrfs.subvolume_snapshot `RW ~src:snapshot tmp; + (match user with | `Unix { Obuilder_spec.uid; gid } -> Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; tmp] - | `Windows _ -> assert false (* btrfs not supported on Windows*) - end >>= fun () -> + | `Windows _ -> assert false (* btrfs not supported on Windows*)); let release () = - Lwt_mutex.with_lock cache.lock @@ fun () -> - begin - if cache.gen = gen then ( + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> + (if cache.gen = gen then ( (* The cache hasn't changed since we cloned it. Update it. *) (* todo: check if it has actually changed. *) cache.gen <- cache.gen + 1; - Btrfs.subvolume_delete snapshot >>= fun () -> + Btrfs.subvolume_delete snapshot; Btrfs.subvolume_snapshot `RO ~src:tmp snapshot - ) else Lwt.return_unit - end >>= fun () -> - Btrfs.subvolume_delete tmp + )); + Btrfs.subvolume_delete tmp) in - Lwt.return (tmp, release) + (tmp, release)) let delete_cache t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) let snapshot = Path.cache t name in if Sys.file_exists snapshot then ( - Btrfs.subvolume_delete snapshot >>= fun () -> - Lwt_result.return () - ) else Lwt_result.return () + Btrfs.subvolume_delete snapshot; + Ok () + ) else Ok ()) let state_dir = Path.state diff --git a/lib/btrfs_store.mli b/lib/btrfs_store.mli index e2e2ff52..12c40d80 100644 --- a/lib/btrfs_store.mli +++ b/lib/btrfs_store.mli @@ -2,5 +2,5 @@ include S.STORE -val create : string -> t Lwt.t +val create : string -> t (** [create path] is a new store in btrfs directory [path]. *) diff --git a/lib/build.ml b/lib/build.ml index b8a0b8fd..6c2a3b38 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -1,17 +1,15 @@ -open Lwt.Infix open Sexplib.Std let ( / ) = Filename.concat let ( // ) p1 p2 = if Sys.win32 then p1 ^ "/" ^ p2 else Filename.concat p1 p2 -let ( >>!= ) = Lwt_result.bind let hostname = "builder" let healthcheck_base () = if Sys.win32 then - Docker_sandbox.servercore () >>= fun (`Docker_image servercore) -> - Lwt.return servercore - else Lwt.return "busybox" + let (`Docker_image servercore) = Docker_sandbox.servercore () in + servercore + else "busybox" let healthcheck_ops = let open Obuilder_spec in @@ -24,7 +22,7 @@ module Scope = Map.Make(String) module Context = struct type t = { - switch : Lwt_switch.t option; + cancelled : unit Eio.Promise.t option; env : Config.env; (* Environment in which to run commands. *) src_dir : string; (* Directory with files for copying. *) user : Obuilder_spec.user; (* Container user to run as. *) @@ -35,9 +33,9 @@ module Context = struct secrets : (string * string) list; } - let v ?switch ?(env=[]) ?(user=Obuilder_spec.root) ?workdir ?(secrets=[]) ~shell ~log ~src_dir () = + let v ?cancelled ?(env=[]) ?(user=Obuilder_spec.root) ?workdir ?(secrets=[]) ~shell ~log ~src_dir () = let workdir = Option.value ~default:(if Sys.win32 then {|C:/|} else "/") workdir in - { switch; env; src_dir; user; workdir; shell; log; scope = Scope.empty; secrets } + { cancelled; env; src_dir; user; workdir; shell; log; scope = Scope.empty; secrets } let with_binding name value t = { t with scope = Scope.add name value t.scope } @@ -70,7 +68,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st mount_secrets : Config.Secret.t list; } [@@deriving sexp_of] - let run t ~switch ~log ~cache run_input = + let run t ~cancelled ~log ~cache run_input = let id = sexp_of_run_input run_input |> Sexplib.Sexp.to_string_mach @@ -78,24 +76,24 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st |> Sha256.to_hex in let { base; workdir; user; env; cmd; shell; network; mount_secrets } = run_input in - Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log result_tmp -> + Store.build t.store ?cancelled ~base ~id ~log (fun ~cancelled ~log result_tmp -> let to_release = ref [] in - Lwt.finalize + Fun.protect (fun () -> - cache |> Lwt_list.map_s (fun { Obuilder_spec.Cache.id; target; buildkit_options = _ } -> - Store.cache ~user t.store id >|= fun (src, release) -> + let mounts = cache |> List.map (fun { Obuilder_spec.Cache.id; target; buildkit_options = _ } -> + let (src, release) = Store.cache ~user t.store id in to_release := release :: !to_release; { Config.Mount.ty = `Bind; src; dst = target; readonly = false } ) - >>= fun mounts -> + in let argv = shell @ [cmd] in let config = Config.v ~cwd:workdir ~argv ~hostname ~user ~env ~mounts ~mount_secrets ~network () in Os.with_pipe_to_child @@ fun ~r:stdin ~w:close_me -> - Lwt_unix.close close_me >>= fun () -> + Unix.close close_me; Sandbox.run ~cancelled ~stdin ~log t.sandbox config result_tmp ) - (fun () -> - !to_release |> Lwt_list.iter_s (fun f -> f ()) + ~finally:(fun () -> + !to_release |> List.iter (fun f -> f ()) ) ) @@ -120,64 +118,61 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st | _ -> Fmt.error_msg "When copying multiple items, the destination must end with '/'" let copy t ~context ~base { Obuilder_spec.from; src; dst; exclude } = - let { Context.switch; src_dir; workdir; user; log; shell = _; env = _; scope; secrets = _ } = context in + let { Context.cancelled; src_dir; workdir; user; log; shell = _; env = _; scope; secrets = _ } = context in let dst = if Filename.is_relative dst then workdir / dst else dst in - begin + let src_dir_result = match from with - | `Context -> Lwt_result.return src_dir + | `Context -> Ok src_dir | `Build name -> match Scope.find_opt name scope with | None -> Fmt.failwith "Unknown build %S" name (* (shouldn't happen; gets caught earlier) *) | Some id -> - Store.result t.store id >>= function + match Store.result t.store id with | None -> - Lwt_result.fail (`Msg (Fmt.str "Build result %S not found" id)) + Error (`Msg (Fmt.str "Build result %S not found" id)) | Some dir -> - Lwt_result.return (dir / "rootfs") - end >>!= fun src_dir -> - let src_manifest = sequence (List.map (Manifest.generate ~exclude ~src_dir) src) in - match Result.bind src_manifest (to_copy_op ~dst) with - | Error _ as e -> Lwt.return e - | Ok op -> - let details = { - base; - op; - user; - } in - (* Fmt.pr "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details); *) - let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in - Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log result_tmp -> - let argv = Sandbox.tar t.sandbox in - let config = Config.v - ~cwd:"/" - ~argv - ~hostname - ~user:Obuilder_spec.root - ~env:["PATH", "/bin:/usr/bin"] - ~mount_secrets:[] - ~mounts:[] - ~network:[] - () - in - Os.with_pipe_to_child @@ fun ~r:from_us ~w:to_untar -> - let proc = Sandbox.run ~cancelled ~stdin:from_us ~log t.sandbox config result_tmp in - let send = - (* If the sending thread finishes (or fails), close the writing socket - immediately so that the tar process finishes too. *) - Lwt.finalize + Ok (dir / "rootfs") + in + match src_dir_result with + | Error _ as e -> e + | Ok src_dir -> + let src_manifest = sequence (List.map (Manifest.generate ~exclude ~src_dir) src) in + match Result.bind src_manifest (to_copy_op ~dst) with + | Error _ as e -> e + | Ok op -> + let details = { + base; + op; + user; + } in + (* Fmt.pr "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details); *) + let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in + Store.build t.store ?cancelled ~base ~id ~log (fun ~cancelled ~log result_tmp -> + let argv = Sandbox.tar t.sandbox in + let config = Config.v + ~cwd:"/" + ~argv + ~hostname + ~user:Obuilder_spec.root + ~env:["PATH", "/bin:/usr/bin"] + ~mount_secrets:[] + ~mounts:[] + ~network:[] + () + in + Os.with_pipe_to_child @@ fun ~r:from_us ~w:to_untar -> + let proc = Sandbox.run ~cancelled ~stdin:from_us ~log t.sandbox config result_tmp in + Fun.protect (fun () -> match op with | `Copy_items (src_manifest, dst_dir) -> - Tar_transfer.send_files ~src_dir ~src_manifest ~dst_dir ~to_untar ~user + Tar_transfer.send_files ~src_dir ~src_manifest ~dst_dir ~to_untar:to_untar ~user | `Copy_item (src_manifest, dst) -> - Tar_transfer.send_file ~src_dir ~src_manifest ~dst ~to_untar ~user + Tar_transfer.send_file ~src_dir ~src_manifest ~dst ~to_untar:to_untar ~user ) - (fun () -> Lwt_unix.close to_untar) - in - proc >>= fun result -> - send >>= fun () -> - Lwt.return result - ) + ~finally:(fun () -> (try Unix.close to_untar with Unix.Unix_error _ -> ())); + proc + ) let pp_op ~(context:Context.t) f op = Fmt.pf f "@[%s: %a@]" context.workdir Obuilder_spec.pp_op op @@ -203,7 +198,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st (resolved_secret :: result) ) (Ok []) secrets let rec run_steps t ~(context:Context.t) ~base = function - | [] -> Sandbox.finished () >>= fun () -> Lwt_result.return base + | [] -> Sandbox.finished (); Ok base | op :: ops -> context.log `Heading Fmt.(str "%a" (pp_op ~context) op); let k = run_steps t ops in @@ -213,16 +208,20 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st | `User user -> k ~base ~context:{context with user} | `Run { shell = cmd; cache; network; secrets = mount_secrets } -> let result = - let { Context.switch; workdir; user; env; shell; log; src_dir = _; scope = _; secrets } = context in + let { Context.cancelled; workdir; user; env; shell; log; src_dir = _; scope = _; secrets } = context in resolve_secrets secrets mount_secrets |> Result.map @@ fun mount_secrets -> - (switch, { base; workdir; user; env; cmd; shell; network; mount_secrets }, log) + (cancelled, { base; workdir; user; env; cmd; shell; network; mount_secrets }, log) in - Lwt.return result >>!= fun (switch, run_input, log) -> - run t ~switch ~log ~cache run_input >>!= fun base -> - k ~base ~context + (match result with + | Error _ as e -> e + | Ok (cancelled, run_input, log) -> + match run t ~cancelled ~log ~cache run_input with + | Error _ as e -> e + | Ok base -> k ~base ~context) | `Copy x -> - copy t ~context ~base x >>!= fun base -> - k ~base ~context + (match copy t ~context ~base x with + | Error _ as e -> e + | Ok base -> k ~base ~context) | `Env ((key, _) as e) -> let env = e :: (List.remove_assoc key context.env) in k ~base ~context:{context with env} @@ -233,38 +232,45 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st log `Heading (Fmt.str "(from %a)" Sexplib.Sexp.pp_hum (Atom base)); let id = Sha256.to_hex (Sha256.string base) in let root = Store.root t.store in - Store.build t.store ~id ~log (fun ~cancelled:_ ~log tmp -> - Log.info (fun f -> f "Base image not present; importing %S…" base); + match Store.build t.store ~id ~log (fun ~cancelled:_ ~log tmp -> + Log.info (fun f -> f "Base image not present; importing %S..." base); let rootfs = tmp / "rootfs" in - Os.sudo ["mkdir"; "-m"; "755"; "--"; rootfs] >>= fun () -> - Fetch.fetch ~log ~root ~rootfs base >>= fun env -> + Os.sudo ["mkdir"; "-m"; "755"; "--"; rootfs]; + let env = Fetch.fetch ~log ~root ~rootfs base in Os.write_file ~path:(tmp / "env") - (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () -> - Lwt_result.return () - ) - >>!= fun id -> Store.result t.store id - >|= Option.get >>= fun path -> - let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in - Lwt_result.return (id, env) + (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})); + Ok () + ) with + | Error _ as e -> e + | Ok id -> + let path = Option.get (Store.result t.store id) in + let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in + Ok (id, env) let rec build t context { Obuilder_spec.child_builds; from = base; ops } = let rec aux context = function - | [] -> Lwt_result.return context + | [] -> Ok context | (name, child_spec) :: child_builds -> - context.Context.log `Heading Fmt.(str "(build %S …)" name); - build t context child_spec >>!= fun child_result -> - context.Context.log `Note Fmt.(str "--> finished %S" name); - let context = Context.with_binding name child_result context in - aux context child_builds + context.Context.log `Heading Fmt.(str "(build %S ...)" name); + (match build t context child_spec with + | Error _ as e -> e + | Ok child_result -> + context.Context.log `Note Fmt.(str "--> finished %S" name); + let context = Context.with_binding name child_result context in + aux context child_builds) in - aux context child_builds >>!= fun context -> - get_base t ~log:context.Context.log base >>!= fun (id, env) -> - let context = { context with env = context.env @ env } in - run_steps t ~context ~base:id ops + match aux context child_builds with + | Error _ as e -> e + | Ok context -> + match get_base t ~log:context.Context.log base with + | Error _ as e -> e + | Ok (id, env) -> + let context = { context with env = context.env @ env } in + run_steps t ~context ~base:id ops let build t context spec = let r = build t context spec in - (r : (string, [ `Cancelled | `Msg of string ]) Lwt_result.t :> (string, [> `Cancelled | `Msg of string ]) Lwt_result.t) + (r : (string, [ `Cancelled | `Msg of string ]) result :> (string, [> `Cancelled | `Msg of string ]) result) let delete ?log t id = Store.delete ?log t.store id @@ -295,43 +301,55 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st let healthcheck ?(timeout=300.0) t = Os.with_pipe_from_child (fun ~r ~w -> let result = Docker.Cmd.version ~stderr:(`FD_move_safely w) () in - let r = Lwt_io.(of_fd ~mode:input) r ~close:Lwt.return in - Lwt_io.read r >>= fun err -> - result >>= function - | Ok _desc -> Lwt_result.return () - | Error (`Msg m) -> Lwt_result.fail (`Msg (Fmt.str "%s@.%s" m (String.trim err))) - ) >>!= fun () -> - let buffer = Buffer.create 1024 in - let log = log_to buffer in - (* Get the base image first, before starting the timer. *) - let switch = Lwt_switch.create () in - let context = Context.v ~shell:(Sandbox.shell t.sandbox) ~switch ~log ~src_dir:"/tmp" () in - healthcheck_base () >>= function healthcheck_base -> - get_base t ~log healthcheck_base >>= function - | Error (`Msg _) as x -> Lwt.return x - | Error `Cancelled -> failwith "Cancelled getting base image (shouldn't happen!)" - | Ok (id, env) -> - let context = { context with env } in - (* Start the timer *) - Lwt.async (fun () -> - Lwt_unix.sleep timeout >>= fun () -> - Lwt_switch.turn_off switch - ); - run_steps t ~context ~base:id healthcheck_ops >>= function - | Ok id -> Store.delete t.store id >|= Result.ok - | Error (`Msg msg) as x -> - let log = String.trim (Buffer.contents buffer) in - if log = "" then Lwt.return x - else Lwt.return (Fmt.error_msg "%s@.%s" msg log) - | Error `Cancelled -> Lwt.return (Fmt.error_msg "Timeout running healthcheck") - - let v ~store ~sandbox = - let store = Store.wrap store in + (* Read stderr data *) + let buf = Buffer.create 1024 in + let tmp = Bytes.create 4096 in + let rec read_all () = + match Unix.read r tmp 0 (Bytes.length tmp) with + | 0 -> () + | n -> Buffer.add_subbytes buf tmp 0 n; read_all () + | exception Unix.Unix_error (Unix.EINTR, _, _) -> read_all () + in + read_all (); + let err = Buffer.contents buf in + match result with + | Ok _desc -> Ok () + | Error (`Msg m) -> Error (`Msg (Fmt.str "%s@.%s" m (String.trim err))) + ) + |> (function + | Error _ as e -> e + | Ok () -> + let buffer = Buffer.create 1024 in + let log = log_to buffer in + (* Get the base image first, before starting the timer. *) + let cancelled, resolve_cancelled = Eio.Promise.create () in + let context = Context.v ~shell:(Sandbox.shell t.sandbox) ~cancelled ~log ~src_dir:"/tmp" () in + let healthcheck_base = healthcheck_base () in + match get_base t ~log healthcheck_base with + | Error (`Msg _) as x -> x + | Error `Cancelled -> failwith "Cancelled getting base image (shouldn't happen!)" + | Ok (id, env) -> + let context = { context with env } in + (* Start the timer *) + let _timeout_thread = Thread.create (fun () -> + Unix.sleepf timeout; + Eio.Promise.resolve resolve_cancelled () + ) () in + match run_steps t ~context ~base:id healthcheck_ops with + | Ok id -> Store.delete t.store id; Ok () + | Error (`Msg msg) -> + let log = String.trim (Buffer.contents buffer) in + if log = "" then Error (`Msg msg) + else Fmt.error_msg "%s@.%s" msg log + | Error `Cancelled -> Fmt.error_msg "Timeout running healthcheck" + ) + + let v ~sw ~store ~sandbox = + let store = Store.wrap ~sw store in { store; sandbox } let finish t = - Store.unwrap t.store; - Lwt.return_unit + Store.unwrap t.store end module Make_Docker (Raw_store : S.STORE) = struct @@ -355,7 +373,7 @@ module Make_Docker (Raw_store : S.STORE) = struct mount_secrets : Config.Secret.t list; } [@@deriving sexp_of] - let run t ~switch ~log ~cache run_input = + let run t ~cancelled ~log ~cache run_input = let id = sexp_of_run_input run_input |> Sexplib.Sexp.to_string_mach @@ -363,26 +381,28 @@ module Make_Docker (Raw_store : S.STORE) = struct |> Sha256.to_hex in let { base; workdir; user; env; cmd; shell; network; mount_secrets } = run_input in - Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log _ -> + Store.build t.store ?cancelled ~base ~id ~log (fun ~cancelled ~log _ -> let to_release = ref [] in - Lwt.finalize + Fun.protect (fun () -> - cache |> Lwt_list.map_s (fun { Obuilder_spec.Cache.id; target; buildkit_options = _ } -> - Store.cache ~user t.store id >|= fun (src, release) -> + let mounts = cache |> List.map (fun { Obuilder_spec.Cache.id; target; buildkit_options = _ } -> + let (src, release) = Store.cache ~user t.store id in to_release := release :: !to_release; { Config.Mount.ty = `Volume; src; dst = target; readonly = false } ) - >>= fun mounts -> + in let entrypoint, argv = Docker.setup_command ~entp:shell ~cmd:[cmd] in let config = Config.v ~cwd:workdir ~entrypoint ~argv ~hostname ~user ~env ~mounts ~mount_secrets ~network () in Os.with_pipe_to_child @@ fun ~r:stdin ~w:close_me -> - Lwt_unix.close close_me >>= fun () -> - Lwt_result.bind_lwt - (Docker_sandbox.run ~cancelled ~stdin ~log t.sandbox config id) - (fun () -> Docker_sandbox.teardown ~log ~commit:true id) + Unix.close close_me; + match Docker_sandbox.run ~cancelled ~stdin ~log t.sandbox config id with + | Error _ as e -> e + | Ok () -> + Docker_sandbox.teardown ~log ~commit:true id; + Ok () ) - (fun () -> - !to_release |> Lwt_list.iter_s (fun f -> f ()) + ~finally:(fun () -> + !to_release |> List.iter (fun f -> f ()) ) ) @@ -407,43 +427,46 @@ module Make_Docker (Raw_store : S.STORE) = struct | _ -> Fmt.error_msg "When copying multiple items, the destination must end with '/'" let copy t ~context ~base { Obuilder_spec.from; src; dst; exclude } = - let { Context.switch; src_dir; workdir; user; log; shell = _; env = _; scope; secrets = _ } = context in + let { Context.cancelled; src_dir; workdir; user; log; shell = _; env = _; scope; secrets = _ } = context in let dst = if Filename.is_relative dst then workdir // dst else dst in - begin + let src_dir_result = match from with - | `Context -> Lwt_result.return (`Context src_dir) + | `Context -> Ok (`Context src_dir) | `Build name -> match Scope.find_opt name scope with | None -> Fmt.failwith "Unknown build %S" name (* (shouldn't happen; gets caught earlier) *) | Some id -> - Store.result t.store id >>= function + match Store.result t.store id with | None -> - Lwt_result.fail (`Msg (Fmt.str "Build result %S not found" id)) + Error (`Msg (Fmt.str "Build result %S not found" id)) | Some dir -> - Lwt_result.return (`Build (id, dir)) - end >>!= fun src_dir -> - begin match src_dir with - | `Context src_dir -> sequence (List.map (Manifest.generate ~exclude ~src_dir) src) |> Lwt.return - | `Build (id, _) -> Docker_sandbox.manifest_from_build t.sandbox ~base:id ~exclude src workdir user - end >>= fun src_manifest -> - match Result.bind src_manifest (to_copy_op ~dst) with - | Error _ as e -> Lwt.return e - | Ok op -> - let details = { - base; - op; - user; - } in - let dst_dir = match op with `Copy_items (_, dst_dir) when Sys.win32 -> Some dst_dir | _ -> None in - (* Fmt.pr "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details); *) - let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in - Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log _ -> - match src_dir with - | `Context src_dir -> - Docker_sandbox.copy_from_context t.sandbox ~cancelled ~log op ~user ~src_dir ?dst_dir id - | `Build (from_id, _) -> - Docker_sandbox.copy_from_build t.sandbox ~cancelled ~log op ~user ~workdir ?dst_dir ~from_id id - ) + Ok (`Build (id, dir)) + in + match src_dir_result with + | Error _ as e -> e + | Ok src_dir -> + let src_manifest = match src_dir with + | `Context src_dir -> sequence (List.map (Manifest.generate ~exclude ~src_dir) src) + | `Build (id, _) -> Docker_sandbox.manifest_from_build t.sandbox ~base:id ~exclude src workdir user + in + (match Result.bind src_manifest (to_copy_op ~dst) with + | Error _ as e -> e + | Ok op -> + let details = { + base; + op; + user; + } in + let dst_dir = match op with `Copy_items (_, dst_dir) when Sys.win32 -> Some dst_dir | _ -> None in + (* Fmt.pr "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details); *) + let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in + Store.build t.store ?cancelled ~base ~id ~log (fun ~cancelled ~log _ -> + match src_dir with + | `Context src_dir -> + Docker_sandbox.copy_from_context t.sandbox ~cancelled ~log op ~user ~src_dir ?dst_dir id + | `Build (from_id, _) -> + Docker_sandbox.copy_from_build t.sandbox ~cancelled ~log op ~user ~workdir ?dst_dir ~from_id id + )) let pp_op ~(context:Context.t) f op = Fmt.pf f "@[%s: %a@]" context.workdir Obuilder_spec.pp_op op @@ -469,7 +492,7 @@ module Make_Docker (Raw_store : S.STORE) = struct (resolved_secret :: result) ) (Ok []) secrets let rec run_steps t ~(context:Context.t) ~base = function - | [] -> Lwt_result.return base + | [] -> Ok base | op :: ops -> context.log `Heading Fmt.(str "%a" (pp_op ~context) op); let k = run_steps t ops in @@ -479,16 +502,20 @@ module Make_Docker (Raw_store : S.STORE) = struct | `User user -> k ~base ~context:{context with user} | `Run { shell = cmd; cache; network; secrets = mount_secrets } -> let result = - let { Context.switch; workdir; user; env; shell; log; src_dir = _; scope = _; secrets } = context in + let { Context.cancelled; workdir; user; env; shell; log; src_dir = _; scope = _; secrets } = context in resolve_secrets secrets mount_secrets |> Result.map @@ fun mount_secrets -> - (switch, { base; workdir; user; env; cmd; shell; network; mount_secrets }, log) + (cancelled, { base; workdir; user; env; cmd; shell; network; mount_secrets }, log) in - Lwt.return result >>!= fun (switch, run_input, log) -> - run t ~switch ~log ~cache run_input >>!= fun base -> - k ~base ~context + (match result with + | Error _ as e -> e + | Ok (cancelled, run_input, log) -> + match run t ~cancelled ~log ~cache run_input with + | Error _ as e -> e + | Ok base -> k ~base ~context) | `Copy x -> - copy t ~context ~base x >>!= fun base -> - k ~base ~context + (match copy t ~context ~base x with + | Error _ as e -> e + | Ok base -> k ~base ~context) | `Env ((key, _) as e) -> let env = e :: (List.remove_assoc key context.env) in k ~base ~context:{context with env} @@ -503,33 +530,39 @@ module Make_Docker (Raw_store : S.STORE) = struct let get_base t ~log base = log `Heading (Fmt.str "(from %a)" Sexplib.Sexp.pp_hum (Atom base)); let id = Sha256.to_hex (Sha256.string base) in - Store.build t.store ~id ~log (fun ~cancelled:_ ~log:_ _ -> - Log.info (fun f -> f "Base image not present; importing %S…" base); - Docker.Cmd.pull (`Docker_image base) >>= fun () -> - Docker.Cmd.tag (`Docker_image base) (Docker.docker_image id) >>= fun () -> - Lwt_result.return () - ) - >>!= fun id -> - Lwt_result.return (id, []) + match Store.build t.store ~id ~log (fun ~cancelled:_ ~log:_ _ -> + Log.info (fun f -> f "Base image not present; importing %S..." base); + Docker.Cmd.pull (`Docker_image base); + Docker.Cmd.tag (`Docker_image base) (Docker.docker_image id); + Ok () + ) with + | Error _ as e -> e + | Ok id -> Ok (id, []) let rec build ~scope t context { Obuilder_spec.child_builds; from = base; ops } = let rec aux context = function - | [] -> Lwt_result.return context + | [] -> Ok context | (name, child_spec) :: child_builds -> - context.Context.log `Heading Fmt.(str "(build %S …)" name); - build ~scope t context child_spec >>!= fun child_result -> - context.Context.log `Note Fmt.(str "--> finished %S" name); - let context = Context.with_binding name child_result context in - aux context child_builds + context.Context.log `Heading Fmt.(str "(build %S ...)" name); + (match build ~scope t context child_spec with + | Error _ as e -> e + | Ok child_result -> + context.Context.log `Note Fmt.(str "--> finished %S" name); + let context = Context.with_binding name child_result context in + aux context child_builds) in - aux context child_builds >>!= fun context -> - get_base t ~log:context.Context.log base >>!= fun (id, env) -> - let context = { context with env = context.env @ env } in - run_steps t ~context ~base:id ops + match aux context child_builds with + | Error _ as e -> e + | Ok context -> + match get_base t ~log:context.Context.log base with + | Error _ as e -> e + | Ok (id, env) -> + let context = { context with env = context.env @ env } in + run_steps t ~context ~base:id ops let build t context spec = let r = build ~scope:[] t context spec in - (r : (string, [ `Cancelled | `Msg of string ]) Lwt_result.t :> (string, [> `Cancelled | `Msg of string ]) Lwt_result.t) + (r : (string, [ `Cancelled | `Msg of string ]) result :> (string, [> `Cancelled | `Msg of string ]) result) let delete ?log t id = Store.delete ?log t.store id @@ -560,42 +593,54 @@ module Make_Docker (Raw_store : S.STORE) = struct let healthcheck ?(timeout=if Sys.win32 then 300.0 else 300.0) t = Os.with_pipe_from_child (fun ~r ~w -> let result = Docker.Cmd.version ~stderr:(`FD_move_safely w) () in - let r = Lwt_io.(of_fd ~mode:input) r ~close:Lwt.return in - Lwt_io.read r >>= fun err -> - result >>= function - | Ok _desc -> Lwt_result.return () - | Error (`Msg m) -> Lwt_result.fail (`Msg (Fmt.str "%s@.%s" m (String.trim err))) - ) >>!= fun () -> - let buffer = Buffer.create 1024 in - let log = log_to buffer in - (* Get the base image first, before starting the timer. *) - let switch = Lwt_switch.create () in - let src_dir = if Sys.win32 then {|C:\TEMP|} else "/tmp" in - let context = Context.v ~shell:(Docker_sandbox.shell t.sandbox) ~switch ~log ~src_dir () in - healthcheck_base () >>= function healthcheck_base -> - get_base t ~log healthcheck_base >>= function - | Error (`Msg _) as x -> Lwt.return x - | Error `Cancelled -> failwith "Cancelled getting base image (shouldn't happen!)" - | Ok (id, env) -> - let context = { context with env } in - (* Start the timer *) - Lwt.async (fun () -> - Lwt_unix.sleep timeout >>= fun () -> - Lwt_switch.turn_off switch - ); - run_steps t ~context ~base:id healthcheck_ops >>= function - | Ok id -> Store.delete t.store id >|= Result.ok - | Error (`Msg msg) as x -> - let log = String.trim (Buffer.contents buffer) in - if log = "" then Lwt.return x - else Lwt.return (Fmt.error_msg "%s@.%s" msg log) - | Error `Cancelled -> Lwt.return (Fmt.error_msg "Timeout running healthcheck") - - let v ~store ~sandbox = - let store = Store.wrap store in + (* Read stderr data *) + let buf = Buffer.create 1024 in + let tmp = Bytes.create 4096 in + let rec read_all () = + match Unix.read r tmp 0 (Bytes.length tmp) with + | 0 -> () + | n -> Buffer.add_subbytes buf tmp 0 n; read_all () + | exception Unix.Unix_error (Unix.EINTR, _, _) -> read_all () + in + read_all (); + let err = Buffer.contents buf in + match result with + | Ok _desc -> Ok () + | Error (`Msg m) -> Error (`Msg (Fmt.str "%s@.%s" m (String.trim err))) + ) + |> (function + | Error _ as e -> e + | Ok () -> + let buffer = Buffer.create 1024 in + let log = log_to buffer in + (* Get the base image first, before starting the timer. *) + let cancelled, resolve_cancelled = Eio.Promise.create () in + let src_dir = if Sys.win32 then {|C:\TEMP|} else "/tmp" in + let context = Context.v ~shell:(Docker_sandbox.shell t.sandbox) ~cancelled ~log ~src_dir () in + let healthcheck_base = healthcheck_base () in + match get_base t ~log healthcheck_base with + | Error (`Msg _) as x -> x + | Error `Cancelled -> failwith "Cancelled getting base image (shouldn't happen!)" + | Ok (id, env) -> + let context = { context with env } in + (* Start the timer *) + let _timeout_thread = Thread.create (fun () -> + Unix.sleepf timeout; + Eio.Promise.resolve resolve_cancelled () + ) () in + match run_steps t ~context ~base:id healthcheck_ops with + | Ok id -> Store.delete t.store id; Ok () + | Error (`Msg msg) -> + let log = String.trim (Buffer.contents buffer) in + if log = "" then Error (`Msg msg) + else Fmt.error_msg "%s@.%s" msg log + | Error `Cancelled -> Fmt.error_msg "Timeout running healthcheck" + ) + + let v ~sw ~store ~sandbox = + let store = Store.wrap ~sw store in { store; sandbox } let finish t = - Store.unwrap t.store; - Lwt.return_unit + Store.unwrap t.store end diff --git a/lib/build.mli b/lib/build.mli index d12c3bf9..857eef02 100644 --- a/lib/build.mli +++ b/lib/build.mli @@ -2,7 +2,7 @@ module Context : sig type t val v : - ?switch:Lwt_switch.t -> + ?cancelled:unit Eio.Promise.t -> ?env:Config.env -> ?user:Obuilder_spec.user -> ?workdir:string -> @@ -12,7 +12,7 @@ module Context : sig src_dir:string -> unit -> t (** [context ~log ~src_dir] is a build context where copy operations read from the (host) directory [src_dir]. - @param switch Turn this off to cancel the build. + @param cancelled Resolve this to cancel the build. @param env Environment in which to run commands. @param user Container user to run as. @param workdir Directory in the container namespace for cwd. @@ -25,11 +25,11 @@ end module Make (Store : S.STORE) (Sandbox : S.SANDBOX) (_ : S.FETCHER) : sig include S.BUILDER with type context := Context.t - val v : store:Store.t -> sandbox:Sandbox.t -> t + val v : sw:Eio.Switch.t -> store:Store.t -> sandbox:Sandbox.t -> t end module Make_Docker (Store : S.STORE) : sig include S.BUILDER with type context := Context.t - val v : store:Store.t -> sandbox:Docker_sandbox.t -> t + val v : sw:Eio.Switch.t -> store:Store.t -> sandbox:Docker_sandbox.t -> t end diff --git a/lib/build_log.ml b/lib/build_log.ml index 7eb7abba..af118aba 100644 --- a/lib/build_log.ml +++ b/lib/build_log.ml @@ -1,109 +1,128 @@ -open Lwt.Infix - let max_chunk_size = 4096 type t = { mutable state : [ - | `Open of Lwt_unix.file_descr * unit Lwt_condition.t (* Fires after writing more data. *) + | `Open of Unix.file_descr * Eio.Condition.t * Eio.Mutex.t | `Readonly of string | `Empty - | `Finished + | `Finished of string option (* log file path, if the log was created from a file *) ]; + path : string option; (* the log file path, if known *) mutable len : int; } let with_dup fd fn = - let fd = Lwt_unix.dup ~cloexec:true fd in - Lwt.finalize - (fun () -> fn fd) - (fun () -> Lwt_unix.close fd) + let fd2 = Unix.dup ~cloexec:true fd in + Fun.protect + (fun () -> fn fd2) + ~finally:(fun () -> (try Unix.close fd2 with Unix.Unix_error _ -> ())) -let catch_cancel fn = - Lwt.catch fn - (function - | Lwt.Canceled -> Lwt_result.fail `Cancelled - | ex -> Lwt.reraise ex - ) +let tail ?cancelled t dst = + let is_cancelled () = + match cancelled with + | Some p -> Eio.Promise.is_resolved p + | None -> false + in -let tail ?switch t dst = - let rec readonly_tail ch buf = - Lwt_io.read_into ch buf 0 max_chunk_size >>= function - | 0 -> Lwt_result.return () - | n -> dst (Bytes.sub_string buf 0 n); readonly_tail ch buf + let rec readonly_tail fd buf = + if is_cancelled () then Error `Cancelled + else + match Unix.read fd buf 0 max_chunk_size with + | 0 -> Ok () + | n -> dst (Bytes.sub_string buf 0 n); readonly_tail fd buf in - let rec open_tail fd cond buf i = - match switch with - | Some sw when not (Lwt_switch.is_on sw) -> Lwt_result.fail `Cancelled - | Some _ | None -> + let rec open_tail fd cond mutex buf i = + if is_cancelled () then Error `Cancelled + else let avail = min (t.len - i) max_chunk_size in if avail > 0 then ( - Lwt_unix.pread fd ~file_offset:i buf 0 avail >>= fun n -> + let n = ExtUnix.All.all_pread fd i buf 0 avail in dst (Bytes.sub_string buf 0 n); - open_tail fd cond buf (i + avail) + open_tail fd cond mutex buf (i + avail) ) else ( match t.state with - | `Open _ -> Lwt_condition.wait cond >>= fun () -> open_tail fd cond buf i - | `Readonly _ | `Empty | `Finished -> Lwt_result.return () + | `Open _ -> + Eio.Mutex.lock mutex; + Fun.protect + (fun () -> Eio.Condition.await cond mutex) + ~finally:(fun () -> Eio.Mutex.unlock mutex); + open_tail fd cond mutex buf i + | `Readonly _ | `Empty | `Finished _ -> Ok () ) in - let interrupt th = - catch_cancel @@ fun () -> - Lwt_switch.add_hook_or_exec switch (fun () -> Lwt.cancel th; Lwt.return_unit) >>= fun () -> - th - in - match t.state with - | `Finished -> invalid_arg "tail: log is finished!" + | `Finished (Some path) -> + (* Build completed before we started tailing. Read the saved log file. *) + let fd = Unix.openfile path [Unix.O_RDONLY; Unix.O_CLOEXEC] 0 in + Fun.protect + (fun () -> + let buf = Bytes.create max_chunk_size in + readonly_tail fd buf) + ~finally:(fun () -> (try Unix.close fd with Unix.Unix_error _ -> ())) + | `Finished None | `Empty -> Ok () | `Readonly path -> - let flags = [Unix.O_RDONLY; Unix.O_NONBLOCK; Unix.O_CLOEXEC] in - Lwt_io.(with_file ~mode:input ~flags) path @@ fun ch -> - let buf = Bytes.create max_chunk_size in - interrupt (readonly_tail ch buf) - | `Empty -> Lwt_result.return () - | `Open (fd, cond) -> - (* Dup [fd], which can still work after [fd] is closed. *) + let fd = Unix.openfile path [Unix.O_RDONLY; Unix.O_CLOEXEC] 0 in + Fun.protect + (fun () -> + let buf = Bytes.create max_chunk_size in + readonly_tail fd buf) + ~finally:(fun () -> (try Unix.close fd with Unix.Unix_error _ -> ())) + | `Open (fd, cond, mutex) -> with_dup fd @@ fun fd -> let buf = Bytes.create max_chunk_size in - interrupt (open_tail fd cond buf 0) + match cancelled with + | None -> open_tail fd cond mutex buf 0 + | Some cancelled_p -> + (* Race between tailing the log and being cancelled. + We need Fiber.first because open_tail blocks on the condition, + and won't check is_cancelled until woken up. *) + Eio.Fiber.first + (fun () -> open_tail fd cond mutex buf 0) + (fun () -> + Eio.Promise.await cancelled_p; + (* Wake up open_tail so it can be cancelled cleanly *) + Eio.Condition.broadcast cond; + Error `Cancelled) let create path = - Lwt_unix.openfile path Lwt_unix.[O_CREAT; O_TRUNC; O_RDWR; O_CLOEXEC] 0o666 >|= fun fd -> - let cond = Lwt_condition.create () in + let fd = Unix.openfile path [Unix.O_CREAT; Unix.O_TRUNC; Unix.O_RDWR; Unix.O_CLOEXEC] 0o666 in + let cond = Eio.Condition.create () in + let mutex = Eio.Mutex.create () in { - state = `Open (fd, cond); + state = `Open (fd, cond, mutex); + path = Some path; len = 0; } let finish t = match t.state with - | `Finished -> invalid_arg "Log is already finished!" - | `Open (fd, cond) -> - t.state <- `Finished; - Lwt_unix.close fd >|= fun () -> - Lwt_condition.broadcast cond () + | `Finished _ -> invalid_arg "Log is already finished!" + | `Open (fd, cond, _mutex) -> + t.state <- `Finished t.path; + Unix.close fd; + Eio.Condition.broadcast cond | `Readonly _ -> - t.state <- `Finished; - Lwt.return_unit + t.state <- `Finished t.path | `Empty -> - Lwt.return_unit (* Empty can be reused *) + () (* Empty can be reused *) let write t data = match t.state with - | `Finished -> invalid_arg "write: log is finished!" + | `Finished _ -> invalid_arg "write: log is finished!" | `Readonly _ | `Empty -> invalid_arg "Log is read-only!" - | `Open (fd, cond) -> + | `Open (fd, cond, _mutex) -> let len = String.length data in - Os.write_all fd (Bytes.of_string data) 0 len >>= fun () -> + Os.write_all_string fd data 0 len; t.len <- t.len + len; - Lwt_condition.broadcast cond (); - Lwt.return_unit + Eio.Condition.broadcast cond let of_saved path = - Lwt_unix.lstat path >|= fun stat -> + let stat = Unix.lstat path in { state = `Readonly path; + path = Some path; len = stat.st_size; } @@ -112,14 +131,15 @@ let printf t fmt = let empty = { state = `Empty; + path = None; len = 0; } let copy ~src ~dst = let buf = Bytes.create max_chunk_size in let rec aux () = - Lwt_unix.read src buf 0 (Bytes.length buf) >>= function - | 0 -> Lwt.return_unit - | n -> write dst (Bytes.sub_string buf 0 n) >>= aux + match Unix.read src buf 0 (Bytes.length buf) with + | 0 -> () + | n -> write dst (Bytes.sub_string buf 0 n); aux () in aux () diff --git a/lib/build_log.mli b/lib/build_log.mli index 23c88136..ad488490 100644 --- a/lib/build_log.mli +++ b/lib/build_log.mli @@ -3,20 +3,20 @@ type t (** {2 Creating logs} *) -val create : string -> t Lwt.t +val create : string -> t (** [create path] creates a new log file at temporary location [path]. Call [finish] when done to release the file descriptor. *) -val finish : t -> unit Lwt.t +val finish : t -> unit (** [finish t] marks log [t] as finished. If it was open for writing, this closes the file descriptor. It cannot be used after this (for reading or writing), although existing background operations (e.g. [tail]) can continue successfully. *) -val write : t -> string -> unit Lwt.t +val write : t -> string -> unit (** [write t data] appends [data] to the log. *) -val printf : t -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a +val printf : t -> ('a, Format.formatter, unit, unit) format4 -> 'a (** [printf t fmt] is a wrapper for [write t] that takes a format string. *) (** {2 Reading logs} *) @@ -24,16 +24,16 @@ val printf : t -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a val empty : t (** [empty] is a read-only log with no content. *) -val of_saved : string -> t Lwt.t +val of_saved : string -> t (** [of_saved path] is a read-only log which reads from [path]. *) -val tail : ?switch:Lwt_switch.t -> t -> (string -> unit) -> (unit, [> `Cancelled]) Lwt_result.t +val tail : ?cancelled:unit Eio.Promise.t -> t -> (string -> unit) -> (unit, [> `Cancelled]) result (** [tail t dst] streams data from the log to [dst]. This can be called at any time before [finish] is called. - @param switch Abort if this is turned off. *) + @param cancelled Abort if this promise is resolved. *) (* {2 Copying to logs} *) -val copy : src:Lwt_unix.file_descr -> dst:t -> unit Lwt.t +val copy : src:Unix.file_descr -> dst:t -> unit (** [copy ~src ~dst] reads bytes from the [src] file descriptor and writes them to the build log [dst]. *) diff --git a/lib/db_store.ml b/lib/db_store.ml index a2be43b5..bfea3c4d 100644 --- a/lib/db_store.ml +++ b/lib/db_store.ml @@ -1,14 +1,11 @@ -open Lwt.Infix - let ( / ) = Filename.concat -let ( >>!= ) = Lwt_result.bind module Make (Raw : S.STORE) = struct type build = { mutable users : int; - set_cancelled : unit Lwt.u; (* Resolve this to cancel (when [users = 0]). *) - log : Build_log.t Lwt.t; - result : (([`Loaded | `Saved] * S.id), [`Cancelled | `Msg of string]) Lwt_result.t; + set_cancelled : unit Eio.Promise.u; (* Resolve this to cancel (when [users = 0]). *) + log : Build_log.t Eio.Promise.t; + result : (([`Loaded | `Saved] * S.id), [`Cancelled | `Msg of string]) result Eio.Promise.t; base : string option; } @@ -17,6 +14,7 @@ module Make (Raw : S.STORE) = struct type t = { raw : Raw.t; dao : Dao.t; + sw : Eio.Switch.t; (* Invariants for builds in [in_progress]: - [result] is still pending and [log] isn't finished. - [set_cancelled] is resolved iff [users = 0]. *) @@ -26,21 +24,20 @@ module Make (Raw : S.STORE) = struct } let finish_log ~set_log log = - match Lwt.state log with - | Lwt.Return log -> + match Eio.Promise.peek log with + | Some log -> Build_log.finish log - | Lwt.Fail _ -> - Lwt.return_unit - | Lwt.Sleep -> - Lwt.wakeup_exn set_log (Failure "Build ended without setting a log!"); - Lwt.return_unit + | None -> + (* Build ended without setting a log. Provide an empty log so + anyone awaiting the log promise can continue. *) + Eio.Promise.resolve set_log Build_log.empty let dec_ref build = build.users <- build.users - 1; - if Lwt.is_sleeping build.result then ( + if not (Eio.Promise.is_resolved build.result) then ( Log.info (fun f -> f "User cancelled job (users now = %d)" build.users); if build.users = 0 then ( - Lwt.wakeup_later build.set_cancelled () + Eio.Promise.resolve build.set_cancelled () ) ) @@ -48,31 +45,33 @@ module Make (Raw : S.STORE) = struct or by doing a new build using [fn]. We only run one instance of this at a time for a single [id]. *) let get_build t ~base ~id ~cancelled ~set_log fn = - Raw.result t.raw id >>= function + match Raw.result t.raw id with | Some _ -> t.cache_hit <- t.cache_hit + 1; let now = Unix.(gmtime (gettimeofday ())) in Dao.set_used t.dao ~id ~now; - Raw.log_file t.raw id >>= fun log_file -> - begin + let log_file = Raw.log_file t.raw id in + let log = if Sys.file_exists log_file then Build_log.of_saved log_file - else Lwt.return Build_log.empty - end >>= fun log -> - Lwt.wakeup set_log log; - Lwt_result.return (`Loaded, id) + else Build_log.empty + in + Eio.Promise.resolve set_log log; + Ok (`Loaded, id) | None -> t.cache_miss <- t.cache_miss + 1; Raw.build t.raw ?base ~id (fun dir -> - Raw.log_file t.raw id >>= fun log_file -> + let log_file = Raw.log_file t.raw id in if Sys.file_exists log_file then Unix.unlink log_file; - Build_log.create log_file >>= fun log -> - Lwt.wakeup set_log log; + let log = Build_log.create log_file in + Eio.Promise.resolve set_log log; fn ~cancelled ~log dir ) - >>!= fun () -> - let now = Unix.(gmtime (gettimeofday () )) in - Dao.add t.dao ?parent:base ~id ~now; - Lwt_result.return (`Saved, id) + |> (function + | Error _ as e -> e + | Ok () -> + let now = Unix.(gmtime (gettimeofday () )) in + Dao.add t.dao ?parent:base ~id ~now; + Ok (`Saved, id)) let log_ty client_log ~id = function | `Loaded -> client_log `Note (Fmt.str "---> using %S from cache" id) @@ -84,50 +83,100 @@ module Make (Raw : S.STORE) = struct [get_build] should set the log being used as soon as it knows it (this can't happen until we've created the temporary directory in the underlying store). *) - let rec build ?switch t ?base ~id ~log:client_log fn = + let rec build ?cancelled t ?base ~id ~log:client_log fn = match Builds.find_opt id t.in_progress with | Some existing when existing.users = 0 -> client_log `Note ("Waiting for previous build to finish cancelling"); - assert (Lwt.is_sleeping existing.result); - existing.result >>= fun _ -> - build ?switch t ?base ~id ~log:client_log fn + assert (not (Eio.Promise.is_resolved existing.result)); + let _ = Eio.Promise.await existing.result in + build ?cancelled t ?base ~id ~log:client_log fn | Some existing -> (* We're already building this, and the build hasn't been cancelled. *) existing.users <- existing.users + 1; - existing.log >>= fun log -> - Lwt_switch.add_hook_or_exec switch (fun () -> dec_ref existing; Lwt.return_unit) >>= fun () -> - Build_log.tail ?switch log (client_log `Output) >>!= fun () -> - existing.result >>!= fun (ty, r) -> - log_ty client_log ~id ty; - Lwt_result.return r + let log = Eio.Promise.await existing.log in + (* Hook: when cancelled is resolved, dec_ref. + Also exit when the build result is resolved so we don't block the switch. *) + (match cancelled with + | Some p -> + Eio.Fiber.fork ~sw:t.sw (fun () -> + Eio.Fiber.first + (fun () -> + Eio.Promise.await p; + dec_ref existing) + (fun () -> + ignore (Eio.Promise.await existing.result))) + | None -> ()); + let await_result () = + match Eio.Promise.await existing.result with + | Error _ as e -> e + | Ok (ty, r) -> + log_ty client_log ~id ty; + Ok r + in + (match Build_log.tail ?cancelled log (client_log `Output) with + | Error `Cancelled -> + (* Build may have completed before we noticed the cancellation. + If a result is available, prefer it over the cancellation. *) + (match Eio.Promise.peek existing.result with + | Some (Ok (ty, r)) -> + log_ty client_log ~id ty; + Ok r + | Some (Error _ as e) -> e + | None -> Error `Cancelled) + | Error _ as e -> e + | Ok () -> await_result ()) | None -> - let result, set_result = Lwt.wait () in - let log, set_log = Lwt.wait () in - let tail_log = log >>= fun log -> Build_log.tail ?switch log (client_log `Output) in - let cancelled, set_cancelled = Lwt.wait () in + let result, set_result = Eio.Promise.create () in + let log, set_log = Eio.Promise.create () in + let cancelled_p, set_cancelled = Eio.Promise.create () in let build = { users = 1; set_cancelled; log; result; base } in - Lwt_switch.add_hook_or_exec switch (fun () -> dec_ref build; Lwt.return_unit) >>= fun () -> + (* Hook: when cancelled is resolved, dec_ref. + Also exit when the build result is resolved so we don't block the switch. *) + (match cancelled with + | Some p -> + Eio.Fiber.fork ~sw:t.sw (fun () -> + Eio.Fiber.first + (fun () -> + Eio.Promise.await p; + dec_ref build) + (fun () -> + ignore (Eio.Promise.await build.result))) + | None -> ()); t.in_progress <- Builds.add id build t.in_progress; - Lwt.async + Eio.Fiber.fork ~sw:t.sw (fun () -> - Lwt.try_bind - (fun () -> get_build t ~base ~id ~cancelled ~set_log fn) - (fun r -> - t.in_progress <- Builds.remove id t.in_progress; - Lwt.wakeup_later set_result r; - finish_log ~set_log log - ) - (fun ex -> - Log.info (fun f -> f "Build %S error: %a" id Fmt.exn ex); - t.in_progress <- Builds.remove id t.in_progress; - Lwt.wakeup_later_exn set_result ex; - finish_log ~set_log log - ) + match get_build t ~base ~id ~cancelled:cancelled_p ~set_log fn with + | r -> + t.in_progress <- Builds.remove id t.in_progress; + Eio.Promise.resolve set_result r; + finish_log ~set_log log + | exception ex -> + Log.info (fun f -> f "Build %S error: %a" id Fmt.exn ex); + t.in_progress <- Builds.remove id t.in_progress; + Eio.Promise.resolve set_result (Error (`Msg (Fmt.str "Build error: %a" Fmt.exn ex))); + finish_log ~set_log log ); - tail_log >>!= fun () -> - result >>!= fun (ty, r) -> - log_ty client_log ~id ty; - Lwt_result.return r + (* Tail the log *) + let log_v = Eio.Promise.await log in + let await_result () = + match Eio.Promise.await result with + | Error _ as e -> e + | Ok (ty, r) -> + log_ty client_log ~id ty; + Ok r + in + (match Build_log.tail ?cancelled log_v (client_log `Output) with + | Error `Cancelled -> + (* Build may have completed before we noticed the cancellation. + If a result is available, prefer it over the cancellation. *) + (match Eio.Promise.peek result with + | Some (Ok (ty, r)) -> + log_ty client_log ~id ty; + Ok r + | Some (Error _ as e) -> e + | None -> Error `Cancelled) + | Error _ as e -> e + | Ok () -> await_result ()) let result t id = Raw.result t.raw id let count t = Dao.count t.dao @@ -144,9 +193,9 @@ module Make (Raw : S.STORE) = struct Log.warn (fun f -> f "ID %S not in database!" id); Raw.delete t.raw id (* Try removing it anyway *) | Ok deps -> - Lwt_list.iter_s aux deps >>= fun () -> + List.iter aux deps; log id; - Raw.delete t.raw id >|= fun () -> + Raw.delete t.raw id; Dao.delete t.dao id in aux id @@ -158,34 +207,34 @@ module Make (Raw : S.STORE) = struct | Some base -> base = id | None -> false) t.in_progress |> Builds.is_empty) items in match items with - | [] -> Lwt.return 0 + | [] -> 0 | id :: _ -> log id; - Raw.delete t.raw id >>= fun () -> - Dao.delete t.dao id ; - Lwt.return 1 + Raw.delete t.raw id; + Dao.delete t.dao id; + 1 let prune ?log t ~before limit = Log.info (fun f -> f "Pruning %d items" limit); let rec aux count = - if count >= limit then Lwt.return count (* Pruned everything we wanted to *) + if count >= limit then count (* Pruned everything we wanted to *) else ( - prune_lru ?log t ~before limit >>= function - | 0 -> Lwt.return count (* Nothing left to prune *) + match prune_lru ?log t ~before limit with + | 0 -> count (* Nothing left to prune *) | n -> aux (count + n) ) in - aux 0 >>= fun n -> - Raw.complete_deletes t.raw >>= fun () -> + let n = aux 0 in + Raw.complete_deletes t.raw; Log.info (fun f -> f "Pruned %d items" n); - Lwt.return n + n - let wrap raw = + let wrap ~sw raw = let db_dir = Raw.state_dir raw / "db" in Os.ensure_dir db_dir; let db = Db.of_dir (db_dir / "db.sqlite") in let dao = Dao.create db in - { raw; dao; in_progress = Builds.empty; cache_hit = 0; cache_miss = 0 } + { raw; dao; sw; in_progress = Builds.empty; cache_hit = 0; cache_miss = 0 } let unwrap t = Dao.close t.dao diff --git a/lib/db_store.mli b/lib/db_store.mli index 74937a02..2f5851aa 100644 --- a/lib/db_store.mli +++ b/lib/db_store.mli @@ -2,27 +2,27 @@ module Make (Raw : S.STORE) : sig type t val build : - ?switch:Lwt_switch.t -> + ?cancelled:unit Eio.Promise.t -> t -> ?base:S.id -> id:S.id -> log:S.logger -> - (cancelled:unit Lwt.t -> log:Build_log.t -> string -> (unit, [`Cancelled | `Msg of string]) Lwt_result.t) -> - (S.id, [`Cancelled | `Msg of string]) Lwt_result.t + (cancelled:unit Eio.Promise.t -> log:Build_log.t -> string -> (unit, [`Cancelled | `Msg of string]) result) -> + (S.id, [`Cancelled | `Msg of string]) result (** [build t ~id ~log fn] ensures that [id] is cached, using [fn ~cancelled ~log dir] to build it if not. If [cancelled] resolves, the build should be cancelled. If [id] is already in the process of being built, this just attaches to the existing build. - @param switch Turn this off if you no longer need the result. The build + @param cancelled Resolve this if you no longer need the result. The build will be cancelled if no-one else is waiting for it. *) - val delete : ?log:(S.id -> unit) -> t -> S.id -> unit Lwt.t + val delete : ?log:(S.id -> unit) -> t -> S.id -> unit - val prune : ?log:(S.id -> unit) -> t -> before:Unix.tm -> int -> int Lwt.t + val prune : ?log:(S.id -> unit) -> t -> before:Unix.tm -> int -> int - val result : t -> S.id -> string option Lwt.t + val result : t -> S.id -> string option val count : t -> int64 - val df : t -> float Lwt.t + val df : t -> float val root : t -> string @@ -32,9 +32,9 @@ module Make (Raw : S.STORE) : sig user : Obuilder_spec.user -> t -> string -> - (string * (unit -> unit Lwt.t)) Lwt.t + (string * (unit -> unit)) - val wrap : Raw.t -> t + val wrap : sw:Eio.Switch.t -> Raw.t -> t val unwrap : t -> unit end diff --git a/lib/docker.ml b/lib/docker.ml index 601569d2..b4694896 100644 --- a/lib/docker.ml +++ b/lib/docker.ml @@ -1,5 +1,3 @@ -open Lwt.Syntax - type ids = [ | `Docker_image of string | `Docker_container of string | `Docker_volume of string | `Obuilder_id of string @@ -102,8 +100,8 @@ module Cmd = struct let commit ?stdout ?stderr (`Docker_image base_image) (`Docker_container container) (`Docker_image target_image) = (* Restore CMD and ENTRYPOINT *) - let* entrypoint = pread ["inspect"; "--type=image"; "--format={{json .Config.Entrypoint }}"; "--"; base_image] in - let* cmd = pread ["inspect"; "--type=image"; "--format={{json .Config.Cmd }}"; "--"; base_image] in + let entrypoint = pread ["inspect"; "--type=image"; "--format={{json .Config.Entrypoint }}"; "--"; base_image] in + let cmd = pread ["inspect"; "--type=image"; "--format={{json .Config.Cmd }}"; "--"; base_image] in let entrypoint, cmd = String.trim entrypoint, String.trim cmd in let argv = [ "--"; container; target_image ] in let argv = if entrypoint = "null" then argv else ("--change=ENTRYPOINT " ^ entrypoint) :: argv in @@ -167,13 +165,13 @@ module Cmd = struct pread ("volume" :: "rm" :: "--" :: volumes) let volume_containers ?stderr (`Docker_volume name) = - let+ names = pread ?stderr (["ps"; "-a"; "--filter"; "volume=" ^ name; "--format={{ .Names }}"]) in + let names = pread ?stderr (["ps"; "-a"; "--filter"; "volume=" ^ name; "--format={{ .Names }}"]) in names |> String.trim |> String.split_on_char '\n' |> List.map (fun id -> `Docker_container id) let mount_point ?stderr name = - let* s = volume ?stderr (`Inspect ([name], `Mountpoint)) in - Lwt.return (String.trim s) + let s = volume ?stderr (`Inspect ([name], `Mountpoint)) in + String.trim s let rmi ?stdout ?stderr images = exec' ?stdout ?stderr ("rmi" :: (List.rev_map extract_name images)) @@ -187,22 +185,19 @@ module Cmd = struct exec_result' ?stdout ?stderr ("manifest" :: "rm" :: (List.rev_map extract_name manifests)) let obuilder_images ?stderr ?tmp () = - let* images = pread ?stderr ["images"; "--format={{ .Repository }}"; image_name ?tmp "*"] in + let images = pread ?stderr ["images"; "--format={{ .Repository }}"; image_name ?tmp "*"] in String.split_on_char '\n' images |> List.filter_map (function "" -> None | id -> Some (`Docker_image id)) - |> Lwt.return let obuilder_containers ?stderr () = - let* containers = pread ?stderr ["container"; "ls"; "--all"; "--filter"; "name=^" ^ !prefix; "-q"] in + let containers = pread ?stderr ["container"; "ls"; "--all"; "--filter"; "name=^" ^ !prefix; "-q"] in String.split_on_char '\n' containers |> List.filter_map (function "" -> None | id -> Some (`Docker_container id)) - |> Lwt.return let obuilder_volumes ?stderr ?(prefix=(!prefix)) () = - let* volumes = volume ?stderr (`List (Some ("name=^" ^ prefix))) in + let volumes = volume ?stderr (`List (Some ("name=^" ^ prefix))) in String.split_on_char '\n' volumes |> List.filter_map (function "" -> None | id -> Some (`Docker_volume id)) - |> Lwt.return let obuilder_caches_tmp ?stderr () = obuilder_volumes ?stderr ~prefix:(cache_prefix () ^ "tmp-") () @@ -217,18 +212,16 @@ module Cmd_log = struct let with_stderr_log ~log fn = Os.with_pipe_from_child @@ fun ~r:err_r ~w:err_w -> let stderr = `FD_move_safely err_w in - let copy_log = Build_log.copy ~src:err_r ~dst:log in - let* r = fn ~stderr in - let+ () = copy_log in + let r = fn ~stderr in + Build_log.copy ~src:err_r ~dst:log; r let with_log ~log fn = Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w -> let stdout = `FD_move_safely out_w in let stderr = stdout in - let copy_log = Build_log.copy ~src:out_r ~dst:log in - let* r = fn ~stdout ~stderr in - let+ () = copy_log in + let r = fn ~stdout ~stderr in + Build_log.copy ~src:out_r ~dst:log; r let version ~log () = @@ -334,27 +327,28 @@ let cp_between_volumes ~base ~src ~dst = Os.with_pipe_between_children @@ fun ~r ~w -> let proc = Cmd.run_result' ~stdin:(`FD_move_safely r) ~rm:true mounts_proc base [tar; "-xp"; "-C"; root ^ "dst"; "-f"; "-"] and send = Cmd.run_result' ~stdout:(`FD_move_safely w) ~rm:true mounts_send base [tar; "-c"; "-C"; root ^ "src"; "-f"; "-"; "."] in - let open Lwt_result.Syntax in - let* () = proc in - let+ () = send in - () + match proc with + | Error _ as e -> e + | Ok () -> + match send with + | Error _ as e -> e + | Ok () -> Ok () let with_container ~log base fn = - let* cid = Os.with_pipe_from_child (fun ~r ~w -> + let cid = Os.with_pipe_from_child (fun ~r ~w -> (* We might need to do a pull here, so log the output to show progress. *) - let copy = Build_log.copy ~src:r ~dst:log in - let* cid = Cmd.create ~stderr:(`FD_move_safely w) (`Docker_image base) in - let+ () = copy in + let cid = Cmd.create ~stderr:(`FD_move_safely w) (`Docker_image base) in + Build_log.copy ~src:r ~dst:log; String.trim cid ) in - Lwt.finalize + Fun.protect (fun () -> fn cid) - (fun () -> Cmd.rm ~stdout:`Dev_null [`Docker_container cid]) + ~finally:(fun () -> Cmd.rm ~stdout:`Dev_null [`Docker_container cid]) module Extract = struct - let export_env base : Config.env Lwt.t = - let+ env = + let export_env base : Config.env = + let env = pread ["image"; "inspect"; "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|}; "--"; base] in @@ -368,13 +362,10 @@ module Extract = struct ) let fetch ~log ~root:_ ~rootfs base = - let* () = with_container ~log base (fun cid -> + with_container ~log base (fun cid -> Os.with_pipe_between_children @@ fun ~r ~w -> - let exporter = Cmd.export ~stdout:(`FD_move_safely w) (`Docker_container cid) in - let tar = Os.sudo ~stdin:(`FD_move_safely r) ["tar"; "-C"; rootfs; "-xf"; "-"] in - let* () = exporter in - tar - ) - in + Cmd.export ~stdout:(`FD_move_safely w) (`Docker_container cid); + Os.sudo ~stdin:(`FD_move_safely r) ["tar"; "-C"; rootfs; "-xf"; "-"] + ); export_env base end diff --git a/lib/docker.mli b/lib/docker.mli index e15bca78..89f57fc7 100644 --- a/lib/docker.mli +++ b/lib/docker.mli @@ -50,7 +50,7 @@ val setup_command : entp:string list -> cmd:string list -> string * string list val cp_between_volumes : base:[< `Docker_image of string ] -> src:[< `Docker_volume of string] -> dst:[`Docker_volume of string] -> - (unit, [> `Msg of string]) Lwt_result.t + (unit, [> `Msg of string]) result (** Wrappers for various Docker client commands, exposing file descriptors. *) module Cmd : S.DOCKER_CMD diff --git a/lib/docker_sandbox.ml b/lib/docker_sandbox.ml index b6874503..b8d6a4cd 100644 --- a/lib/docker_sandbox.ml +++ b/lib/docker_sandbox.ml @@ -1,5 +1,3 @@ -open Lwt.Syntax -let ( >>!= ) = Lwt_result.bind open Sexplib.Conv include S.Sandbox_default @@ -85,7 +83,7 @@ let secrets_layer ~log mount_secrets base_image container docker_argv = (0, []) mount_secrets in if mount_secrets = [] then - Lwt_result.ok Lwt.return_unit + Ok () else let docker_argv, argv = if Sys.win32 then @@ -95,67 +93,54 @@ let secrets_layer ~log mount_secrets base_image container docker_argv = docker_argv @ ["--entrypoint"; {|/bin/sh|}], ["-c"; String.concat " " argv] in - - Lwt_result.bind_lwt - (Docker.Cmd_log.run_result ~log ~name:container docker_argv base_image argv) - (fun () -> - let* () = Docker.Cmd_log.commit ~log base_image container base_image in - Docker.Cmd_log.rm ~log [container]) + match Docker.Cmd_log.run_result ~log ~name:container docker_argv base_image argv with + | Error _ as e -> e + | Ok () -> + Docker.Cmd_log.commit ~log base_image container base_image; + Docker.Cmd_log.rm ~log [container]; + Ok () let teardown ~log ~commit id = let container = Docker.docker_container id in let base_image = Docker.docker_image ~tmp:true id in let target_image = Docker.docker_image id in - let* () = - if commit then Docker.Cmd_log.commit ~log base_image container target_image - else Lwt.return_unit - in + if commit then Docker.Cmd_log.commit ~log base_image container target_image; Docker.Cmd_log.rm ~log [container] let run ~cancelled ?stdin ~log t config (id:S.id) = - Lwt_io.with_temp_dir ~perm:0o700 ~prefix:"obuilder-docker-" @@ fun tmp -> + let tmp = Filename.temp_dir ~temp_dir:(Filename.get_temp_dir_name ()) "obuilder-docker-" "" in + Fun.protect ~finally:(fun () -> Os.rm ~directory:tmp) @@ fun () -> + Unix.chmod tmp 0o700; let docker_argv, argv = Docker_config.make config ~config_dir:tmp t in - let* _ = Lwt_list.fold_left_s + let _ = List.fold_left (fun id Config.Secret.{value; _} -> Os.ensure_dir (tmp / "secrets"); Os.ensure_dir (tmp / secret_dir id); - let+ () = Os.write_file ~path:(tmp / secret_dir id / "secret") value in + Os.write_file ~path:(tmp / secret_dir id / "secret") value; id + 1 ) 0 config.mount_secrets in let container = Docker.docker_container id in let base_image = Docker.docker_image ~tmp:true id in - let proc = - Lwt_result.bind - (secrets_layer ~log config.Config.mount_secrets base_image container docker_argv) - (fun () -> - let* r = Docker.Cmd.exists container in - let* () = - if Result.is_ok r then begin - let `Docker_container name = container in - Log.warn (fun f -> f "Removing left over container %s." name); - Docker.Cmd.rm [ container ] - end else - Lwt.return_unit - in - let stdin = Option.map (fun x -> `FD_move_safely x) stdin in - Docker.Cmd_log.run_result ~log ?stdin ~name:container docker_argv base_image argv) - in - Lwt.on_termination cancelled (fun () -> - let aux () = - if Lwt.is_sleeping proc then ( - Docker.Cmd_log.rm ~log [container] - ) else Lwt.return_unit (* Process has already finished *) - in - Lwt.async aux - ); - let* r = proc in - let+ () = match r with - | Ok () -> Lwt.return_unit - | _ -> Docker.Cmd_log.rm ~log [container] + let r = + match secrets_layer ~log config.Config.mount_secrets base_image container docker_argv with + | Error _ as e -> e + | Ok () -> + let r = Docker.Cmd.exists container in + if Result.is_ok r then begin + let `Docker_container name = container in + Log.warn (fun f -> f "Removing left over container %s." name); + Docker.Cmd.rm [ container ] + end; + let stdin = Option.map (fun x -> `FD_move_safely x) stdin in + Docker.Cmd_log.run_result ~log ?stdin ~name:container docker_argv base_image argv in - if Lwt.is_sleeping cancelled then (r :> (unit, [`Msg of string | `Cancelled]) result) - else Error `Cancelled + (* Check cancellation after process completes *) + (match r with + | Ok () -> () + | _ -> Docker.Cmd_log.rm ~log [container]); + if Eio.Promise.is_resolved cancelled then Error `Cancelled + else (r :> (unit, [`Msg of string | `Cancelled]) result) (* Duplicate of Build.hostname. *) let hostname = "builder" @@ -187,10 +172,12 @@ let manifest_from_build t ~base ~exclude src workdir user = () in let docker_args, args = Docker_config.make config t in - Docker.Cmd.run_pread_result ~rm:true docker_args (Docker.docker_image base) args >>!= fun manifests -> - match Parsexp.Many.parse_string manifests with - | Ok ts -> List.rev_map Manifest.t_of_sexp ts |> Lwt_result.return - | Error e -> Lwt_result.fail (`Msg (Parsexp.Parse_error.message e)) + match Docker.Cmd.run_pread_result ~rm:true docker_args (Docker.docker_image base) args with + | Error _ as e -> e + | Ok manifests -> + match Parsexp.Many.parse_string manifests with + | Ok ts -> Ok (List.rev_map Manifest.t_of_sexp ts) + | Error e -> Error (`Msg (Parsexp.Parse_error.message e)) let manifest_files_from op fd = let copy_root manifest = @@ -198,7 +185,7 @@ let manifest_files_from op fd = Os.write_all_string fd list 0 (String.length list) in match op with - | `Copy_items (src_manifest, _) -> Lwt_list.iter_s copy_root src_manifest + | `Copy_items (src_manifest, _) -> List.iter copy_root src_manifest | `Copy_item (src_manifest, _) -> copy_root src_manifest let tarball_from_build t ~log ~files_from ~tar workdir user id = @@ -268,70 +255,50 @@ let untar t ~cancelled ~stdin ~log ?dst_dir id = ~entrypoint () in - Lwt_result.bind_lwt - (run ~cancelled ~stdin ~log t config id) - (fun () -> teardown ~log ~commit:true id) + match run ~cancelled ~stdin ~log t config id with + | Error _ as e -> e + | Ok () -> + teardown ~log ~commit:true id; + Ok () let copy_from_context t ~cancelled ~log op ~user ~src_dir ?dst_dir id = (* If the sending thread finishes (or fails), close the writing end of the pipe immediately so that the untar process finishes too. *) Os.with_pipe_to_child @@ fun ~r:from_us ~w:to_untar -> let proc = untar t ~cancelled ~stdin:from_us ~log ?dst_dir id in - let send = - Lwt.finalize - (fun () -> - match op with - | `Copy_items (src_manifest, dst_dir) -> - Tar_transfer.send_files ~src_dir ~src_manifest ~dst_dir ~to_untar ~user - | `Copy_item (src_manifest, dst) -> - Tar_transfer.send_file ~src_dir ~src_manifest ~dst ~to_untar ~user - ) - (fun () -> Lwt_unix.close to_untar) in - let* result = proc in - let+ () = send in - result + Fun.protect + (fun () -> + match op with + | `Copy_items (src_manifest, dst_dir) -> + Tar_transfer.send_files ~src_dir ~src_manifest ~dst_dir ~to_untar ~user + | `Copy_item (src_manifest, dst) -> + Tar_transfer.send_file ~src_dir ~src_manifest ~dst ~to_untar ~user + ) + ~finally:(fun () -> (try Unix.close to_untar with Unix.Unix_error _ -> ())); + proc let copy_from_build t ~cancelled ~log op ~user ~workdir ?dst_dir ~from_id id = (* If a sending thread finishes (or fails), close the writing end of the pipes immediately so that the receiving processes may finish too. *) - Lwt_switch.with_switch @@ fun switch -> - let kill () = Lwt_switch.turn_off switch in - let kill_exn exn = let+ () = kill () in raise exn in - let tarball ~tar () = - Os.with_pipe_to_child @@ fun ~r:files_from ~w:files_from_out -> - let proc = tarball_from_build ~log t ~files_from ~tar workdir user from_id in - let f () = Os.ensure_closed_lwt files_from_out in - let send = Lwt.try_bind (fun () -> - let* () = manifest_files_from op files_from_out in - f ()) - f kill_exn in - let* () = Lwt_switch.add_hook_or_exec (Some switch) f in - let* result = proc in - let+ () = send in - result - in - let transform ~to_untar () = - Os.with_pipe_from_child @@ fun ~r:from_tar ~w:tar -> - let f () = Os.ensure_closed_lwt from_tar in - let proc = - let* () = transform op ~user ~from_tar ~to_untar in - f () - in - let send = Lwt.try_bind (tarball ~tar) f kill_exn in - let* () = Lwt_switch.add_hook_or_exec (Some switch) f in - let* result = proc in - let+ () = send in - result - in Os.with_pipe_to_child @@ fun ~r:from_us ~w:to_untar -> let proc = untar t ~cancelled ~stdin:from_us ~log ?dst_dir id in - let f () = Os.ensure_closed_lwt to_untar in - let send = Lwt.try_bind (transform ~to_untar) f kill_exn in - let* () = Lwt_switch.add_hook_or_exec (Some switch) f in - let* result = proc in - let+ () = send in - result + Fun.protect + (fun () -> + Os.with_pipe_from_child @@ fun ~r:from_tar ~w:tar -> + Fun.protect + (fun () -> + Os.with_pipe_to_child @@ fun ~r:files_from ~w:files_from_out -> + Fun.protect + (fun () -> + manifest_files_from op files_from_out; + (try Unix.close files_from_out with Unix.Unix_error _ -> ())) + ~finally:(fun () -> (try Unix.close files_from_out with Unix.Unix_error _ -> ())); + tarball_from_build ~log t ~files_from ~tar workdir user from_id) + ~finally:(fun () -> (try Unix.close from_tar with Unix.Unix_error _ -> ())); + transform op ~user ~from_tar ~to_untar) + ~finally:(fun () -> (try Unix.close to_untar with Unix.Unix_error _ -> ())); + proc (* The container must be based on the same version as the host. *) let servercore = @@ -341,7 +308,7 @@ let servercore = | None -> let keyname = {|HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion|} in let valuename = "CurrentBuild" in - let* value = Os.pread ["reg"; "query"; keyname; "/v"; valuename] in + let value = Os.pread ["reg"; "query"; keyname; "/v"; valuename] in let line = String.(value |> trim |> split_on_char '\n') |> Fun.flip List.nth 1 in Scanf.sscanf line " CurrentBuild REG_SZ %i" @@ fun version -> let version' = match version with @@ -359,7 +326,7 @@ let servercore = in let img' = "mcr.microsoft.com/windows/servercore:" ^ version' in Log.info (fun f -> f "Windows host is build %i, will use tag %s." version img'); - img := Some (Lwt.return (`Docker_image img')); + img := Some (`Docker_image img'); Option.get !img | Some img -> img @@ -374,15 +341,15 @@ let servercore = We use `manifest.bash', an implementation of {!Manifest} in Bash, to extract the tar manifest from the Docker image. *) let create_tar_volume (t:t) = - Log.info (fun f -> f "Preparing tar volume…"); + Log.info (fun f -> f "Preparing tar volume..."); let name = Docker.obuilder_libexec () in let vol = `Docker_volume name and img = `Docker_image name in - let* _ = Docker.Cmd.volume (`Create vol) in + let _ = Docker.Cmd.volume (`Create vol) in - let* (`Docker_image base) = if Sys.win32 then servercore () else Lwt.return (`Docker_image "busybox") in + let (`Docker_image base) = if Sys.win32 then servercore () else (`Docker_image "busybox") in - let* config = - if Sys.win32 then + let config = + if Sys.win32 then begin let destination = Docker.(mount_point_inside_native // obuilder_libexec ()) in let dockerfile = "# escape=`\n" ^ (strf "FROM %s\n" base) ^ {| @@ -400,19 +367,23 @@ let create_tar_volume (t:t) = COPY [ "manifest.bash", "C:/manifest.bash" ] |} in - let+ () = Lwt_io.with_temp_dir ~perm:0o700 @@ fun temp_dir -> + let temp_dir = Filename.temp_dir ~temp_dir:(Filename.get_temp_dir_name ()) "obuilder-tar-" "" in + Fun.protect ~finally:(fun () -> Os.rm ~directory:temp_dir) (fun () -> + Unix.chmod temp_dir 0o700; let write_file dst ?(perm=0o400) contents = - Lwt_io.(with_file ~perm ~mode:Output (temp_dir / dst)) @@ fun ch -> - Lwt_io.fprint ch contents in - let* () = write_file "Dockerfile" dockerfile in - let* () = write_file "extract.cmd" ~perm:0o500 (Option.get (Static_files.read "extract.cmd")) in - let* () = write_file "manifest.bash" ~perm:0o500 (Option.get (Static_files.read "manifest.bash")) in + let path = temp_dir / dst in + let fd = Unix.openfile path [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_CLOEXEC] perm in + Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> + Os.write_all_string fd contents 0 (String.length contents)) + in + write_file "Dockerfile" dockerfile; + write_file "extract.cmd" ~perm:0o500 (Option.get (Static_files.read "extract.cmd")); + write_file "manifest.bash" ~perm:0o500 (Option.get (Static_files.read "manifest.bash")); let docker_argv = [ "--isolation"; List.assoc t.docker_isolation isolations; "--network"; t.docker_network; ] in - Docker.Cmd.build docker_argv img temp_dir - in + Docker.Cmd.build docker_argv img temp_dir); let entrypoint, argv = {|C:\Windows\System32\cmd.exe|}, ["/S"; "/C"; {|C:\extract.cmd|}] in Config.v ~cwd:{|C:/|} ~argv ~hostname:"" @@ -424,21 +395,26 @@ let create_tar_volume (t:t) = ~entrypoint () - else + end else begin let destination = Docker.(mount_point_inside_native / obuilder_libexec ()) in let dockerfile = strf "FROM %s\n" base ^ strf {|COPY [ "manifest.bash", "%s/manifest.bash" ]|} destination in - let+ () = Lwt_io.with_temp_dir ~perm:0o700 @@ fun temp_dir -> + + let temp_dir = Filename.temp_dir ~temp_dir:(Filename.get_temp_dir_name ()) "obuilder-tar-" "" in + Fun.protect ~finally:(fun () -> Os.rm ~directory:temp_dir) (fun () -> + Unix.chmod temp_dir 0o700; let write_file dst ?(perm=0o400) contents = - Lwt_io.(with_file ~perm ~mode:Output (temp_dir / dst)) @@ fun ch -> - Lwt_io.fprint ch contents in - let* () = write_file "Dockerfile" dockerfile in - let* () = write_file "manifest.bash" ~perm:0o500 (Option.get (Static_files.read "manifest.bash")) in + let path = temp_dir / dst in + let fd = Unix.openfile path [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_CLOEXEC] perm in + Fun.protect ~finally:(fun () -> Unix.close fd) (fun () -> + Os.write_all_string fd contents 0 (String.length contents)) + in + write_file "Dockerfile" dockerfile; + write_file "manifest.bash" ~perm:0o500 (Option.get (Static_files.read "manifest.bash")); let docker_argv = [ "--isolation"; List.assoc t.docker_isolation isolations; "--network"; t.docker_network; ] in - Docker.Cmd.build docker_argv img temp_dir - in + Docker.Cmd.build docker_argv img temp_dir); let entrypoint, argv = "/bin/sh", ["-c"; ":"] in Config.v ~cwd:"/" ~argv ~hostname:"" @@ -449,16 +425,17 @@ let create_tar_volume (t:t) = ~network:[] ~entrypoint () + end in let docker_args, args = Docker_config.make config t in - let* () = Docker.Cmd.run ~rm:true docker_args img args in + Docker.Cmd.run ~rm:true docker_args img args; Docker.Cmd.image (`Remove img) let create (c : config) = let t = { docker_cpus = c.cpus; docker_isolation = c.isolation; docker_memory = c.memory; docker_network = c.network; } in - let* volume_exists = Docker.Cmd.exists (`Docker_volume (Docker.obuilder_libexec ())) in - let+ () = if Result.is_error volume_exists then create_tar_volume t else Lwt.return_unit in + let volume_exists = Docker.Cmd.exists (`Docker_volume (Docker.obuilder_libexec ())) in + if Result.is_error volume_exists then create_tar_volume t; t open Cmdliner diff --git a/lib/docker_sandbox.mli b/lib/docker_sandbox.mli index 2dc51ce8..80da4b61 100644 --- a/lib/docker_sandbox.mli +++ b/lib/docker_sandbox.mli @@ -2,28 +2,28 @@ include S.SANDBOX -val teardown : log:Build_log.t -> commit:bool -> S.id -> unit Lwt.t +val teardown : log:Build_log.t -> commit:bool -> S.id -> unit val manifest_from_build : t -> base:S.id -> exclude:string list -> string list -> string -> Obuilder_spec.user -> - (Manifest.t list, [> `Msg of string ]) Lwt_result.t + (Manifest.t list, [> `Msg of string ]) result val copy_from_context : t -> - cancelled:unit Lwt.t -> + cancelled:unit Eio.Promise.t -> log:Build_log.t -> [< `Copy_item of Manifest.t * string | `Copy_items of Manifest.t list * string ] -> user:Obuilder_spec.user -> src_dir:string -> ?dst_dir:string -> - string -> (unit, [ `Cancelled | `Msg of string ]) result Lwt.t + string -> (unit, [ `Cancelled | `Msg of string ]) result val copy_from_build : t -> - cancelled:'a Lwt.t -> + cancelled:unit Eio.Promise.t -> log:Build_log.t -> [< `Copy_item of Manifest.t * string | `Copy_items of Manifest.t list * string ] -> @@ -32,9 +32,9 @@ val copy_from_build : ?dst_dir:string -> from_id:S.id -> S.id -> - (unit, [ `Cancelled | `Msg of string ]) result Lwt.t + (unit, [ `Cancelled | `Msg of string ]) result -val servercore : unit -> ([ `Docker_image of string ]) Lwt.t +val servercore : unit -> [ `Docker_image of string ] (** Get the Windows ServerCore image based on the same version as the host. *) @@ -56,6 +56,6 @@ val cmdliner : config Cmdliner.Term.t necessary flags and parameters to setup a specific sandbox's configuration. *) -val create : config -> t Lwt.t +val create : config -> t (** [create config] is a Docker sandboxing system that is configured using [config]. *) diff --git a/lib/docker_store.ml b/lib/docker_store.ml index a9a44e24..38e24d00 100644 --- a/lib/docker_store.ml +++ b/lib/docker_store.ml @@ -1,5 +1,3 @@ -open Lwt.Syntax - (* Represents a persistent cache. You must hold a cache's lock when removing or updating its entry in "cache", and must assume this may happen at any time when not holding it. @@ -7,7 +5,7 @@ open Lwt.Syntax since being cloned. The counter starts from zero when the in-memory cache value is created (i.e. you cannot compare across restarts). *) type cache = { - lock : Lwt_mutex.t; + lock : Mutex.t; mutable gen : int; } @@ -45,10 +43,10 @@ module Cache : sig val name : [ `Docker_volume of string] -> string - val exists : [ `Docker_volume of string] -> bool Lwt.t - val create : [ `Docker_volume of string] -> unit Lwt.t - val snapshot : src:[ `Docker_volume of string] -> [ `Docker_volume of string] -> unit Lwt.t - val delete : [`Docker_volume of string] -> unit Lwt.t + val exists : [ `Docker_volume of string] -> bool + val create : [ `Docker_volume of string] -> unit + val snapshot : src:[ `Docker_volume of string] -> [ `Docker_volume of string] -> unit + val delete : [`Docker_volume of string] -> unit end = struct let cache name = Docker.docker_volume_cache (Escape.cache name) let cache_tmp i name = Docker.docker_volume_cache ~tmp:true (strf "%d-%s" i (Escape.cache name)) @@ -56,42 +54,40 @@ end = struct let name (`Docker_volume name) = name let exists volume = - let+ r = Docker.Cmd.exists volume in + let r = Docker.Cmd.exists volume in Result.is_ok r let create volume = - let* id = Docker.Cmd.volume ~timeout:5.0 (`Create volume) in - Log.debug (fun f -> f "Volume id: %s" (String.trim id)); - Lwt.return_unit + let id = Docker.Cmd.volume ~timeout:5.0 (`Create volume) in + Log.debug (fun f -> f "Volume id: %s" (String.trim id)) let snapshot ~src dst = Log.debug (fun f -> f "Snapshotting volume %s to %s" (match src with `Docker_volume src -> src) (match dst with `Docker_volume dst -> dst)); - let* () = create dst in - let* base = if Sys.win32 then Docker_sandbox.servercore () else Lwt.return (`Docker_image "busybox") in - let* r = Docker.cp_between_volumes ~base ~src ~dst in + create dst; + let base = if Sys.win32 then Docker_sandbox.servercore () else `Docker_image "busybox" in + let r = Docker.cp_between_volumes ~base ~src ~dst in Log.debug (fun f -> f "Finished snapshotting"); - match r with Ok () -> Lwt.return_unit | Error (`Msg msg) -> failwith msg + match r with Ok () -> () | Error (`Msg msg) -> failwith msg let delete volume = - let* _ = Docker.Cmd.volume (`Remove [volume]) in - Lwt.return_unit + let _ = Docker.Cmd.volume (`Remove [volume]) in + () end let root t = t.root -let df t = Lwt.return (Os.free_space_percent t.root) +let df t = Os.free_space_percent t.root let cache_stats _ = 0, 0 let purge () = - let* containers = Docker.Cmd.obuilder_containers () in - let* () = if containers <> [] then Docker.Cmd.rm containers else Lwt.return_unit in + let containers = Docker.Cmd.obuilder_containers () in + if containers <> [] then Docker.Cmd.rm containers; Log.info (fun f -> f "Removing left-over Docker images"); - let* images = Docker.Cmd.obuilder_images ~tmp:true () in - let* () = if images <> [] then Docker.Cmd.rmi images else Lwt.return_unit in + let images = Docker.Cmd.obuilder_images ~tmp:true () in + if images <> [] then Docker.Cmd.rmi images; Log.info (fun f -> f "Removing left-over Docker volumes"); - let* volumes = Docker.Cmd.obuilder_caches_tmp () in - let* _ = if volumes <> [] then Docker.Cmd.volume (`Remove volumes) else Lwt.return "" in - Lwt.return_unit + let volumes = Docker.Cmd.obuilder_caches_tmp () in + if volumes <> [] then (let _ = Docker.Cmd.volume (`Remove volumes) in ()) let create root = Os.ensure_dir root; @@ -102,55 +98,51 @@ let create root = Os.ensure_dir ~mode:0o0 (root / "empty"); Os.ensure_dir (root / "state"); Os.ensure_dir (root / "logs"); - let* () = purge () in - Lwt.return t + purge (); + t -let build t ?base ~id (fn:(string -> (unit, 'e) Lwt_result.t)) : (unit, 'e) Lwt_result.t = +let build t ?base ~id (fn:(string -> (unit, 'e) result)) : (unit, 'e) result = match base with | None -> - Lwt.catch - (fun () -> fn (Path.empty t)) - (fun ex -> - Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); - Lwt.reraise ex) + (try fn (Path.empty t) + with ex -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); + raise ex) | Some base -> let base = Docker.docker_image base in let tmp_image = (Docker.docker_image ~tmp:true id) in - let* () = Docker.Cmd.tag base tmp_image in - Lwt.try_bind - (fun () -> fn (Path.empty t)) - (fun r -> - (* As the cache is cleaned before this, the sandbox must take - care of committing the container and removing it, otherwise - the container still has a reference to the cache. *) - let+ () = Docker.Cmd.image (`Remove tmp_image) in - r) - (fun ex -> - Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); - let* () = Docker.Cmd.image (`Remove tmp_image) in - Lwt.reraise ex) + Docker.Cmd.tag base tmp_image; + match (try Ok (fn (Path.empty t)) with ex -> Error ex) with + | Ok r -> + (* As the cache is cleaned before this, the sandbox must take + care of committing the container and removing it, otherwise + the container still has a reference to the cache. *) + Docker.Cmd.image (`Remove tmp_image); + r + | Error ex -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); + Docker.Cmd.image (`Remove tmp_image); + raise ex let delete t id = let image = Docker.docker_image id in - let* exists = Docker.Cmd.exists image in - let* () = match exists with + let exists = Docker.Cmd.exists image in + (match exists with | Ok () -> Docker.Cmd.image (`Remove image) - | Error _ -> Lwt.return_unit - in + | Error _ -> ()); let log_file = Path.log_file t id in if Sys.file_exists log_file then - Lwt_unix.unlink log_file - else Lwt.return_unit + Unix.unlink log_file let result t id = let img = Docker.docker_image id in - let* r = Docker.Cmd.exists img in + let r = Docker.Cmd.exists img in match r with - | Ok () -> Lwt.return_some (Path.empty t) + | Ok () -> Some (Path.empty t) | Error _ -> - Lwt.return_none + None -let log_file t id = Lwt.return (Path.log_file t id) +let log_file t id = Path.log_file t id let state_dir = Path.state @@ -158,62 +150,58 @@ let get_cache t name = match Hashtbl.find_opt t.caches name with | Some c -> c | None -> - let c = { lock = Lwt_mutex.create (); gen = 0 } in + let c = { lock = Mutex.create (); gen = 0 } in Hashtbl.add t.caches name c; c -let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t = +let cache ~user t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> let tmp = Cache.cache_tmp t.next name in t.next <- t.next + 1; let snapshot = Cache.cache name in (* Create cache if it doesn't already exist. *) - let* () = - let* exists = Cache.exists snapshot in - if not exists then Cache.create snapshot - else Lwt.return_unit - in + let exists = Cache.exists snapshot in + if not exists then Cache.create snapshot; (* Create writeable clone. *) let gen = cache.gen in - let* () = Cache.snapshot ~src:snapshot tmp in - let+ () = match user with + Cache.snapshot ~src:snapshot tmp; + (match user with | `Unix { Obuilder_spec.uid; gid } -> - let* tmp = Docker.Cmd.mount_point tmp in + let tmp = Docker.Cmd.mount_point tmp in Os.sudo ["chown"; strf "%d:%d" uid gid; tmp] - | `Windows _ -> Lwt.return_unit (* FIXME: does Windows need special treatment? *) - in + | `Windows _ -> () (* FIXME: does Windows need special treatment? *)); let release () = - Lwt_mutex.with_lock cache.lock @@ fun () -> - let* () = - if cache.gen = gen then ( - (* The cache hasn't changed since we cloned it. Update it. *) - (* todo: check if it has actually changed. *) - cache.gen <- cache.gen + 1; - let* () = Cache.delete snapshot in - Cache.snapshot ~src:tmp snapshot - ) else Lwt.return_unit - in - Cache.delete tmp + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> + (if cache.gen = gen then ( + (* The cache hasn't changed since we cloned it. Update it. *) + (* todo: check if it has actually changed. *) + cache.gen <- cache.gen + 1; + Cache.delete snapshot; + Cache.snapshot ~src:tmp snapshot)); + Cache.delete tmp) in - Cache.name tmp, release + (Cache.name tmp, release)) let delete_cache t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) let snapshot = Cache.cache name in - let* exists = Cache.exists snapshot in + let exists = Cache.exists snapshot in if exists then - let* containers = Docker.Cmd.volume_containers snapshot in - if containers <> [] then - let* () = Cache.delete snapshot in - Lwt_result.ok Lwt.return_unit + let containers = Docker.Cmd.volume_containers snapshot in + if containers <> [] then ( + Cache.delete snapshot; + Ok ()) else - Lwt_result.fail `Busy - else Lwt_result.ok Lwt.return_unit + Error `Busy + else Ok ()) let complete_deletes t = ignore t; (* FIXME: how to implement this? *) - Lwt.return_unit + () diff --git a/lib/docker_store.mli b/lib/docker_store.mli index b48689af..4bbcd09e 100644 --- a/lib/docker_store.mli +++ b/lib/docker_store.mli @@ -2,7 +2,7 @@ include S.STORE -val create : string -> t Lwt.t +val create : string -> t (** [create root] is a new store using Docker images and [root] to store ancillary state. *) diff --git a/lib/dune b/lib/dune index 3410deb1..7a6eb5a2 100644 --- a/lib/dune +++ b/lib/dune @@ -28,4 +28,4 @@ (public_name obuilder) (preprocess (pps ppx_sexp_conv)) (flags (:standard -w -69)) - (libraries fpath lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner extunix)) + (libraries fpath eio eio_main eio.unix lwt lwt_eio tar-unix fmt yojson sexplib sqlite3 astring logs sha obuilder-spec cmdliner extunix)) diff --git a/lib/macos.ml b/lib/macos.ml index 538dcca6..211e1922 100644 --- a/lib/macos.ml +++ b/lib/macos.ml @@ -1,73 +1,69 @@ (* Extensions to the Os module for macOS *) -open Lwt.Syntax -open Lwt.Infix open Os let ( / ) = Filename.concat let user_exists ~user = - let+ s = pread ["sudo"; "dscl"; "."; "list"; "/Users"] in + let s = pread ["sudo"; "dscl"; "."; "list"; "/Users"] in List.exists (Astring.String.equal user) (Astring.String.cuts ~sep:"\n" s) (* Generates a new MacOS user called `' *) let create_new_user ~username ~home_dir ~uid ~gid = - let* exists = user_exists ~user:username in - if exists then Lwt.return_ok () + let exists = user_exists ~user:username in + if exists then Ok () else let user = "/Users" / username in let pp s ppf = Fmt.pf ppf "[ Mac ] %s\n" s in let dscl = [ "dscl"; "."; "-create"; user ] in - sudo_result ~pp:(pp "UniqueID") (dscl @ [ "UniqueID"; uid ]) >>!= fun _ -> - sudo_result ~pp:(pp "PrimaryGroupID") (dscl @ [ "PrimaryGroupID"; gid ]) >>!= fun _ -> - sudo_result ~pp:(pp "UserShell") (dscl @ [ "UserShell"; "/bin/bash" ]) >>!= fun _ -> - sudo_result ~pp:(pp "NFSHomeDirectory") (dscl @ [ "NFSHomeDirectory"; home_dir ]) >>!= fun _ -> - Lwt_result.return () + Result.bind (sudo_result ~pp:(pp "UniqueID") (dscl @ [ "UniqueID"; uid ])) @@ fun _ -> + Result.bind (sudo_result ~pp:(pp "PrimaryGroupID") (dscl @ [ "PrimaryGroupID"; gid ])) @@ fun _ -> + Result.bind (sudo_result ~pp:(pp "UserShell") (dscl @ [ "UserShell"; "/bin/bash" ])) @@ fun _ -> + Result.bind (sudo_result ~pp:(pp "NFSHomeDirectory") (dscl @ [ "NFSHomeDirectory"; home_dir ])) @@ fun _ -> + Ok () let delete_user ~user = - let* exists = user_exists ~user in + let exists = user_exists ~user in match exists with | false -> Log.info (fun f -> f "Not deleting %s as they don't exist" user); - Lwt_result.return () + Ok () | true -> let user = "/Users" / user in let pp s ppf = Fmt.pf ppf "[ Mac ] %s\n" s in let delete = ["dscl"; "."; "-delete"; user ] in - sudo_result ~pp:(pp "Deleting") delete >>!= fun _ -> - Lwt_result.return () + Result.bind (sudo_result ~pp:(pp "Deleting") delete) @@ fun _ -> + Ok () let rec kill_users_processes ~uid = let pp _ ppf = Fmt.pf ppf "[ PKILL ]" in let delete = ["pkill"; "-9"; "-U"; string_of_int uid ] in - let* t = sudo_result ~pp:(pp "PKILL") delete in + let t = sudo_result ~pp:(pp "PKILL") delete in match t with | Ok _ -> kill_users_processes ~uid | Error (`Msg _) -> - Log.info (fun f -> f "pkill all killed"); - Lwt.return () + Log.info (fun f -> f "pkill all killed") let rec sudo_fallback cmds cmds2 ~uid = let pp f = pp_cmd f ("", cmds) in - let* t = sudo_result ~pp cmds in + let t = sudo_result ~pp cmds in match t with - | Ok _ -> Lwt.return () + | Ok _ -> () | Error (`Msg m) -> Log.warn (fun f -> f "failed with %s" m); (* wait a second then try to kill any user processes and retry *) - Lwt_unix.sleep 2.0 >>= fun () -> - kill_users_processes ~uid >>= fun () -> - sudo cmds2 >>= fun () -> + Unix.sleepf 2.0; + kill_users_processes ~uid; + sudo cmds2; sudo_fallback cmds cmds2 ~uid let rm ~directory = let pp _ ppf = Fmt.pf ppf "[ RM ]" in let delete = ["rm"; "-r"; directory ] in - let* t = sudo_result ~pp:(pp "RM") delete in + let t = sudo_result ~pp:(pp "RM") delete in match t with - | Ok _ -> Lwt.return () + | Ok _ -> () | Error (`Msg m) -> - Log.warn (fun f -> f "Failed to remove %s because %s" directory m); - Lwt.return () + Log.warn (fun f -> f "Failed to remove %s because %s" directory m) let get_tmpdir ~user = ["sudo"; "-u"; user; "-i"; "getconf"; "DARWIN_USER_TEMP_DIR"] diff --git a/lib/os.ml b/lib/os.ml index 3b371b8f..324684c0 100644 --- a/lib/os.ml +++ b/lib/os.ml @@ -1,12 +1,13 @@ -open Lwt.Infix - -let ( >>!= ) = Lwt_result.bind - type unix_fd = { raw : Unix.file_descr; mutable needs_close : bool; } +let rec waitpid_non_intr pid = + match Unix.waitpid [] pid with + | v -> v + | exception Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid + let stdout = { raw = Unix.stdout; needs_close = false; @@ -19,17 +20,13 @@ let stderr = { let close fd = assert (fd.needs_close); - Unix.close fd.raw; + (try Unix.close fd.raw with Unix.Unix_error _ -> ()); fd.needs_close <- false let ensure_closed_unix fd = if fd.needs_close then close fd -let ensure_closed_lwt fd = - if Lwt_unix.state fd = Lwt_unix.Closed then Lwt.return_unit - else Lwt_unix.close fd - let pp_cmd f (cmd, argv) = let argv = if cmd = "" then argv else cmd :: argv in Fmt.hbox Fmt.(list ~sep:sp (quote string)) f argv @@ -49,68 +46,121 @@ let close_redirection (x : [`FD_move_safely of unix_fd | `Dev_null]) = | `FD_move_safely x -> ensure_closed_unix x | `Dev_null -> () +let dev_null_fd = lazy (Unix.openfile "/dev/null" [Unix.O_RDWR] 0) + +let setup_fd = function + | Some (`FD_copy fd) -> fd + | Some `Dev_null -> Lazy.force dev_null_fd + | None -> Unix.stdin (* placeholder, won't be used if not set *) + (* stdin, stdout and stderr are copied to the child and then closed on the host. They are closed at most once, so duplicates are OK. *) -let default_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp argv = - let proc = - let stdin = Option.map redirection stdin in - let stdout = Option.map redirection stdout in - let stderr = Option.map redirection stderr in - try Lwt_result.ok (Lwt_process.exec ?timeout ?cwd ?stdin ?stdout ?stderr argv) - with e -> Lwt_result.fail e +let default_exec ?timeout:(_:float option) ?cwd ?stdin ?stdout ?stderr ~pp argv = + let stdin_r = Option.map redirection stdin in + let stdout_r = Option.map redirection stdout in + let stderr_r = Option.map redirection stderr in + let result = + try + let cmd = fst argv in + let args = snd argv in + let env = Unix.environment () in + let stdin_fd = match stdin_r with + | Some (`FD_copy fd) -> fd + | Some `Dev_null -> Lazy.force dev_null_fd + | None -> Unix.stdin + in + let stdout_fd = match stdout_r with + | Some (`FD_copy fd) -> fd + | Some `Dev_null -> Lazy.force dev_null_fd + | None -> Unix.stdout + in + let stderr_fd = match stderr_r with + | Some (`FD_copy fd) -> fd + | Some `Dev_null -> Lazy.force dev_null_fd + | None -> Unix.stderr + in + let prog = if cmd = "" then args.(0) else cmd in + let cwd_args = match cwd with + | None -> [] + | Some _ -> [] (* handled below *) + in + ignore cwd_args; + (* Save/restore cwd if needed *) + let old_cwd = match cwd with Some _ -> Some (Unix.getcwd ()) | None -> None in + (match cwd with Some d -> Unix.chdir d | None -> ()); + let pid = Unix.create_process_env prog args env stdin_fd stdout_fd stderr_fd in + (match old_cwd with Some d -> Unix.chdir d | None -> ()); + let _, status = waitpid_non_intr pid in + match status with + | Unix.WEXITED n -> Ok n + | Unix.WSIGNALED x -> Fmt.error_msg "%t failed with signal %a" pp Fmt.Dump.signal x + | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp Fmt.Dump.signal x + with e -> + Fmt.error_msg "%t raised %s\n%s" pp (Printexc.to_string e) (Printexc.get_backtrace ()) in Option.iter close_redirection stdin; Option.iter close_redirection stdout; Option.iter close_redirection stderr; - proc >|= fun proc -> - Result.fold ~ok:(function - | Unix.WEXITED n -> Ok n - | Unix.WSIGNALED x -> Fmt.error_msg "%t failed with signal %a" pp Fmt.Dump.signal x - | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp Fmt.Dump.signal x) - ~error:(fun e -> - Fmt.error_msg "%t raised %s\n%s" pp (Printexc.to_string e) (Printexc.get_backtrace ())) proc + result -(* Similar to default_exec except using open_process_none in order to get the +(* Similar to default_exec except using Unix.create_process in order to get the pid of the forked process. On macOS this allows for cleaner job cancellations *) let open_process ?cwd ?env ?stdin ?stdout ?stderr ?pp:_ argv = Logs.info (fun f -> f "Fork exec %a" pp_cmd ("", argv)); - let proc = - let stdin = Option.map redirection stdin in - let stdout = Option.map redirection stdout in - let stderr = Option.map redirection stderr in - let process = Lwt_process.open_process_none ?cwd ?env ?stdin ?stdout ?stderr ("", (Array.of_list argv)) in - (process#pid, process#status) + let stdin_fd = match stdin with + | Some (`FD_move_safely fd) -> fd.raw + | Some `Dev_null -> Lazy.force dev_null_fd + | None -> Unix.stdin + in + let stdout_fd = match stdout with + | Some (`FD_move_safely fd) -> fd.raw + | Some `Dev_null -> Lazy.force dev_null_fd + | None -> Unix.stdout in - Option.iter close_redirection stdin; - Option.iter close_redirection stdout; - Option.iter close_redirection stderr; - proc + let stderr_fd = match stderr with + | Some (`FD_move_safely fd) -> fd.raw + | Some `Dev_null -> Lazy.force dev_null_fd + | None -> Unix.stderr + in + let old_cwd = match cwd with Some _ -> Some (Unix.getcwd ()) | None -> None in + (match cwd with Some d -> Unix.chdir d | None -> ()); + let env_arr = match env with Some e -> e | None -> Unix.environment () in + let prog = List.hd argv in + let args = Array.of_list argv in + let pid = Unix.create_process_env prog args env_arr stdin_fd stdout_fd stderr_fd in + (match old_cwd with Some d -> Unix.chdir d | None -> ()); + Option.iter close_redirection (Option.map (fun x -> (x : [`FD_move_safely of unix_fd | `Dev_null])) stdin); + Option.iter close_redirection (Option.map (fun x -> (x : [`FD_move_safely of unix_fd | `Dev_null])) stdout); + Option.iter close_redirection (Option.map (fun x -> (x : [`FD_move_safely of unix_fd | `Dev_null])) stderr); + let wait_for_result () = + let _, status = waitpid_non_intr pid in + status + in + (pid, wait_for_result) let process_result ~pp proc = - proc >|= (function - | Unix.WEXITED n -> Ok n + let status = proc () in + match status with + | Unix.WEXITED 0 -> Ok () + | Unix.WEXITED n -> Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n | Unix.WSIGNALED x -> Fmt.error_msg "%t failed with signal %a" pp Fmt.Dump.signal x - | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp Fmt.Dump.signal x) - >>= function - | Ok 0 -> Lwt_result.return () - | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n - | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string]) + | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp Fmt.Dump.signal x (* Overridden in unit-tests *) -let lwt_process_exec = ref default_exec +let process_exec = ref default_exec let exec_result ?cwd ?stdin ?stdout ?stderr ~pp ?(is_success=((=) 0)) ?(cmd="") argv = Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv)); - !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function - | Ok n when is_success n -> Lwt_result.ok Lwt.return_unit - | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n - | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string]) + match !process_exec ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) with + | Ok n when is_success n -> Ok () + | Ok n -> Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n + | Error e -> Error (e : [`Msg of string] :> [> `Msg of string]) let exec ?timeout ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") argv = Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv)); let pp f = pp_cmd f (cmd, argv) in - !lwt_process_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function - | Ok n when is_success n -> Lwt.return_unit + match !process_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) with + | Ok n when is_success n -> () | Ok n -> Fmt.failwith "%t failed with exit status %a" pp pp_exit_status n | Error (`Msg m) -> failwith m @@ -126,91 +176,114 @@ let sudo_result ?cwd ?stdin ?stdout ?stderr ?is_success ~pp args = let rec write_all fd buf ofs len = assert (len >= 0); - if len = 0 then Lwt.return_unit + if len = 0 then () else ( - Lwt_unix.write fd buf ofs len >>= fun n -> + let n = Unix.write fd buf ofs len in write_all fd buf (ofs + n) (len - n) ) let rec write_all_string fd buf ofs len = assert (len >= 0); - if len = 0 then Lwt.return_unit + if len = 0 then () else ( - Lwt_unix.write_string fd buf ofs len >>= fun n -> + let n = Unix.write_substring fd buf ofs len in write_all_string fd buf (ofs + n) (len - n) ) let write_file ~path contents = - let flags = [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK; Unix.O_CLOEXEC] in - Lwt_io.(with_file ~mode:output ~flags) path @@ fun ch -> - Lwt_io.write ch contents + let fd = Unix.openfile path [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_CLOEXEC] 0o666 in + Fun.protect ~finally:(fun () -> (try Unix.close fd with Unix.Unix_error _ -> ())) @@ fun () -> + write_all_string fd contents 0 (String.length contents) let with_pipe_from_child fn = - let r, w = Lwt_unix.pipe_in ~cloexec:true () in + let r, w = Unix.pipe ~cloexec:true () in let w = { raw = w; needs_close = true } in - Lwt.finalize - (fun () -> fn ~r ~w) - (fun () -> + let r_fd = r in + Fun.protect + (fun () -> fn ~r:r_fd ~w) + ~finally:(fun () -> ensure_closed_unix w; - ensure_closed_lwt r + (try Unix.close r_fd with Unix.Unix_error _ -> ()) ) let with_pipe_to_child fn = - let r, w = Lwt_unix.pipe_out ~cloexec:true () in + let r, w = Unix.pipe ~cloexec:true () in let r = { raw = r; needs_close = true } in - Lwt.finalize - (fun () -> fn ~r ~w) - (fun () -> + let w_fd = w in + Fun.protect + (fun () -> fn ~r ~w:w_fd) + ~finally:(fun () -> ensure_closed_unix r; - ensure_closed_lwt w + (try Unix.close w_fd with Unix.Unix_error _ -> ()) ) let with_pipe_between_children fn = let r, w = Unix.pipe ~cloexec:true () in let r = { raw = r; needs_close = true } in let w = { raw = w; needs_close = true } in - Lwt.finalize + Fun.protect (fun () -> fn ~r ~w) - (fun () -> + ~finally:(fun () -> ensure_closed_unix r; - ensure_closed_unix w; - Lwt.return_unit + ensure_closed_unix w ) let pread ?timeout ?stderr argv = with_pipe_from_child @@ fun ~r ~w -> - let child = exec ?timeout ~stdout:(`FD_move_safely w) ?stderr argv in - let r = Lwt_io.(of_fd ~mode:input) r in - Lwt.finalize - (fun () -> Lwt_io.read r) - (fun () -> Lwt_io.close r) - >>= fun data -> child >|= fun () -> data + let child_result = ref (Ok ()) in + let () = child_result := (try exec ?timeout ~stdout:(`FD_move_safely w) ?stderr argv; Ok () with Failure m -> Error (`Msg m)) in + (* Read all data from the pipe *) + let buf = Buffer.create 1024 in + let tmp = Bytes.create 4096 in + let rec read_all () = + match Unix.read r tmp 0 (Bytes.length tmp) with + | 0 -> () + | n -> Buffer.add_subbytes buf tmp 0 n; read_all () + | exception Unix.Unix_error (Unix.EINTR, _, _) -> read_all () + in + read_all (); + (match !child_result with Ok () -> () | Error (`Msg m) -> failwith m); + Buffer.contents buf let pread_result ?cwd ?stdin ?stderr ~pp ?is_success ?cmd argv = with_pipe_from_child @@ fun ~r ~w -> let child = exec_result ?cwd ?stdin ~stdout:(`FD_move_safely w) ?stderr ~pp ?is_success ?cmd argv in - let r = Lwt_io.(of_fd ~mode:input) r in - Lwt.finalize - (fun () -> Lwt_io.read r) - (fun () -> Lwt_io.close r) - >>= fun data -> child >|= fun r -> Result.map (fun () -> data) r + let buf = Buffer.create 1024 in + let tmp = Bytes.create 4096 in + let rec read_all () = + match Unix.read r tmp 0 (Bytes.length tmp) with + | 0 -> () + | n -> Buffer.add_subbytes buf tmp 0 n; read_all () + | exception Unix.Unix_error (Unix.EINTR, _, _) -> read_all () + in + read_all (); + let data = Buffer.contents buf in + Result.map (fun () -> data) child let pread_all ?stdin ~pp ?(cmd="") argv = with_pipe_from_child @@ fun ~r:r1 ~w:w1 -> with_pipe_from_child @@ fun ~r:r2 ~w:w2 -> + Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv)); let child = - Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv)); - !lwt_process_exec ?stdin ~stdout:(`FD_move_safely w1) ~stderr:(`FD_move_safely w2) ~pp + !process_exec ?stdin ~stdout:(`FD_move_safely w1) ~stderr:(`FD_move_safely w2) ~pp (cmd, Array.of_list argv) in - let r1 = Lwt_io.(of_fd ~mode:input) r1 in - let r2 = Lwt_io.(of_fd ~mode:input) r2 in - Lwt.finalize - (fun () -> Lwt.both (Lwt_io.read r1) (Lwt_io.read r2)) - (fun () -> Lwt.both (Lwt_io.close r1) (Lwt_io.close r2) >>= fun _ -> Lwt.return_unit) - >>= fun (stdin, stdout) -> - child >>= function - | Ok i -> Lwt.return (i, stdin, stdout) + let read_fd fd = + let buf = Buffer.create 1024 in + let tmp = Bytes.create 4096 in + let rec read_all () = + match Unix.read fd tmp 0 (Bytes.length tmp) with + | 0 -> () + | n -> Buffer.add_subbytes buf tmp 0 n; read_all () + | exception Unix.Unix_error (Unix.EINTR, _, _) -> read_all () + in + read_all (); + Buffer.contents buf + in + let stdout_data = read_fd r1 in + let stderr_data = read_fd r2 in + match child with + | Ok i -> (i, stdout_data, stderr_data) | Error (`Msg m) -> failwith m let check_dir x = @@ -231,30 +304,24 @@ let read_link x = let rm ~directory = let pp _ ppf = Fmt.pf ppf "[ RM ]" in - sudo_result ~pp:(pp "RM") ["rm"; "-r"; directory ] >>= fun t -> - match t with - | Ok () -> Lwt.return_unit + match sudo_result ~pp:(pp "RM") ["rm"; "-r"; directory ] with + | Ok () -> () | Error (`Msg m) -> - Log.warn (fun f -> f "Failed to remove %s because %s" directory m); - Lwt.return_unit + Log.warn (fun f -> f "Failed to remove %s because %s" directory m) let mv ~src dst = let pp _ ppf = Fmt.pf ppf "[ MV ]" in - sudo_result ~pp:(pp "MV") ["mv"; src; dst ] >>= fun t -> - match t with - | Ok () -> Lwt.return_unit + match sudo_result ~pp:(pp "MV") ["mv"; src; dst ] with + | Ok () -> () | Error (`Msg m) -> - Log.warn (fun f -> f "Failed to move %s to %s because %s" src dst m); - Lwt.return_unit + Log.warn (fun f -> f "Failed to move %s to %s because %s" src dst m) let cp ~src dst = let pp _ ppf = Fmt.pf ppf "[ CP ]" in - sudo_result ~pp:(pp "CP") ["cp"; "-pRduT"; "--reflink=auto"; src; dst ] >>= fun t -> - match t with - | Ok () -> Lwt.return_unit + match sudo_result ~pp:(pp "CP") ["cp"; "-pRduT"; "--reflink=auto"; src; dst ] with + | Ok () -> () | Error (`Msg m) -> - Log.warn (fun f -> f "Failed to copy from %s to %s because %s" src dst m); - Lwt.return_unit + Log.warn (fun f -> f "Failed to copy from %s to %s because %s" src dst m) let normalise_path root_dir = if Sys.win32 then diff --git a/lib/overlayfs_store.ml b/lib/overlayfs_store.ml index c4f61f28..a3f23c25 100644 --- a/lib/overlayfs_store.ml +++ b/lib/overlayfs_store.ml @@ -26,10 +26,8 @@ ocluster-worker ... --obuilder-store=overlayfs:/var/cache/obuilder *) -open Lwt.Infix - type cache = { - lock : Lwt_mutex.t; + lock : Mutex.t; mutable children : int; } @@ -45,9 +43,9 @@ module Overlayfs = struct let create ?mode ?user dirs = match mode with | None -> Os.exec ([ "mkdir"; "-p" ] @ dirs) - | Some mode -> Os.exec ([ "mkdir"; "-p"; "-m"; mode ] @ dirs) >>= fun () -> + | Some mode -> Os.exec ([ "mkdir"; "-p"; "-m"; mode ] @ dirs); match user with - | None -> Lwt.return_unit + | None -> () | Some `Unix user -> let { Obuilder_spec.uid; gid } = user in Os.sudo ([ "chown"; Printf.sprintf "%d:%d" uid gid; ] @ dirs) @@ -55,7 +53,7 @@ module Overlayfs = struct let delete dirs = match dirs with - | [] -> Lwt.return_unit + | [] -> () | d -> Os.sudo ([ "rm"; "-rf" ] @ d) let rename ~src ~dst = @@ -115,8 +113,7 @@ end let root t = t.path let df t = - Lwt_process.pread ("", [| "df"; "-k"; "--output=used,size"; t.path |]) - >>= fun output -> + let output = Os.pread ["df"; "-k"; "--output=used,size"; t.path] in let used, blocks = String.split_on_char '\n' output |> List.filter_map (fun s -> @@ -125,10 +122,10 @@ let df t = | (exception Scanf.Scan_failure _) | (exception End_of_file) -> None) |> List.fold_left (fun (used, blocks) (u, b) -> (used +. u, blocks +. b)) (0., 0.) in - Lwt.return (100. -. (100. *. (used /. blocks))) + 100. -. (100. *. (used /. blocks)) let create ~path = - Overlayfs.create (Path.dirs path) >>= fun () -> + Overlayfs.create (Path.dirs path); let parse_mtab s = match Scanf.sscanf s "%s %s %s %s %s %s" (fun _ mp _ _ _ _ -> mp) with | x -> Some x @@ -144,13 +141,12 @@ let create ~path = else None | None -> None) in - Lwt_list.iter_s + List.iter (fun merged -> Log.warn (fun f -> f "Unmounting left-over folder %S" merged); Overlayfs.umount ~merged) - mounts - >>= fun () -> - Lwt_list.iter_s + mounts; + List.iter (fun path -> Sys.readdir path |> Array.to_list |> List.map (Filename.concat path) @@ -160,8 +156,8 @@ let create ~path = path / Path.cache_result_dirname; path / Path.cache_work_dirname; path / Path.cache_merged_dirname; - path / Path.work_dirname; ] - >|= fun () -> { path; caches = Hashtbl.create 10; next = 0 } + path / Path.work_dirname; ]; + { path; caches = Hashtbl.create 10; next = 0 } let build t ?base ~id fn = Log.debug (fun f -> f "overlayfs: build %S" id); @@ -169,11 +165,11 @@ let build t ?base ~id fn = let in_progress = Path.in_progress t id in let merged = Path.merged t id in let work = Path.work t id in - Overlayfs.create [ in_progress; work; merged ] >>= fun () -> + Overlayfs.create [ in_progress; work; merged ]; let _ = Option.map (Path.in_progress t) base in (match base with | None -> - Lwt.return_unit + () | Some src -> let src = Path.result t src in Unix.symlink src (in_progress / "parent"); @@ -183,27 +179,24 @@ let build t ?base ~id fn = | None -> []) in let lower = ancestors src |> String.concat ":" in - Overlayfs.overlay ~lower ~upper:in_progress ~work ~merged) - >>= fun () -> - Lwt.try_bind - (fun () -> match base with - | None -> fn in_progress - | Some _ -> fn merged) - (fun r -> - (match base with - | None -> Lwt.return_unit - | Some _ -> Overlayfs.umount ~merged) - >>= fun () -> - (match r with - | Ok () -> - Overlayfs.rename ~src:in_progress ~dst:result >>= fun () -> - Overlayfs.delete [ merged; work ] - | Error _ -> Overlayfs.delete [ merged; work; in_progress ]) - >>= fun () -> Lwt.return r) - (fun ex -> - Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); - Overlayfs.delete [ merged; work; in_progress ] >>= fun () -> - Lwt.reraise ex) + Overlayfs.overlay ~lower ~upper:in_progress ~work ~merged); + match (try Ok (match base with + | None -> fn in_progress + | Some _ -> fn merged) with ex -> Error ex) with + | Ok r -> + (match base with + | None -> () + | Some _ -> Overlayfs.umount ~merged); + (match r with + | Ok () -> + Overlayfs.rename ~src:in_progress ~dst:result; + Overlayfs.delete [ merged; work ] + | Error _ -> Overlayfs.delete [ merged; work; in_progress ]); + r + | Error ex -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); + Overlayfs.delete [ merged; work; in_progress ]; + raise ex let delete t id = let path = Path.result t id in @@ -225,11 +218,11 @@ let delete t id = let result t id = let dir = Path.result t id in match Os.check_dir dir with - | `Present -> Lwt.return_some dir - | `Missing -> Lwt.return_none + | `Present -> Some dir + | `Missing -> None let log_file t id = - result t id >|= function + match result t id with | Some dir -> dir / "log" | None -> Path.in_progress t id / "log" @@ -239,46 +232,48 @@ let get_cache t name = match Hashtbl.find_opt t.caches name with | Some c -> c | None -> - let c = { lock = Lwt_mutex.create (); children = 0 } in + let c = { lock = Mutex.create (); children = 0 } in Hashtbl.add t.caches name c; c let cache ~user t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> let result, work, merged = Path.cache_result t t.next name in t.next <- t.next + 1; let master = Path.cache t name in (* Create cache if it doesn't already exist. *) (match Os.check_dir master with | `Missing -> Overlayfs.create ~mode:"1777" ~user [ master ] - | `Present -> Lwt.return_unit) - >>= fun () -> + | `Present -> ()); cache.children <- cache.children + 1; - Overlayfs.create ~mode:"1777" ~user [ result; work; merged ] >>= fun () -> + Overlayfs.create ~mode:"1777" ~user [ result; work; merged ]; let lower = String.split_on_char ':' master |> String.concat "\\:" in - Overlayfs.overlay ~lower ~upper:result ~work ~merged >>= fun () -> + Overlayfs.overlay ~lower ~upper:result ~work ~merged; let release () = - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> cache.children <- cache.children - 1; - Overlayfs.umount ~merged >>= fun () -> - Overlayfs.cp ~src:result ~dst:master >>= fun () -> - Overlayfs.delete [ result; work; merged ] + Overlayfs.umount ~merged; + Overlayfs.cp ~src:result ~dst:master; + Overlayfs.delete [ result; work; merged ]) in - Lwt.return (merged, release) + (merged, release)) let delete_cache t name = let () = Printf.printf "0\n" in let cache = get_cache t name in let () = Printf.printf "1\n" in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> let () = Printf.printf "2\n" in (* Ensures in-progress writes will be discarded *) if cache.children > 0 - then Lwt_result.fail `Busy - else - Overlayfs.delete [ Path.cache t name ] >>= fun () -> + then Error `Busy + else ( + Overlayfs.delete [ Path.cache t name ]; let () = Printf.printf "3\n" in - Lwt.return (Ok ()) + Ok ())) -let complete_deletes _t = Lwt.return_unit +let complete_deletes _t = () diff --git a/lib/overlayfs_store.mli b/lib/overlayfs_store.mli index 55e65773..def89070 100644 --- a/lib/overlayfs_store.mli +++ b/lib/overlayfs_store.mli @@ -2,6 +2,6 @@ include S.STORE -val create : path:string -> t Lwt.t +val create : path:string -> t (** [create ~path] creates a new overlayfs store where everything will be stored under [path]. *) diff --git a/lib/qemu_sandbox.ml b/lib/qemu_sandbox.ml index 02beb4f5..c0778413 100644 --- a/lib/qemu_sandbox.ml +++ b/lib/qemu_sandbox.ml @@ -1,4 +1,3 @@ -open Lwt.Infix open Sexplib.Conv include S.Sandbox_default @@ -8,9 +7,9 @@ let ( / ) = Filename.concat let copy_to_log ~src ~dst = let buf = Bytes.create 4096 in let rec aux () = - Lwt_unix.read src buf 0 (Bytes.length buf) >>= function - | 0 -> Lwt.return_unit - | n -> Build_log.write dst (Bytes.sub_string buf 0 n) >>= aux + match Unix.read src buf 0 (Bytes.length buf) with + | 0 -> () + | n -> Build_log.write dst (Bytes.sub_string buf 0 n); aux () in aux () @@ -59,7 +58,7 @@ let run ~cancelled ?stdin ~log t config result_tmp = Os.with_pipe_to_child @@ fun ~r:qemu_r ~w:qemu_w -> let qemu_stdin = `FD_move_safely qemu_r in - let qemu_monitor = Lwt_io.(of_fd ~mode:output) qemu_w in + let qemu_oc = Unix.out_channel_of_descr qemu_w in let port = get_free_port () in let qemu_binary = match t.qemu_guest_arch with | Amd64 -> [ "qemu-system-x86_64"; "-machine"; "accel=kvm,type=pc"; "-cpu"; "host"; "-display"; "none"; @@ -79,90 +78,94 @@ let run ~cancelled ?stdin ~log t config result_tmp = "-netdev"; "user,id=net0," ^ network ^ "hostfwd=tcp::" ^ port ^ "-:22"; "-drive"; "file=" ^ result_tmp / "rootfs" / "image.qcow2" ^ ",if=virtio" ] @ extra_mounts in - let _, proc = Os.open_process ~stdin:qemu_stdin ~stdout:`Dev_null ~pp cmd in + let qemu_pid, proc = Os.open_process ~stdin:qemu_stdin ~stdout:`Dev_null ~pp cmd in let ssh = ["ssh"; "opam@localhost"; "-p"; port; "-o"; "NoHostAuthenticationForLocalhost=yes"] in let rec loop = function - | 0 -> Lwt_result.fail (`Msg "No connection") + | 0 -> Error (`Msg "No connection") | n -> - Os.exec_result ~pp (ssh @ ["exit"]) >>= function - | Ok _ -> Lwt.return_ok () - | _ -> Lwt_unix.sleep 1. >>= fun _ -> loop (n - 1) in - Lwt_unix.sleep 5. >>= fun _ -> - loop t.qemu_boot_time >>= fun _ -> + match Os.exec_result ~pp (ssh @ ["exit"]) with + | Ok _ -> Ok () + | _ -> Unix.sleepf 1.; loop (n - 1) in + Unix.sleepf 5.; + ignore (loop t.qemu_boot_time); - Lwt_list.iteri_s (fun i { Config.Mount.dst; _ } -> + List.iteri (fun i { Config.Mount.dst; _ } -> match t.qemu_guest_os with | Linux -> let dev = Printf.sprintf "/dev/vd%c1" (Char.chr (Char.code 'b' + i)) in Os.exec (ssh @ ["sudo"; "mount"; dev; dst]) | OpenBSD -> let dev = Printf.sprintf "/dev/sd%ca" (Char.chr (Char.code '1' + i)) in - Os.exec (ssh @ ["doas"; "fsck"; "-y"; dev]) >>= fun () -> + Os.exec (ssh @ ["doas"; "fsck"; "-y"; dev]); Os.exec (ssh @ ["doas"; "mount"; dev; dst]) | Windows -> - Os.exec (ssh @ ["cmd"; "/c"; "if exist '" ^ dst ^ "' rmdir /s /q '" ^ dst ^ "'"]) >>= fun () -> + Os.exec (ssh @ ["cmd"; "/c"; "if exist '" ^ dst ^ "' rmdir /s /q '" ^ dst ^ "'"]); let drive_letter = String.init 1 (fun _ -> Char.chr (Char.code 'd' + i)) in Os.exec (ssh @ ["cmd"; "/c"; "mklink /j '" ^ dst ^ "' '" ^ drive_letter ^ ":\\'"]) - ) config.Config.mounts >>= fun () -> - - Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w -> - let stdin = Option.map (fun x -> `FD_move_safely x) stdin in - let stdout = `FD_move_safely out_w in - let stderr = stdout in - let copy_log = copy_to_log ~src:out_r ~dst:log in - let env = List.map (fun (k, v) -> k ^ "=" ^ v) config.Config.env |> Array.of_list in - let sendenv = if Array.length env > 0 then List.map (fun (k, _) -> ["-o"; "SendEnv=" ^ k]) config.Config.env |> List.flatten else [] in - let _, proc2 = Os.open_process ~env ?stdin ~stdout ~stderr ~pp (ssh @ sendenv @ ["cd"; config.Config.cwd; "&&"] @ config.Config.argv) in - Lwt.on_termination cancelled (fun () -> - let aux () = - if Lwt.is_sleeping proc then - Lwt_io.write qemu_monitor "quit\n" - else Lwt.return_unit (* Process has already finished *) - in - Lwt.async aux - ); - Os.process_result ~pp proc2 >>= fun res -> - copy_log >>= fun () -> - - Lwt_list.iter_s (fun { Config.Mount.dst; _ } -> + ) config.Config.mounts; + + let res = + Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w -> + let stdin = Option.map (fun x -> `FD_move_safely x) stdin in + let stdout = `FD_move_safely out_w in + let stderr = stdout in + let env = List.map (fun (k, v) -> k ^ "=" ^ v) config.Config.env |> Array.of_list in + let sendenv = if Array.length env > 0 then List.map (fun (k, _) -> ["-o"; "SendEnv=" ^ k]) config.Config.env |> List.flatten else [] in + let _, proc2 = Os.open_process ~env ?stdin ~stdout ~stderr ~pp (ssh @ sendenv @ ["cd"; config.Config.cwd; "&&"] @ config.Config.argv) in + let res = Os.process_result ~pp proc2 in + copy_to_log ~src:out_r ~dst:log; + res + in + + List.iter (fun { Config.Mount.dst; _ } -> match t.qemu_guest_os with | Linux - | OpenBSD -> Lwt.return_unit + | OpenBSD -> () | Windows -> (* if the junction isn't removed and the target drive is missing, then `mkdir -p /foo` fails *) (* also note that `fsutil reparsepoint delete ` only works if the target exists *) Os.exec (ssh @ ["cmd"; "/c"; "rmdir '" ^ dst ^ "'"]) - ) config.Config.mounts >>= fun () -> + ) config.Config.mounts; (match t.qemu_guest_arch with | Amd64 -> Log.info (fun f -> f "Sending QEMU an ACPI shutdown event"); - Lwt_io.write qemu_monitor "system_powerdown\n" + output_string qemu_oc "system_powerdown\n"; flush qemu_oc | Riscv64 -> (* QEMU RISCV does not support ACPI until >= v9 *) Log.info (fun f -> f "Shutting down the VM"); - Os.exec (ssh @ ["sudo"; "poweroff"])) >>= fun () -> + Os.exec (ssh @ ["sudo"; "poweroff"])); + let qemu_exited = ref false in + let check_qemu_exited () = + if !qemu_exited then true + else + match Unix.waitpid [Unix.WNOHANG] qemu_pid with + | 0, _ -> false + | _ -> qemu_exited := true; true + | exception Unix.Unix_error _ -> qemu_exited := true; true + in let rec loop = function | 0 -> Log.warn (fun f -> f "Powering off QEMU"); - Lwt_io.write qemu_monitor "quit\n" + output_string qemu_oc "quit\n"; flush qemu_oc | n -> - if Lwt.is_sleeping proc then - Lwt_unix.sleep 1. >>= fun () -> + if not (check_qemu_exited ()) then begin + Unix.sleepf 1.; loop (n - 1) - else Lwt.return () in - loop t.qemu_boot_time >>= fun _ -> - - Os.process_result ~pp proc >>= fun _ -> + end in + loop t.qemu_boot_time; + + (* Ensure QEMU process is fully reaped *) + if not !qemu_exited then + ignore (Os.process_result ~pp proc); - if Lwt.is_sleeping cancelled then Lwt.return (res :> (unit, [`Msg of string | `Cancelled]) result) - else Lwt_result.fail `Cancelled + if Eio.Promise.is_resolved cancelled then Error `Cancelled + else (res :> (unit, [`Msg of string | `Cancelled]) result) let create (c : config) = - let t = { qemu_cpus = c.cpus; qemu_memory = c.memory; qemu_guest_os = c.guest_os; qemu_guest_arch = c.guest_arch; qemu_boot_time = c.boot_time } in - Lwt.return t + { qemu_cpus = c.cpus; qemu_memory = c.memory; qemu_guest_os = c.guest_os; qemu_guest_arch = c.guest_arch; qemu_boot_time = c.boot_time } let shell _ = [] diff --git a/lib/qemu_sandbox.mli b/lib/qemu_sandbox.mli index d91e1d02..ad225ccf 100644 --- a/lib/qemu_sandbox.mli +++ b/lib/qemu_sandbox.mli @@ -10,6 +10,6 @@ val cmdliner : config Cmdliner.Term.t necessary flags and parameters to setup a specific sandbox's configuration. *) -val create : config -> t Lwt.t +val create : config -> t (** [create config] is a Docker sandboxing system that is configured using [config]. *) diff --git a/lib/qemu_snapshot.ml b/lib/qemu_snapshot.ml index 91e1fb2a..1104bbc3 100644 --- a/lib/qemu_snapshot.ml +++ b/lib/qemu_snapshot.ml @@ -1,10 +1,7 @@ -open Lwt.Infix - let ( / ) = Filename.concat let fetch ~log:_ ~root ~rootfs base = Os.sudo [ "qemu-img"; "create"; "-f"; "qcow2"; "-b"; root / "base-image" / (base ^ ".qcow2"); - "-F"; "qcow2"; rootfs / "image.qcow2" ] >>= fun () -> - Lwt.return [] - + "-F"; "qcow2"; rootfs / "image.qcow2" ]; + [] diff --git a/lib/qemu_store.ml b/lib/qemu_store.ml index 2d5ac2f8..c616b692 100644 --- a/lib/qemu_store.ml +++ b/lib/qemu_store.ml @@ -1,5 +1,3 @@ -open Lwt.Infix - let strf = Printf.sprintf let running_as_root = Unix.getuid () = 0 @@ -8,7 +6,7 @@ let running_as_root = Unix.getuid () = 0 You must hold a cache's lock when removing or updating its entry in "cache". *) type cache = { - lock : Lwt_mutex.t; + lock : Mutex.t; mutable children : int; } @@ -59,11 +57,11 @@ end let delete t id = let path = Path.result t id in match Os.check_dir path with - | `Missing -> Lwt.return_unit + | `Missing -> () | `Present -> Os.rm ~directory:path let purge path = - Sys.readdir path |> Array.to_list |> Lwt_list.iter_s (fun item -> + Sys.readdir path |> Array.to_list |> List.iter (fun item -> let item = path / item in Log.warn (fun f -> f "Removing left-over temporary item %S" item); Os.rm ~directory:item @@ -73,7 +71,7 @@ let root t = t.root module Stats = Map.Make (String) -let df t = Lwt.return (Os.free_space_percent t.root) +let df t = Os.free_space_percent t.root let create ~root = Os.ensure_dir (root / "result"); @@ -81,42 +79,36 @@ let create ~root = Os.ensure_dir (root / "state"); Os.ensure_dir (root / "cache"); Os.ensure_dir (root / "cache-tmp"); - purge (root / "result-tmp") >>= fun () -> - purge (root / "cache-tmp") >>= fun () -> - Lwt.return { root; caches = Hashtbl.create 10; next = 0 } + purge (root / "result-tmp"); + purge (root / "cache-tmp"); + { root; caches = Hashtbl.create 10; next = 0 } let build t ?base ~id fn = let result = Path.result t id in let result_tmp = Path.result_tmp t id in assert (not (Sys.file_exists result)); (* Builder should have checked first *) - begin match base with - | None -> Lwt.return (Os.ensure_dir result_tmp) - | Some base -> Qemu_img.snapshot ~src:(Path.result t base) result_tmp - end - >>= fun () -> - Lwt.try_bind - (fun () -> fn result_tmp) - (fun r -> - begin match r with - | Ok () -> Os.mv ~src:result_tmp result - | Error _ -> Os.rm ~directory:result_tmp - end >>= fun () -> - Lwt.return r - ) - (fun ex -> - Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); - Os.rm ~directory:result_tmp >>= fun () -> - Lwt.reraise ex - ) + (match base with + | None -> Os.ensure_dir result_tmp + | Some base -> Qemu_img.snapshot ~src:(Path.result t base) result_tmp); + match (try Ok (fn result_tmp) with ex -> Error ex) with + | Ok r -> + (match r with + | Ok () -> Os.mv ~src:result_tmp result + | Error _ -> Os.rm ~directory:result_tmp); + r + | Error ex -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); + Os.rm ~directory:result_tmp; + raise ex let result t id = let dir = Path.result t id in match Os.check_dir dir with - | `Present -> Lwt.return_some dir - | `Missing -> Lwt.return_none + | `Present -> Some dir + | `Missing -> None let log_file t id = - result t id >|= function + match result t id with | Some dir -> dir / "log" | None -> (Path.result_tmp t id) / "log" @@ -124,49 +116,50 @@ let get_cache t name = match Hashtbl.find_opt t.caches name with | Some c -> c | None -> - let c = { lock = Lwt_mutex.create (); children = 0 } in + let c = { lock = Mutex.create (); children = 0 } in Hashtbl.add t.caches name c; c -let cache ~user:_ t name : (string * (unit -> unit Lwt.t)) Lwt.t = +let cache ~user:_ t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> let tmp = Path.cache_tmp t t.next name in t.next <- t.next + 1; let master = Path.cache t name in (* Create cache if it doesn't already exist. *) (match Os.check_dir master with | `Missing -> Qemu_img.create master - | `Present -> Lwt.return ()) >>= fun () -> + | `Present -> ()); cache.children <- cache.children + 1; - let () = Os.ensure_dir tmp in - Os.cp ~src:master tmp >>= fun () -> + Os.ensure_dir tmp; + Os.cp ~src:master tmp; let release () = - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> cache.children <- cache.children - 1; let cache_stat = Unix.stat (Path.image master) in let tmp_stat = Unix.stat (Path.image tmp) in (if tmp_stat.st_size > cache_stat.st_size then - Os.cp ~src:tmp master - else - Lwt.return ()) >>= fun () -> - Os.rm ~directory:tmp + Os.cp ~src:tmp master); + Os.rm ~directory:tmp) in - Lwt.return (tmp, release) + (tmp, release)) let delete_cache t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> if cache.children > 0 - then Lwt_result.fail `Busy + then Error `Busy else let snapshot = Path.cache t name in if Sys.file_exists snapshot then ( - Os.rm ~directory:snapshot >>= fun () -> - Lwt_result.return () - ) else Lwt_result.return () + Os.rm ~directory:snapshot; + Ok () + ) else Ok ()) let state_dir = Path.state let complete_deletes _ = - Lwt.return_unit + () diff --git a/lib/qemu_store.mli b/lib/qemu_store.mli index 31955e31..9cb54dd9 100644 --- a/lib/qemu_store.mli +++ b/lib/qemu_store.mli @@ -2,6 +2,6 @@ include S.STORE -val create : root:string -> t Lwt.t +val create : root:string -> t (** [create ~root] creates a new QEMU store directory where everything will be stored under [root]. *) diff --git a/lib/rsync_store.ml b/lib/rsync_store.ml index f95d2ff0..0fa74ece 100644 --- a/lib/rsync_store.ml +++ b/lib/rsync_store.ml @@ -1,12 +1,11 @@ (* The rsync backend is intended for stability, portability and testing. It is not supposed to be fast nor is it supposed to be particularly memory efficient. *) -open Lwt.Infix (* The caching approach (and much of the code) is copied from the btrfs implementation *) type cache = { - lock : Lwt_mutex.t; + lock : Mutex.t; mutable gen : int; } @@ -25,7 +24,7 @@ type t = { let ( / ) = Filename.concat module Rsync = struct - let create dir = Lwt.return @@ Os.ensure_dir dir + let create dir = Os.ensure_dir dir let delete dir = Os.sudo [ "rm"; "-r"; dir ] @@ -46,7 +45,7 @@ module Rsync = struct in let cmd = rsync @ safe @ ["--link-dest=" ^ base; src ^ "/"; dst ] in Os.ensure_dir dst; - Os.sudo cmd >>= fun () -> + Os.sudo cmd; delete src let copy_children ?chown ~src ~dst () = @@ -81,11 +80,11 @@ end let root t = t.path -let df t = Lwt.return (Os.free_space_percent t.path) +let df t = Os.free_space_percent t.path let create ~path ?(mode = Copy) () = - Rsync.create path >>= fun () -> - Lwt_list.iter_s Rsync.create (Path.dirs path) >|= fun () -> + Rsync.create path; + List.iter Rsync.create (Path.dirs path); { path; mode; caches = Hashtbl.create 10; next = 0 } let build t ?base ~id fn = @@ -93,40 +92,34 @@ let build t ?base ~id fn = let result = Path.result t id in let result_tmp = Path.result_tmp t id in let base = Option.map (Path.result t) base in - begin match base with + (match base with | None -> Rsync.create result_tmp - | Some src -> Rsync.copy_children ~src ~dst:result_tmp () - end - >>= fun () -> - Lwt.try_bind - (fun () -> fn result_tmp) - (fun r -> - begin match r with - | Ok () -> Rsync.rename_with_sharing ~mode:t.mode ~base ~src:result_tmp ~dst:result - | Error _ -> Rsync.delete result_tmp - end >>= fun () -> - Lwt.return r - ) - (fun ex -> - Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); - Rsync.delete result_tmp >>= fun () -> - Lwt.reraise ex - ) + | Some src -> Rsync.copy_children ~src ~dst:result_tmp ()); + match (try Ok (fn result_tmp) with ex -> Error ex) with + | Ok r -> + (match r with + | Ok () -> Rsync.rename_with_sharing ~mode:t.mode ~base ~src:result_tmp ~dst:result + | Error _ -> Rsync.delete result_tmp); + r + | Error ex -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); + Rsync.delete result_tmp; + raise ex let delete t id = let path = Path.result t id in match Os.check_dir path with | `Present -> Rsync.delete path - | `Missing -> Lwt.return_unit + | `Missing -> () let result t id = let dir = Path.result t id in match Os.check_dir dir with - | `Present -> Lwt.return_some dir - | `Missing -> Lwt.return_none + | `Present -> Some dir + | `Missing -> None let log_file t id = - result t id >|= function + match result t id with | Some dir -> dir / "log" | None -> (Path.result_tmp t id) / "log" @@ -136,21 +129,21 @@ let get_cache t name = match Hashtbl.find_opt t.caches name with | Some c -> c | None -> - let c = { lock = Lwt_mutex.create (); gen = 0 } in + let c = { lock = Mutex.create (); gen = 0 } in Hashtbl.add t.caches name c; c let cache ~user t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> let tmp = Path.cache_tmp t t.next name in t.next <- t.next + 1; let snapshot = Path.cache t name in (* Create cache if it doesn't already exist. *) - begin match Os.check_dir snapshot with + (match Os.check_dir snapshot with | `Missing -> Rsync.create snapshot - | `Present -> Lwt.return_unit - end >>= fun () -> + | `Present -> ()); (* Create writeable clone. *) let gen = cache.gen in let { Obuilder_spec.uid; gid } = match user with @@ -158,32 +151,32 @@ let cache ~user t name = | `Windows _ -> assert false (* rsync not supported on Windows *) in (* rsync --chown not supported by the rsync that macOS ships with *) - Rsync.copy_children ~src:snapshot ~dst:tmp () >>= fun () -> - Os.sudo [ "chown"; Printf.sprintf "%d:%d" uid gid; tmp ] >>= fun () -> + Rsync.copy_children ~src:snapshot ~dst:tmp (); + Os.sudo [ "chown"; Printf.sprintf "%d:%d" uid gid; tmp ]; let release () = - Lwt_mutex.with_lock cache.lock @@ fun () -> - begin - if cache.gen = gen then ( - (* The cache hasn't changed since we cloned it. Update it. *) - (* todo: check if it has actually changed. *) - cache.gen <- cache.gen + 1; - Rsync.delete snapshot >>= fun () -> - Rsync.rename ~src:tmp ~dst:snapshot - ) else Lwt.return_unit - end + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> + if cache.gen = gen then ( + (* The cache hasn't changed since we cloned it. Update it. *) + (* todo: check if it has actually changed. *) + cache.gen <- cache.gen + 1; + Rsync.delete snapshot; + Rsync.rename ~src:tmp ~dst:snapshot + )) in - Lwt.return (tmp, release) + (tmp, release)) let delete_cache t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) let snapshot = Path.cache t name in if Sys.file_exists snapshot then ( - Rsync.delete snapshot >>= fun () -> - Lwt_result.return () - ) else Lwt_result.return () + Rsync.delete snapshot; + Ok () + ) else Ok ()) (* Don't think this applies to rsync *) -let complete_deletes _t = Lwt.return_unit +let complete_deletes _t = () diff --git a/lib/rsync_store.mli b/lib/rsync_store.mli index ee0d69d0..a39e6fa9 100644 --- a/lib/rsync_store.mli +++ b/lib/rsync_store.mli @@ -9,7 +9,7 @@ type mode = checksum verification. Only for testing during development, do not use in production. *) -val create : path:string -> ?mode:mode -> unit -> t Lwt.t +val create : path:string -> ?mode:mode -> unit -> t (** [create ~path ?mode ()] creates a new rsync store where everything will be stored under [path]. The [mode] defaults to [Copy] and defines how the caches are reused: [Copy] copies all the files, while [Hardlink] tries diff --git a/lib/s.ml b/lib/s.ml index 345c5faf..2e78e1dc 100644 --- a/lib/s.ml +++ b/lib/s.ml @@ -16,14 +16,14 @@ module type STORE = sig val root : t -> string (** [root t] returns the root of the store. *) - val df : t -> float Lwt.t + val df : t -> float (** [df t] returns the percentage of free space in the store. *) val build : t -> ?base:id -> id:id -> - (string -> (unit, 'e) Lwt_result.t) -> - (unit, 'e) Lwt_result.t + (string -> (unit, 'e) result) -> + (unit, 'e) result (** [build t ~id fn] runs [fn tmpdir] to add a new item to the store under key [id]. On success, [tmpdir] is saved as [id], which can be used as the [base] for further builds, until it is expired from the cache. @@ -34,13 +34,13 @@ module type STORE = sig exists (i.e. for which [result] returns a path). @param base Initialise [tmpdir] as a clone of [base]. *) - val delete : t -> id -> unit Lwt.t + val delete : t -> id -> unit (** [delete t id] removes [id] from the store, if present. *) - val result : t -> id -> string option Lwt.t + val result : t -> id -> string option (** [result t id] is the path of the build result for [id], if present. *) - val log_file : t -> id -> string Lwt.t + val log_file : t -> id -> string (** [log_file t id] is the path of the build logs for [id]. The file may not exist if the build has never been run, or failed. *) @@ -52,7 +52,7 @@ module type STORE = sig user:Obuilder_spec.user -> t -> string -> - (string * (unit -> unit Lwt.t)) Lwt.t + (string * (unit -> unit)) (** [cache ~user t name] creates a writeable copy of the latest snapshot of the cache [name]. It returns the path of this fresh copy and a function which must be called to free it when done. @@ -62,11 +62,11 @@ module type STORE = sig version of the cache, unless the cache has already been updated since it was snapshotted, in which case this writeable copy is simply discarded. *) - val delete_cache : t -> string -> (unit, [> `Busy]) Lwt_result.t + val delete_cache : t -> string -> (unit, [> `Busy]) result (** [delete_cache t name] removes the cache [name], if present. If the cache is currently in use, the store may instead return [Error `Busy]. *) - val complete_deletes : t -> unit Lwt.t + val complete_deletes : t -> unit (** [complete_deletes t] attempts to wait for previously executed deletes to finish, so that the free space is accurate. *) end @@ -75,20 +75,20 @@ module Sandbox_default = struct let tar _ = ["tar"; "-xf"; "-"] let shell _ = if Sys.win32 then ["cmd"; "/S"; "/C"] else ["/usr/bin/env"; "bash"; "-c"] - let finished () = Lwt.return () + let finished () = () end module type SANDBOX = sig type t val run : - cancelled:unit Lwt.t -> + cancelled:unit Eio.Promise.t -> ?stdin:Os.unix_fd -> log:Build_log.t -> t -> Config.t -> string -> - (unit, [`Cancelled | `Msg of string]) Lwt_result.t + (unit, [`Cancelled | `Msg of string]) result (** [run ~cancelled t config dir] runs the operation [config] in a sandbox with root filesystem [dir]. @param cancelled Resolving this kills the process (and returns [`Cancelled]). @@ -102,7 +102,7 @@ module type SANDBOX = sig val tar : t -> string list (** [tar t] Command line to invoke tar for this sandbox. *) - val finished : unit -> unit Lwt.t + val finished : unit -> unit end module type BUILDER = sig @@ -113,20 +113,20 @@ module type BUILDER = sig t -> context -> Obuilder_spec.t -> - (id, [> `Cancelled | `Msg of string]) Lwt_result.t + (id, [> `Cancelled | `Msg of string]) result - val finish : t -> unit Lwt.t + val finish : t -> unit (** [finish builder] close allocated resources and store state (e.g., sqlite3 databases). *) - val delete : ?log:(id -> unit) -> t -> id -> unit Lwt.t + val delete : ?log:(id -> unit) -> t -> id -> unit (** [delete ?log t id] removes [id] from the store, along with all of its dependencies. This is for testing. Note that is not safe to perform builds while deleting: the delete might fail because an item got a new child during the delete, or we might delete something that the build is using. @param log Called just before deleting each item, so it can be displayed. *) - val prune : ?log:(id -> unit) -> t -> before:Unix.tm -> int -> int Lwt.t + val prune : ?log:(id -> unit) -> t -> before:Unix.tm -> int -> int (** [prune t ~before n] attempts to remove up to [n] items from the store, all of which were last used before [before]. Returns the number of items removed. @@ -138,7 +138,7 @@ module type BUILDER = sig val root : t -> string (** [root t] returns the root of the store. *) - val df : t -> float Lwt.t + val df : t -> float (** [df t] returns the percentage of free space in the store. *) val shell : t -> string list @@ -147,14 +147,14 @@ module type BUILDER = sig val cache_stats : t -> int * int (** [cache_stats t] returns the number of cache hits and the number of cache misses. *) - val healthcheck : ?timeout:float -> t -> (unit, [> `Msg of string]) Lwt_result.t + val healthcheck : ?timeout:float -> t -> (unit, [> `Msg of string]) result (** [healthcheck t] performs a check that [t] is working correctly. @param timeout Cancel and report failure after this many seconds. This excludes the time to fetch the base image. *) end module type FETCHER = sig - val fetch : log:Build_log.t -> root:string -> rootfs:string -> string -> Config.env Lwt.t + val fetch : log:Build_log.t -> root:string -> rootfs:string -> string -> Config.env (** [fetch ~log ~root ~rootfs base] initialises the [rootfs] directory by fetching and extracting the [base] image. [root] is the root of the store. Returns the image's environment. @@ -170,31 +170,31 @@ module type DOCKER_CMD = sig type 'a logerr (** Log only standard error of the sub-process. *) - val version : (unit -> (string, [> `Msg of string ]) result Lwt.t) logerr + val version : (unit -> (string, [> `Msg of string ]) result) logerr val pull : - ([< `Docker_image of string ] -> unit Lwt.t) log + ([< `Docker_image of string ] -> unit) log (** Pulls a Docker image. *) val export : - ([< `Docker_container of string ] -> unit Lwt.t) log + ([< `Docker_container of string ] -> unit) log (** Exports a Docker container. *) val image : - ([< `Remove of [< `Docker_image of string ] ] -> unit Lwt.t) log + ([< `Remove of [< `Docker_image of string ] ] -> unit) log (** Operates on a Docker image. *) val rm : - ([ `Docker_container of string ] list -> unit Lwt.t) log + ([ `Docker_container of string ] list -> unit) log (** Removes a Docker container. *) val rmi : - ([ `Docker_image of string ] list -> unit Lwt.t) log + ([ `Docker_image of string ] list -> unit) log (** Removes a list of Docker images. *) val tag : ([< `Docker_image of string ] -> - [< `Docker_image of string ] -> unit Lwt.t) log + [< `Docker_image of string ] -> unit) log (** [tag source_image target_image] creates a new tag for a Docker iamge. *) val commit : ([< `Docker_image of string ] -> [< `Docker_container of string ] -> - [< `Docker_image of string ] -> unit Lwt.t) log + [< `Docker_image of string ] -> unit) log (** [commit base_image container target_image] commits the [container] to the [target_image] using [base_image] (typically the container's base image) entrypoint and cmd. *) @@ -204,16 +204,16 @@ module type DOCKER_CMD = sig | `Inspect of [< `Docker_volume of string ] list * [< `Mountpoint ] | `List of string option | `Remove of [< `Docker_volume of string ] list ] -> - string Lwt.t) logerr + string) logerr (** Operates on Docker volumes. *) val volume_containers : - ([< `Docker_volume of string ] -> [> `Docker_container of string ] list Lwt.t) logerr + ([< `Docker_volume of string ] -> [> `Docker_container of string ] list) logerr (** [volume_containers vol] returns the list of containers using [vol]. *) val mount_point : - ([< `Docker_volume of string ] -> string Lwt.t) logerr + ([< `Docker_volume of string ] -> string) logerr (** [mount_point vol] returns the mount point in the host filesystem of [vol]. *) val build : - (string list -> [< `Docker_image of string ] -> string -> unit Lwt.t) log + (string list -> [< `Docker_image of string ] -> string -> unit) log (** [build docker_args image context_path] builds the Docker [image] using the context located in [context_path]. *) @@ -222,7 +222,7 @@ module type DOCKER_CMD = sig (?is_success:(int -> bool) -> ?name:[< `Docker_container of string ] -> ?rm:bool -> - string list -> [< `Docker_image of string ] -> string list -> unit Lwt.t) log + string list -> [< `Docker_image of string ] -> string list -> unit) log (** [run ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) val run' : ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> @@ -230,7 +230,7 @@ module type DOCKER_CMD = sig (?is_success:(int -> bool) -> ?name:[< `Docker_container of string ] -> ?rm:bool -> - string list -> [< `Docker_image of string ] -> string list -> unit Lwt.t) logerr + string list -> [< `Docker_image of string ] -> string list -> unit) logerr (** [run' ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) val run_result : ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> @@ -238,7 +238,7 @@ module type DOCKER_CMD = sig ?rm:bool -> string list -> [< `Docker_image of string ] -> - string list -> (unit, [> `Msg of string ]) result Lwt.t) log + string list -> (unit, [> `Msg of string ]) result) log (** [run_result ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) val run_result' : ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> @@ -247,7 +247,7 @@ module type DOCKER_CMD = sig ?rm:bool -> string list -> [< `Docker_image of string ] -> - string list -> (unit, [> `Msg of string ]) result Lwt.t) logerr + string list -> (unit, [> `Msg of string ]) result) logerr (** [run_result ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) val run_pread_result : ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> @@ -255,12 +255,12 @@ module type DOCKER_CMD = sig ?rm:bool -> string list -> [< `Docker_image of string ] -> - string list -> (string, [> `Msg of string ]) result Lwt.t) logerr + string list -> (string, [> `Msg of string ]) result) logerr (** [run_pread_result ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) val stop : ([< `Docker_container of string ] -> - (unit, [> `Msg of string ]) result Lwt.t) log + (unit, [> `Msg of string ]) result) log (** Stop a Docker container. *) val manifest : @@ -268,26 +268,26 @@ module type DOCKER_CMD = sig [< `Docker_image of string ] * [< `Docker_image of string ] list | `Inspect of [< `Docker_image of string ] | `Remove of [< `Docker_image of string ] list ] -> - (unit, [> `Msg of string ]) result Lwt.t) log + (unit, [> `Msg of string ]) result) log (** Operates on a Docker manifest. *) val exists : ([< `Docker_container of string | `Docker_image of string | `Docker_volume of string ] -> - (unit, [> `Msg of string ]) result Lwt.t) log + (unit, [> `Msg of string ]) result) log (** Tests if an object exists. *) val obuilder_images : - (?tmp:bool -> unit -> [ `Docker_image of string ] list Lwt.t) logerr + (?tmp:bool -> unit -> [ `Docker_image of string ] list) logerr (** Returns the list of this OBuilder instance images. *) val obuilder_containers : - (unit -> [ `Docker_container of string ] list Lwt.t) logerr + (unit -> [ `Docker_container of string ] list) logerr (** Returns the list of this OBuilder instance containers. *) val obuilder_volumes : - (?prefix:string -> unit -> [ `Docker_volume of string ] list Lwt.t) logerr + (?prefix:string -> unit -> [ `Docker_volume of string ] list) logerr (** Returns the list of this OBuilder instance volumes. *) val obuilder_caches_tmp : - (unit -> [ `Docker_volume of string ] list Lwt.t) logerr + (unit -> [ `Docker_volume of string ] list) logerr (** Returns the list of this OBuilder instance temporary caches. *) end diff --git a/lib/sandbox.jail.ml b/lib/sandbox.jail.ml index a66d4104..9ae68792 100644 --- a/lib/sandbox.jail.ml +++ b/lib/sandbox.jail.ml @@ -1,4 +1,3 @@ -open Lwt.Infix open Sexplib.Conv include S.Sandbox_default @@ -84,18 +83,21 @@ let jail_options config rootdir tmp_dir = let copy_to_log ~src ~dst = let buf = Bytes.create 4096 in let rec aux () = - Lwt_unix.read src buf 0 (Bytes.length buf) >>= function - | 0 -> Lwt.return_unit - | n -> Build_log.write dst (Bytes.sub_string buf 0 n) >>= aux + match Unix.read src buf 0 (Bytes.length buf) with + | 0 -> () + | n -> Build_log.write dst (Bytes.sub_string buf 0 n); aux () in aux () let jail_id = ref 0 let run ~cancelled ?stdin:stdin ~log (t : t) config rootdir = - Lwt_io.with_temp_dir ~prefix:"obuilder-jail-" @@ fun tmp_dir -> + let tmp_dir = Filename.temp_dir "obuilder-jail-" "" in + Fun.protect ~finally:(fun () -> + try ignore (Sys.command ("rm -rf " ^ Filename.quote tmp_dir)) with _ -> () + ) @@ fun () -> let zfs_volume = String.sub rootdir 1 (String.length rootdir - 1) in (* remove / from front *) - Os.sudo [ "zfs"; "inherit"; "mountpoint"; zfs_volume ^ "/rootfs" ] >>= fun () -> + Os.sudo [ "zfs"; "inherit"; "mountpoint"; zfs_volume ^ "/rootfs" ]; let cwd = rootdir in let jail_name = t.jail_name_prefix ^ "_" ^ string_of_int !jail_id in incr jail_id; @@ -105,12 +107,11 @@ let run ~cancelled ?stdin:stdin ~log (t : t) config rootdir = (* Make sure the work directory exists prior to starting the jail. *) begin match Os.check_dir workdir with - | `Present -> Lwt.return_unit + | `Present -> () | `Missing -> Os.sudo [ "mkdir" ; "-p" ; workdir ] - end >>= fun () -> + end; let stdout = `FD_move_safely out_w in let stderr = stdout in - let copy_log = copy_to_log ~src:out_r ~dst:log in let proc = let cmd = let options = jail_options config rootdir tmp_dir in @@ -118,51 +119,34 @@ let run ~cancelled ?stdin:stdin ~log (t : t) config rootdir = in let stdin = Option.map (fun x -> `FD_move_safely x) stdin in let pp f = Os.pp_cmd f ("", cmd) in - (* This is similar to - Os.sudo_result ~cwd ?stdin ~stdout ~stderr ~pp cmd - but also unmounting the in-jail devfs if necessary, see below. *) let cmd = if Os.running_as_root then cmd else "sudo" :: "--" :: cmd in Logs.info (fun f -> f "Exec %a" Os.pp_cmd ("", cmd)); - !Os.lwt_process_exec ~cwd ?stdin ~stdout ~stderr ~pp - ("", Array.of_list cmd) >>= function + match !Os.process_exec ~cwd ?stdin ~stdout ~stderr ~pp + ("", Array.of_list cmd) with | Ok 0 -> let fstab = tmp_dir / "fstab" in - (if Sys.file_exists fstab - then + if Sys.file_exists fstab then begin let cmd = [ "sudo" ; "/sbin/umount" ; "-a" ; "-F" ; fstab ] in Os.exec ~is_success:(fun _ -> true) cmd - else Lwt.return_unit) >>= fun () -> + end; (* If the command within the jail completes, the jail is automatically removed, but without performing any of the stop and release actions, thus we can not use "exec.stop" to unmount the in-jail devfs filesystem. Do this here, ignoring the exit code of umount(8). *) let cmd = [ "sudo" ; "/sbin/umount" ; rootdir / "dev" ] in - Os.exec ~is_success:(fun _ -> true) cmd >>= fun () -> - Lwt_result.ok Lwt.return_unit - | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n - | Error e -> Lwt_result.fail e + Os.exec ~is_success:(fun _ -> true) cmd; + Ok () + | Ok n -> Fmt.error_msg "%t failed with exit status %d" pp n + | Error e -> Error e in - Lwt.on_termination cancelled (fun () -> - let rec aux () = - if Lwt.is_sleeping proc then ( - let pp f = Fmt.pf f "jail -r obuilder" in - Os.sudo_result ~cwd [ "jail" ; "-r" ; jail_name ] ~pp >>= function - | Ok () -> Lwt.return_unit - | Error (`Msg _) -> - Lwt_unix.sleep 10.0 >>= aux - ) else Lwt.return_unit (* Process has already finished *) - in - Lwt.async aux - ); - proc >>= fun r -> - copy_log >>= fun () -> - if Lwt.is_sleeping cancelled then - Lwt.return (r :> (unit, [`Msg of string | `Cancelled]) result) + copy_to_log ~src:out_r ~dst:log; + if Eio.Promise.is_resolved cancelled then + Error `Cancelled else - Lwt_result.fail `Cancelled + (proc :> (unit, [`Msg of string | `Cancelled]) result) let create ~state_dir:_ _c = - Lwt.return { + { (* Compute a unique (across obuilder instances) name prefix for the jail. *) jail_name_prefix = "obuilder_" ^ (Int.to_string (Unix.getpid ())); } diff --git a/lib/sandbox.macos.ml b/lib/sandbox.macos.ml index fc1547c4..82bc68ab 100644 --- a/lib/sandbox.macos.ml +++ b/lib/sandbox.macos.ml @@ -1,4 +1,3 @@ -open Lwt.Infix open Cmdliner include S.Sandbox_default @@ -8,7 +7,7 @@ type t = { gid: int; (* mount point where Homebrew is installed. Either /opt/homebrew or /usr/local depending upon architecture *) brew_path : string; - lock : Lwt_mutex.t; + lock : Mutex.t; } open Sexplib.Conv @@ -31,9 +30,9 @@ let run_as ~env ~user ~cmd = let copy_to_log ~src ~dst = let buf = Bytes.create 4096 in let rec aux () = - Lwt_unix.read src buf 0 (Bytes.length buf) >>= function - | 0 -> Lwt.return_unit - | n -> Build_log.write dst (Bytes.sub_string buf 0 n) >>= aux + match Unix.read src buf 0 (Bytes.length buf) with + | 0 -> () + | n -> Build_log.write dst (Bytes.sub_string buf 0 n); aux () in aux () @@ -47,7 +46,8 @@ let zfs_volume_from path = |> String.concat "/" let run ~cancelled ?stdin:stdin ~log (t : t) config result_tmp = - Lwt_mutex.with_lock t.lock (fun () -> + Mutex.lock t.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock t.lock) @@ fun () -> Log.info (fun f -> f "result_tmp = %s" result_tmp); Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w -> let user = user_name ~prefix:"mac" ~uid:t.uid in @@ -55,66 +55,50 @@ let run ~cancelled ?stdin:stdin ~log (t : t) config result_tmp = let home_dir = Filename.concat "/Users/" user in let zfs_home_dir = Filename.concat zfs_volume "home" in let zfs_brew = Filename.concat zfs_volume "brew" in - Os.sudo [ "zfs"; "set"; "mountpoint=" ^ home_dir; zfs_home_dir ] >>= fun () -> - Os.sudo [ "zfs"; "set"; "mountpoint=" ^ t.brew_path; zfs_brew ] >>= fun () -> - Lwt_list.iter_s (fun { Config.Mount.src; dst; readonly; _ } -> + Os.sudo [ "zfs"; "set"; "mountpoint=" ^ home_dir; zfs_home_dir ]; + Os.sudo [ "zfs"; "set"; "mountpoint=" ^ t.brew_path; zfs_brew ]; + List.iter (fun { Config.Mount.src; dst; readonly; _ } -> Log.info (fun f -> f "src = %s, dst = %s, type %s" src dst (if readonly then "ro" else "rw") ); if Sys.file_exists dst then Os.sudo [ "zfs"; "set"; "mountpoint=" ^ dst; zfs_volume_from src ] - else Lwt.return_unit) config.Config.mounts >>= fun () -> + ) config.Config.mounts; let uid = string_of_int t.uid in let gid = string_of_int t.gid in - Macos.create_new_user ~username:user ~home_dir ~uid ~gid >>= fun _ -> + ignore (Macos.create_new_user ~username:user ~home_dir ~uid ~gid); let osenv = config.Config.env in let stdout = `FD_move_safely out_w in let stderr = stdout in - let copy_log = copy_to_log ~src:out_r ~dst:log in - let proc_id = ref None in - let proc = - let stdin = Option.map (fun x -> `FD_move_safely x) stdin in - let pp f = Os.pp_cmd f ("", config.Config.argv) in - Os.pread @@ Macos.get_tmpdir ~user >>= fun tmpdir -> - let tmpdir = List.hd (String.split_on_char '\n' tmpdir) in - let env = ("TMPDIR", tmpdir) :: osenv in - let cmd = run_as ~env ~user ~cmd:config.Config.argv in - Os.ensure_dir config.Config.cwd; - let pid, proc = Os.open_process ?stdin ~stdout ~stderr ~pp ~cwd:config.Config.cwd cmd in - proc_id := Some pid; - Os.process_result ~pp proc >>= fun r -> - Lwt.return r - in - Lwt.on_termination cancelled (fun () -> - let aux () = - if Lwt.is_sleeping proc then - match !proc_id with - | Some _ -> Macos.kill_users_processes ~uid:t.uid - | None -> Log.warn (fun f -> f "Failed to find pid…"); Lwt.return () - else Lwt.return_unit (* Process has already finished *) - in - Lwt.async aux - ); - proc >>= fun r -> - copy_log >>= fun () -> - Lwt_list.iter_s (fun { Config.Mount.src; dst = _; readonly = _; ty = _ } -> - Os.sudo [ "zfs"; "inherit"; "mountpoint"; zfs_volume_from src ]) config.Config.mounts >>= fun () -> - Macos.sudo_fallback [ "zfs"; "set"; "mountpoint=none"; zfs_home_dir ] [ "zfs"; "unmount"; "-f"; zfs_home_dir ] ~uid:t.uid >>= fun () -> - Macos.sudo_fallback [ "zfs"; "set"; "mountpoint=none"; zfs_brew ] [ "zfs"; "unmount"; "-f"; zfs_brew ] ~uid:t.uid >>= fun () -> - if Lwt.is_sleeping cancelled then - Lwt.return (r :> (unit, [`Msg of string | `Cancelled]) result) - else Lwt_result.fail `Cancelled) + let copy_log () = copy_to_log ~src:out_r ~dst:log in + let tmpdir = Os.pread @@ Macos.get_tmpdir ~user in + let tmpdir = List.hd (String.split_on_char '\n' tmpdir) in + let env = ("TMPDIR", tmpdir) :: osenv in + let cmd = run_as ~env ~user ~cmd:config.Config.argv in + Os.ensure_dir config.Config.cwd; + let stdin = Option.map (fun x -> `FD_move_safely x) stdin in + let pp f = Os.pp_cmd f ("", config.Config.argv) in + let _pid, proc = Os.open_process ?stdin ~stdout ~stderr ~pp ~cwd:config.Config.cwd cmd in + let r = Os.process_result ~pp proc in + copy_log (); + List.iter (fun { Config.Mount.src; dst = _; readonly = _; ty = _ } -> + Os.sudo [ "zfs"; "inherit"; "mountpoint"; zfs_volume_from src ]) config.Config.mounts; + Macos.sudo_fallback [ "zfs"; "set"; "mountpoint=none"; zfs_home_dir ] [ "zfs"; "unmount"; "-f"; zfs_home_dir ] ~uid:t.uid; + Macos.sudo_fallback [ "zfs"; "set"; "mountpoint=none"; zfs_brew ] [ "zfs"; "unmount"; "-f"; zfs_brew ] ~uid:t.uid; + if Eio.Promise.is_resolved cancelled then + Error `Cancelled + else + (r :> (unit, [`Msg of string | `Cancelled]) result) let create ~state_dir:_ c = - Lwt.return { + { uid = c.uid; gid = 1000; brew_path = c.brew_path; - lock = Lwt_mutex.create (); + lock = Mutex.create (); } let finished () = - Os.sudo [ "zfs"; "unmount"; "obuilder/result" ] >>= fun () -> - Os.sudo [ "zfs"; "mount"; "obuilder/result" ] >>= fun () -> - Lwt.return () + Os.sudo [ "zfs"; "unmount"; "obuilder/result" ]; + Os.sudo [ "zfs"; "mount"; "obuilder/result" ] let uid = Arg.required @@ diff --git a/lib/sandbox.mli b/lib/sandbox.mli index fc46c63b..0a2201f3 100644 --- a/lib/sandbox.mli +++ b/lib/sandbox.mli @@ -9,10 +9,10 @@ val cmdliner : config Cmdliner.Term.t (** [cmdliner] is used for command-line interfaces to generate the necessary flags and parameters to setup a specific sandbox's configuration. *) -val create : state_dir:string -> config -> t Lwt.t +val create : state_dir:string -> config -> t (** [create ~state_dir config] is a sandboxing system that keeps state in [state_dir] and is configured using [config]. *) -val finished : unit -> unit Lwt.t +val finished : unit -> unit (** [finished] is a call back to the sandbox which is triggered when the current job is finished. The sandbox may choose do nothing. *) diff --git a/lib/sandbox.runc.ml b/lib/sandbox.runc.ml index c36372e8..f0848593 100644 --- a/lib/sandbox.runc.ml +++ b/lib/sandbox.runc.ml @@ -1,4 +1,3 @@ -open Lwt.Infix open Sexplib.Conv include S.Sandbox_default @@ -279,51 +278,36 @@ end let next_id = ref 0 let run ~cancelled ?stdin:stdin ~log t config results_dir = - Lwt_io.with_temp_dir ~perm:0o700 ~prefix:"obuilder-runc-" @@ fun tmp -> + let tmp = Filename.temp_dir "obuilder-runc-" "" in + Unix.chmod tmp 0o700; + Fun.protect ~finally:(fun () -> + try ignore (Sys.command ("rm -rf " ^ Filename.quote tmp)) with _ -> () + ) @@ fun () -> let json_config = Json_config.make config ~config_dir:tmp ~results_dir t in - Os.write_file ~path:(tmp / "config.json") (Yojson.Safe.pretty_to_string json_config ^ "\n") >>= fun () -> - Os.write_file ~path:(tmp / "hosts") "127.0.0.1 localhost builder" >>= fun () -> - Lwt_list.fold_left_s + Os.write_file ~path:(tmp / "config.json") (Yojson.Safe.pretty_to_string json_config ^ "\n"); + Os.write_file ~path:(tmp / "hosts") "127.0.0.1 localhost builder"; + ignore (List.fold_left (fun id Config.Secret.{value; _} -> - Os.write_file ~path:(tmp / secret_file id) value >|= fun () -> + Os.write_file ~path:(tmp / secret_file id) value; id + 1 - ) 0 config.mount_secrets - >>= fun _ -> + ) 0 config.mount_secrets); let id = string_of_int !next_id in incr next_id; Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w -> let cmd = ["runc"; "--root"; t.runc_state_dir; "run"; id] in let stdout = `FD_move_safely out_w in let stderr = stdout in - let copy_log = Build_log.copy ~src:out_r ~dst:log in - let proc = - let stdin = Option.map (fun x -> `FD_move_safely x) stdin in - let pp f = Os.pp_cmd f ("", config.argv) in - Os.sudo_result ~cwd:tmp ?stdin ~stdout ~stderr ~pp cmd - in - Lwt.on_termination cancelled (fun () -> - let rec aux () = - if Lwt.is_sleeping proc then ( - let pp f = Fmt.pf f "runc kill %S" id in - Os.sudo_result ~cwd:tmp ["runc"; "--root"; t.runc_state_dir; "kill"; id; "KILL"] ~pp >>= function - | Ok () -> Lwt.return_unit - | Error (`Msg m) -> - (* This might be because it hasn't been created yet, so retry. *) - Log.warn (fun f -> f "kill failed: %s (will retry in 10s)" m); - Lwt_unix.sleep 10.0 >>= aux - ) else Lwt.return_unit (* Process has already finished *) - in - Lwt.async aux - ); - proc >>= fun r -> - copy_log >>= fun () -> - if Lwt.is_sleeping cancelled then Lwt.return (r :> (unit, [`Msg of string | `Cancelled]) result) - else Lwt_result.fail `Cancelled + let stdin = Option.map (fun x -> `FD_move_safely x) stdin in + let pp f = Os.pp_cmd f ("", config.argv) in + let r = Os.sudo_result ~cwd:tmp ?stdin ~stdout ~stderr ~pp cmd in + Build_log.copy ~src:out_r ~dst:log; + if Eio.Promise.is_resolved cancelled then Error `Cancelled + else (r :> (unit, [`Msg of string | `Cancelled]) result) let clean_runc dir = Sys.readdir dir |> Array.to_list - |> Lwt_list.iter_s (fun item -> + |> List.iter (fun item -> Log.warn (fun f -> f "Removing left-over runc container %S" item); Os.sudo ["runc"; "--root"; dir; "delete"; "--force"; item] ) @@ -332,7 +316,7 @@ let create ~state_dir (c : config) = Os.ensure_dir state_dir; let arches = get_arches () in Log.info (fun f -> f "Architectures for multi-arch system: %a" Fmt.(Dump.list string) arches); - clean_runc state_dir >|= fun () -> + clean_runc state_dir; { runc_state_dir = state_dir; fast_sync = c.fast_sync; arches } open Cmdliner diff --git a/lib/store_spec.ml b/lib/store_spec.ml index f676651e..bff2c16c 100644 --- a/lib/store_spec.ml +++ b/lib/store_spec.ml @@ -1,7 +1,5 @@ (** Configuration information to set up a store. *) -open Lwt.Infix - type t = [ | `Btrfs of string (* Path *) | `Zfs of string (* Path with pool at end *) @@ -38,26 +36,26 @@ type store = Store : (module S.STORE with type t = 'a) * 'a -> store let to_store = function | `Btrfs path -> - `Native, Btrfs_store.create path >|= fun store -> - Store ((module Btrfs_store), store) + let store = Btrfs_store.create path in + `Native, Store ((module Btrfs_store), store) | `Zfs path -> - `Native, Zfs_store.create ~path >|= fun store -> - Store ((module Zfs_store), store) + let store = Zfs_store.create ~path in + `Native, Store ((module Zfs_store), store) | `Rsync (path, rsync_mode) -> - `Native, Rsync_store.create ~path ~mode:rsync_mode () >|= fun store -> - Store ((module Rsync_store), store) + let store = Rsync_store.create ~path ~mode:rsync_mode () in + `Native, Store ((module Rsync_store), store) | `Xfs path -> - `Native, Xfs_store.create ~path >|= fun store -> - Store ((module Xfs_store), store) + let store = Xfs_store.create ~path in + `Native, Store ((module Xfs_store), store) | `Overlayfs path -> - `Native, Overlayfs_store.create ~path >|= fun store -> - Store ((module Overlayfs_store), store) + let store = Overlayfs_store.create ~path in + `Native, Store ((module Overlayfs_store), store) | `Docker path -> - `Docker, Docker_store.create path >|= fun store -> - Store ((module Docker_store), store) + let store = Docker_store.create path in + `Docker, Store ((module Docker_store), store) | `Qemu root -> - `Qemu, Qemu_store.create ~root >|= fun store -> - Store ((module Qemu_store), store) + let store = Qemu_store.create ~root in + `Qemu, Store ((module Qemu_store), store) open Cmdliner diff --git a/lib/tar_transfer.ml b/lib/tar_transfer.ml index c16cbeb3..83a82478 100644 --- a/lib/tar_transfer.ml +++ b/lib/tar_transfer.ml @@ -1,59 +1,22 @@ -open Lwt.Infix - let ( / ) = Filename.concat let level = Tar.Header.GNU -module Tar_lwt_unix = struct - include Tar_lwt_unix - - (* Copied from tar_lwt_unix.ml (ISC license). Not sure why this isn't exposed. - - ## ISC License - - Copyright (c) 2012-2018 The ocaml-tar contributors - - Permission to use, copy, modify, and/or distribute this software for any - purpose with or without fee is hereby granted, provided that the above - copyright notice and this permission notice appear in all copies. - - THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - - module Writer = struct - type out_channel = Lwt_unix.file_descr - type 'a t = 'a Lwt.t - let really_write fd = Lwt_cstruct.(complete (write fd)) - end - - module HW = Tar.HeaderWriter(Lwt)(Writer) - - let write_block ?level (header: Tar.Header.t) (body: Lwt_unix.file_descr -> unit Lwt.t) (fd : Lwt_unix.file_descr) = - HW.write ?level header fd - >>= fun () -> - body fd >>= fun () -> - Writer.really_write fd (Tar.Header.zero_padding header) - - let write_end (fd: Lwt_unix.file_descr) = - Writer.really_write fd Tar.Header.zero_block >>= fun () -> - Writer.really_write fd Tar.Header.zero_block -end - -let copy_to ~dst src = - let len = 4096 in - let buf = Bytes.create len in - let rec aux () = - Lwt_io.read_into src buf 0 len >>= function - | 0 -> Lwt.return_unit - | n -> Os.write_all dst buf 0 n >>= aux - in - aux () +(* Helper to unwrap tar write operation results *) +let unwrap_write_result = function + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> failwith m + | Error (`Unix (e, fn, arg)) -> + Fmt.failwith "%s(%s): %s" fn arg (Unix.error_message e) + +let rec lwt_write_all fd buf ofs len = + if len = 0 then Lwt.return_unit + else + Lwt.bind (Lwt_unix.write fd buf ofs len) (fun n -> + lwt_write_all fd buf (ofs + n) (len - n)) + +let lwt_write_all_string fd s ofs len = + lwt_write_all fd (Bytes.unsafe_of_string s) ofs len let get_ids = function | `Unix user -> Some user.Obuilder_spec.uid, Some user.gid, None, None @@ -63,37 +26,33 @@ let get_ids = function Some (0x1000 * x + rid), Some (0x1000 * x + rid), Some user.name, Some user.name | `Windows _ -> None, None, None, None -let copy_file ~src ~dst ~to_untar ~user = - Lwt_unix.LargeFile.lstat src >>= fun stat -> - let user_id, group_id, uname, gname = get_ids user in - let hdr = Tar.Header.make - ~file_mode:(if stat.Lwt_unix.LargeFile.st_perm land 0o111 <> 0 then 0o755 else 0o644) - ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) - ?user_id ?group_id ?uname ?gname - dst stat.Lwt_unix.LargeFile.st_size - in - Tar_lwt_unix.write_block ~level hdr (fun ofd -> - let flags = [Unix.O_RDONLY; Unix.O_NONBLOCK; Unix.O_CLOEXEC] in - Lwt_io.(with_file ~mode:input ~flags) src (copy_to ~dst:ofd) - ) to_untar - -let copy_symlink ~src ~target ~dst ~to_untar ~user = - Lwt_unix.LargeFile.lstat src >>= fun stat -> - let user_id, group_id, uname, gname = get_ids user in - let hdr = Tar.Header.make - ~file_mode:0o777 - ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) - ~link_indicator:Tar.Header.Link.Symbolic - ~link_name:target - ?user_id ?group_id ?uname ?gname - dst 0L - in - Tar_lwt_unix.write_block ~level hdr (fun _ -> Lwt.return_unit) to_untar +let copy_file_lwt ~src ~dst ~to_untar ~user = + Lwt.bind (Lwt_unix.LargeFile.lstat src) (fun stat -> + let user_id, group_id, uname, gname = get_ids user in + let hdr = Tar.Header.make + ~file_mode:(if stat.Lwt_unix.LargeFile.st_perm land 0o111 <> 0 then 0o755 else 0o644) + ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) + ?user_id ?group_id ?uname ?gname + dst stat.Lwt_unix.LargeFile.st_size + in + Lwt.bind (Tar_lwt_unix.append_file ~level ~header:hdr src to_untar) unwrap_write_result) -let rec copy_dir ~src_dir ~src ~dst ~(items:(Manifest.t list)) ~to_untar ~user = +let copy_symlink_lwt ~src ~target ~dst ~to_untar ~user = + Lwt.bind (Lwt_unix.LargeFile.lstat src) (fun stat -> + let user_id, group_id, uname, gname = get_ids user in + let hdr = Tar.Header.make + ~file_mode:0o777 + ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) + ~link_indicator:Tar.Header.Link.Symbolic + ~link_name:target + ?user_id ?group_id ?uname ?gname + dst 0L + in + Lwt.bind (Tar_lwt_unix.write_header ~level hdr to_untar) unwrap_write_result) + +let rec copy_dir_lwt ~src_dir ~src ~dst ~(items:(Manifest.t list)) ~to_untar ~user = Log.debug(fun f -> f "Copy dir %S -> %S" src dst); - Lwt_unix.LargeFile.lstat (src_dir / src) >>= fun stat -> - begin + Lwt.bind (Lwt_unix.LargeFile.lstat (src_dir / src)) (fun stat -> let user_id, group_id, uname, gname = get_ids user in let hdr = Tar.Header.make ~file_mode:0o755 @@ -101,45 +60,63 @@ let rec copy_dir ~src_dir ~src ~dst ~(items:(Manifest.t list)) ~to_untar ~user = ?user_id ?group_id ?uname ?gname (dst ^ "/") 0L in - Tar_lwt_unix.write_block ~level hdr (fun _ -> Lwt.return_unit) to_untar - end >>= fun () -> send_dir ~src_dir ~dst ~to_untar ~user items + Lwt.bind (Tar_lwt_unix.write_header ~level hdr to_untar) (fun r -> + Lwt.bind (unwrap_write_result r) (fun () -> + send_dir_lwt ~src_dir ~dst ~to_untar ~user items))) -and send_dir ~src_dir ~dst ~to_untar ~user items = - items |> Lwt_list.iter_s (function +and send_dir_lwt ~src_dir ~dst ~to_untar ~user items = + Lwt_list.iter_s (function | `File (src, _) -> let src = src_dir / src in let dst = dst / Filename.basename src in - copy_file ~src ~dst ~to_untar ~user + copy_file_lwt ~src ~dst ~to_untar ~user | `Symlink (src, target) -> let src = src_dir / src in let dst = dst / Filename.basename src in - copy_symlink ~src ~target ~dst ~to_untar ~user + copy_symlink_lwt ~src ~target ~dst ~to_untar ~user | `Dir (src, items) -> let dst = dst / Filename.basename src in - copy_dir ~src_dir ~src ~dst ~items ~to_untar ~user - ) + copy_dir_lwt ~src_dir ~src ~dst ~items ~to_untar ~user + ) items let remove_leading_slashes = Astring.String.drop ~sat:((=) '/') -let send_files ~src_dir ~src_manifest ~dst_dir ~user ~to_untar = +let write_end_lwt to_untar = + Lwt.bind (Tar_lwt_unix.write_end to_untar) (function + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> failwith m) + +let send_files_lwt ~src_dir ~src_manifest ~dst_dir ~user ~to_untar = let dst = remove_leading_slashes dst_dir in - send_dir ~src_dir ~dst ~to_untar ~user src_manifest >>= fun () -> - Tar_lwt_unix.write_end to_untar + Lwt.bind (send_dir_lwt ~src_dir ~dst ~to_untar ~user src_manifest) (fun () -> + write_end_lwt to_untar) -let send_file ~src_dir ~src_manifest ~dst ~user ~to_untar = +let send_file_lwt ~src_dir ~src_manifest ~dst ~user ~to_untar = let dst = remove_leading_slashes dst in - begin + Lwt.bind begin match src_manifest with | `File (path, _) -> let src = src_dir / path in - copy_file ~src ~dst ~to_untar ~user + copy_file_lwt ~src ~dst ~to_untar ~user | `Symlink (src, target) -> let src = src_dir / src in - copy_symlink ~src ~target ~dst ~to_untar ~user + copy_symlink_lwt ~src ~target ~dst ~to_untar ~user | `Dir (src, items) -> - copy_dir ~src_dir ~src ~dst ~items ~to_untar ~user - end >>= fun () -> - Tar_lwt_unix.write_end to_untar + copy_dir_lwt ~src_dir ~src ~dst ~items ~to_untar ~user + end (fun () -> + write_end_lwt to_untar) + +(* Public direct-style wrappers *) + +let send_files ~src_dir ~src_manifest ~dst_dir ~user ~to_untar = + let lwt_fd = Lwt_unix.of_unix_file_descr ~blocking:true to_untar in + Lwt_eio.run_lwt (fun () -> + send_files_lwt ~src_dir ~src_manifest ~dst_dir ~user ~to_untar:lwt_fd) + +let send_file ~src_dir ~src_manifest ~dst ~user ~to_untar = + let lwt_fd = Lwt_unix.of_unix_file_descr ~blocking:true to_untar in + Lwt_eio.run_lwt (fun () -> + send_file_lwt ~src_dir ~src_manifest ~dst ~user ~to_untar:lwt_fd) let transform ~user fname hdr = (* Make a copy to erase unneeded data from the tar headers. *) @@ -183,6 +160,46 @@ let rec map_transform ~dst transformations = function Log.debug(fun f -> f "Copy dir %S -> %S" src dst); List.iter (map_transform ~dst transformations) items +(* Transform a tar archive: read from source, transform headers, write to dest. + Uses Tar.fold on the source fd with Tar.High to lift writes to the dest fd. *) +let rec transform_archive_lwt ~transform_hdr ~from_tar ~to_untar = + let open Tar.Syntax in + let f ?global:_ hdr () = + let file_size = Int64.to_int hdr.Tar.Header.file_size in + let hdr' = transform_hdr hdr in + if file_size > 0 then begin + (* Read the file content from source (fold handles padding) *) + let* data = Tar.really_read file_size in + (* Write transformed entry to dest *) + Tar_lwt_unix.value ( + Lwt.bind (Tar_lwt_unix.write_header ~level hdr' to_untar) (function + | Error (`Msg m) -> Lwt.return_error (`Msg m) + | Error (`Unix (e, fn, arg)) -> + Lwt.return_error (`Msg (Fmt.str "%s(%s): %s" fn arg (Unix.error_message e))) + | Ok () -> + Lwt.bind (lwt_write_all_string to_untar data 0 file_size) (fun () -> + let padding = Tar.Header.zero_padding hdr' in + let plen = String.length padding in + if plen > 0 then + Lwt.bind (lwt_write_all_string to_untar padding 0 plen) (fun () -> + Lwt.return_ok ()) + else + Lwt.return_ok ()))) + end else begin + (* Directory, symlink, or empty file: just write header *) + Tar_lwt_unix.value ( + Lwt.bind (Tar_lwt_unix.write_header ~level hdr' to_untar) (function + | Error (`Msg m) -> Lwt.return_error (`Msg m) + | Error (`Unix (e, fn, arg)) -> + Lwt.return_error (`Msg (Fmt.str "%s(%s): %s" fn arg (Unix.error_message e))) + | Ok () -> Lwt.return_ok ())) + end + in + Lwt.bind (Tar_lwt_unix.run (Tar.fold f ()) from_tar) (function + | Error err -> + Fmt.failwith "Tar transform error: %a" Tar_lwt_unix.pp_decode_error err + | Ok () -> write_end_lwt to_untar) + and transform_files ~from_tar ~src_manifest ~dst_dir ~user ~to_untar = let dst = remove_leading_slashes dst_dir in let transformations = Hashtbl.create ~random:true 64 in @@ -192,7 +209,10 @@ and transform_files ~from_tar ~src_manifest ~dst_dir ~user ~to_untar = | exception Not_found -> Fmt.failwith "Could not find mapping for %s" file_name | file_name -> file_name in - Tar_lwt_unix.Archive.transform ~level (transform ~user fname) from_tar to_untar + let lwt_from = Lwt_unix.of_unix_file_descr ~blocking:true from_tar in + let lwt_to = Lwt_unix.of_unix_file_descr ~blocking:true to_untar in + Lwt_eio.run_lwt (fun () -> + transform_archive_lwt ~transform_hdr:(transform ~user fname) ~from_tar:lwt_from ~to_untar:lwt_to) let transform_file ~from_tar ~src_manifest ~dst ~user ~to_untar = let dst = remove_leading_slashes dst in @@ -211,8 +231,11 @@ let transform_file ~from_tar ~src_manifest ~dst ~user ~to_untar = | exception Not_found -> Fmt.failwith "Could not find mapping for %s" file_name | file_name -> file_name in - Tar_lwt_unix.Archive.transform ~level (fun hdr -> - let hdr' = transform ~user fname hdr in - Log.debug (fun f -> f "Copying %s -> %s" hdr.Tar.Header.file_name hdr'.Tar.Header.file_name); - hdr') - from_tar to_untar + let lwt_from = Lwt_unix.of_unix_file_descr ~blocking:true from_tar in + let lwt_to = Lwt_unix.of_unix_file_descr ~blocking:true to_untar in + Lwt_eio.run_lwt (fun () -> + transform_archive_lwt ~transform_hdr:(fun hdr -> + let hdr' = transform ~user fname hdr in + Log.debug (fun f -> f "Copying %s -> %s" hdr.Tar.Header.file_name hdr'.Tar.Header.file_name); + hdr') + ~from_tar:lwt_from ~to_untar:lwt_to) diff --git a/lib/tar_transfer.mli b/lib/tar_transfer.mli index 1cf59697..319f64c8 100644 --- a/lib/tar_transfer.mli +++ b/lib/tar_transfer.mli @@ -3,8 +3,8 @@ val send_files : src_manifest:Manifest.t list -> dst_dir:string -> user:Obuilder_spec.user -> - to_untar:Lwt_unix.file_descr -> - unit Lwt.t + to_untar:Unix.file_descr -> + unit (** [send_files ~src_dir ~src_manifest ~dst_dir ~user ~to_untar] writes a tar-format stream to [to_untar] containing all the files listed in [src_manifest], which are loaded from [src_dir]. The file names in the stream are prefixed with [dst_dir]. @@ -15,32 +15,32 @@ val send_file : src_manifest:Manifest.t -> dst:string -> user:Obuilder_spec.user -> - to_untar:Lwt_unix.file_descr -> - unit Lwt.t + to_untar:Unix.file_descr -> + unit (** [send_files ~src_dir ~src_manifest ~dst ~user ~to_untar] writes a tar-format stream to [to_untar] containing the item [src_manifest], which is loaded from [src_dir]. The item will be copied as [dst]. All files are listed as being owned by [user]. *) val transform_files : - from_tar:Lwt_unix.file_descr -> + from_tar:Unix.file_descr -> src_manifest:Manifest.t list -> dst_dir:string -> user:Obuilder_spec.user -> - to_untar:Lwt_unix.file_descr -> - unit Lwt.t + to_untar:Unix.file_descr -> + unit (** [transform_files ~src_dir ~from_tar ~src_manifest ~dst_dir ~user ~to_untar] prefixes the files names of all the files found in [from_tar], a tar archive streamed in input, with [dst_dir], and writes the resulting tar-format stream to [to_untar]. All files are listed as being owned by [user]. *) val transform_file : - from_tar:Lwt_unix.file_descr -> + from_tar:Unix.file_descr -> src_manifest:Manifest.t -> dst:string -> user:Obuilder_spec.user -> - to_untar:Lwt_unix.file_descr -> - unit Lwt.t + to_untar:Unix.file_descr -> + unit (** [transform_files ~src_dir ~from_tar ~src_manifest ~dst ~user ~to_untar] renames the _unique_ file found in [from_tar], a tar archive streamed in input, to [dst], and writes the resulting tar-format stream to diff --git a/lib/xfs_store.ml b/lib/xfs_store.ml index 992a0681..f8ae69a7 100644 --- a/lib/xfs_store.ml +++ b/lib/xfs_store.ml @@ -1,8 +1,7 @@ (* This store will work with any file system which supports reflinks. *) -open Lwt.Infix type cache = { - lock : Lwt_mutex.t; + lock : Mutex.t; mutable gen : int; } @@ -15,7 +14,7 @@ type t = { let ( / ) = Filename.concat module Xfs = struct - let create dir = Lwt.return @@ Os.ensure_dir dir + let create dir = Os.ensure_dir dir let delete dir = Os.sudo [ "rm"; "-r"; dir ] @@ -49,11 +48,11 @@ end let root t = t.path -let df t = Lwt.return (Os.free_space_percent t.path) +let df t = Os.free_space_percent t.path let create ~path = - Xfs.create path >>= fun () -> - Lwt_list.iter_s Xfs.create (Path.dirs path) >|= fun () -> + Xfs.create path; + List.iter Xfs.create (Path.dirs path); { path; caches = Hashtbl.create 10; next = 0 } let build t ?base ~id fn = @@ -61,40 +60,34 @@ let build t ?base ~id fn = let result = Path.result t id in let result_tmp = Path.result_tmp t id in let base = Option.map (Path.result t) base in - begin match base with + (match base with | None -> Xfs.create result_tmp - | Some src -> Xfs.cp ~src ~dst:result_tmp - end - >>= fun () -> - Lwt.try_bind - (fun () -> fn result_tmp) - (fun r -> - begin match r with - | Ok () -> Xfs.rename ~src:result_tmp ~dst:result - | Error _ -> Xfs.delete result_tmp - end >>= fun () -> - Lwt.return r - ) - (fun ex -> - Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); - Xfs.delete result_tmp >>= fun () -> - Lwt.reraise ex - ) + | Some src -> Xfs.cp ~src ~dst:result_tmp); + match (try Ok (fn result_tmp) with ex -> Error ex) with + | Ok r -> + (match r with + | Ok () -> Xfs.rename ~src:result_tmp ~dst:result + | Error _ -> Xfs.delete result_tmp); + r + | Error ex -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); + Xfs.delete result_tmp; + raise ex let delete t id = let path = Path.result t id in match Os.check_dir path with | `Present -> Xfs.delete path - | `Missing -> Lwt.return_unit + | `Missing -> () let result t id = let dir = Path.result t id in match Os.check_dir dir with - | `Present -> Lwt.return_some dir - | `Missing -> Lwt.return_none + | `Present -> Some dir + | `Missing -> None let log_file t id = - result t id >|= function + match result t id with | Some dir -> dir / "log" | None -> (Path.result_tmp t id) / "log" @@ -104,52 +97,52 @@ let get_cache t name = match Hashtbl.find_opt t.caches name with | Some c -> c | None -> - let c = { lock = Lwt_mutex.create (); gen = 0 } in + let c = { lock = Mutex.create (); gen = 0 } in Hashtbl.add t.caches name c; c let cache ~user t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> let tmp = Path.cache_tmp t t.next name in t.next <- t.next + 1; let snapshot = Path.cache t name in (* Create cache if it doesn't already exist. *) - begin match Os.check_dir snapshot with - | `Missing -> Xfs.create snapshot >>= fun () -> + (match Os.check_dir snapshot with + | `Missing -> Xfs.create snapshot; let { Obuilder_spec.uid; gid } = match user with | `Unix user -> user | `Windows _ -> assert false (* xfs not supported on Windows *) in Os.sudo [ "chown"; Printf.sprintf "%d:%d" uid gid; snapshot ] - | `Present -> Lwt.return_unit - end >>= fun () -> + | `Present -> ()); (* Create writeable clone. *) let gen = cache.gen in - Xfs.cp ~src:snapshot ~dst:tmp >>= fun () -> + Xfs.cp ~src:snapshot ~dst:tmp; let release () = - Lwt_mutex.with_lock cache.lock @@ fun () -> - begin - if cache.gen = gen then ( - (* The cache hasn't changed since we cloned it. Update it. *) - (* todo: check if it has actually changed. *) - cache.gen <- cache.gen + 1; - Xfs.delete snapshot >>= fun () -> - Xfs.rename ~src:tmp ~dst:snapshot - ) else - Xfs.delete tmp - end + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> + if cache.gen = gen then ( + (* The cache hasn't changed since we cloned it. Update it. *) + (* todo: check if it has actually changed. *) + cache.gen <- cache.gen + 1; + Xfs.delete snapshot; + Xfs.rename ~src:tmp ~dst:snapshot + ) else + Xfs.delete tmp) in - Lwt.return (tmp, release) + (tmp, release)) let delete_cache t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) let snapshot = Path.cache t name in if Sys.file_exists snapshot then ( - Xfs.delete snapshot >>= fun () -> - Lwt_result.return () - ) else Lwt_result.return () + Xfs.delete snapshot; + Ok () + ) else Ok ()) -let complete_deletes _t = Lwt.return_unit +let complete_deletes _t = () diff --git a/lib/xfs_store.mli b/lib/xfs_store.mli index a0870617..dce0c11e 100644 --- a/lib/xfs_store.mli +++ b/lib/xfs_store.mli @@ -6,6 +6,6 @@ include S.STORE -val create : path:string -> t Lwt.t +val create : path:string -> t (** [create ~path] creates a new XFS store where everything will be stored under [path]. *) diff --git a/lib/zfs_clone.ml b/lib/zfs_clone.ml index 3a281166..527294f0 100644 --- a/lib/zfs_clone.ml +++ b/lib/zfs_clone.ml @@ -1,11 +1,9 @@ -open Lwt.Infix - let ( / ) = Filename.concat (* On FreeBSD the input is rootfs = "/obuilder/result/522fb2a0e81ba278bc1ae7314bd754201505e6493f4f2f40a166c416624a4005/rootfs" with base = "busybox", or base = "freebsd-ocaml-4.14" -> just clone rootfs - + On macOS the input is rootfs = "/Volumes/obuilder/result/522fb2a0e81ba278bc1ae7314bd754201505e6493f4f2f40a166c416624a4005/rootfs" with base = "busybox", or base = "macos-homebrew-ocaml-4.14" -> clone home and brew subvolumes *) @@ -19,11 +17,10 @@ let fetch ~log:_ ~root:_ ~rootfs base = |> remove_on_match "rootfs" |> List.rev in let zfs_rootfs = String.concat "/" path in let base_image = (List.hd path) / "base-image" / base in - Lwt_process.pread ("", [| "zfs"; "list"; "-H"; "-r"; "-o"; "name"; base_image |]) >>= fun output -> - let len = String.length base_image in - String.split_on_char '\n' output |> List.map (fun s -> (s, String.length s)) |> - List.filter (fun (_, l) -> l > len) |> List.map (fun (s, l) -> String.sub s (len + 1) (l - len - 1)) |> - Lwt_list.iter_s (fun subvolume -> - Os.sudo ["zfs"; "clone"; base_image / subvolume ^ "@snap"; zfs_rootfs / subvolume ]) >>= fun () -> - Lwt.return [] - + let output = Os.pread ["zfs"; "list"; "-H"; "-r"; "-o"; "name"; base_image] in + let len = String.length base_image in + String.split_on_char '\n' output |> List.map (fun s -> (s, String.length s)) |> + List.filter (fun (_, l) -> l > len) |> List.map (fun (s, l) -> String.sub s (len + 1) (l - len - 1)) |> + List.iter (fun subvolume -> + Os.sudo ["zfs"; "clone"; base_image / subvolume ^ "@snap"; zfs_rootfs / subvolume ]); + [] diff --git a/lib/zfs_store.ml b/lib/zfs_store.ml index a810c18a..ec0745f2 100644 --- a/lib/zfs_store.ml +++ b/lib/zfs_store.ml @@ -1,6 +1,3 @@ -open Lwt.Infix -open Lwt.Syntax - (* This is rather complicated, because (unlike btrfs): - zfs won't let you delete datasets that other datasets are cloned from. However, you can "promote" a dataset, so that it switches roles with its parent. @@ -26,7 +23,7 @@ open Lwt.Syntax let strf = Printf.sprintf type cache = { - lock : Lwt_mutex.t; + lock : Mutex.t; mutable gen : int; (* Version counter. *) mutable n_clones : int; } @@ -54,8 +51,8 @@ module Dataset : sig val full_name : ?snapshot:string -> ?subvolume:string -> t -> dataset -> string val path : ?snapshot:string -> t -> dataset -> string - val exists : ?snapshot:string -> t -> dataset -> bool Lwt.t - val if_missing : ?snapshot:string -> t -> dataset -> (unit -> unit Lwt.t) -> unit Lwt.t + val exists : ?snapshot:string -> t -> dataset -> bool + val if_missing : ?snapshot:string -> t -> dataset -> (unit -> unit) -> unit end = struct type dataset = string @@ -83,13 +80,14 @@ end = struct | Some snapshot -> strf "%s%s/%s/.zfs/snapshot/%s" t.prefix t.pool ds snapshot let exists ?snapshot t ds = - Lwt_process.pread ("", [| "zfs"; "list"; "-p"; "-H"; full_name t ds ?snapshot |]) >>= function - | "" -> Lwt.return false - | _ -> Lwt.return true + let output = Os.pread ["zfs"; "list"; "-p"; "-H"; full_name t ds ?snapshot] in + match output with + | "" -> false + | _ -> true let if_missing ?snapshot t ds fn = - exists ?snapshot t ds >>= function - | true -> Lwt.return_unit + match exists ?snapshot t ds with + | true -> () | false -> fn () end @@ -125,32 +123,30 @@ module Zfs = struct Os.sudo ["zfs"; "clone"; "--"; Dataset.full_name t src ~snapshot; Dataset.full_name t dst] let mounted ?snapshot t ~ds = - Lwt_process.pread ("", [| "zfs"; "get"; "-pH"; "mounted"; Dataset.full_name t ds ?snapshot |]) >>= fun s -> + let s = Os.pread ["zfs"; "get"; "-pH"; "mounted"; Dataset.full_name t ds ?snapshot] in match ( Scanf.sscanf s "%s %s %s %s" (fun _ _ yesno _ -> yesno = "yes") ) with - | state -> Lwt.return state - | exception Scanf.Scan_failure _ -> Lwt.return false + | state -> state + | exception Scanf.Scan_failure _ -> false let mount ?snapshot t ~ds = - mounted t ~ds ?snapshot >>= fun m -> + let m = mounted t ~ds ?snapshot in if not m then let pp _ ppf = Fmt.pf ppf "zfs mount" in - let* t = Os.sudo_result ~pp:(pp "zfs mount") ~is_success:(fun n -> n = 0 || n = 16) ["zfs"; "mount"; "--"; Dataset.full_name t ds ?snapshot] in + let t = Os.sudo_result ~pp:(pp "zfs mount") ~is_success:(fun n -> n = 0 || n = 16) ["zfs"; "mount"; "--"; Dataset.full_name t ds ?snapshot] in match t with - | Ok () -> Lwt.return () + | Ok () -> () | Error (`Msg m) -> - Log.info (fun f -> f "%s" m); - Lwt.return () - else Lwt.return () + Log.info (fun f -> f "%s" m) let clone_with_children t ~src ~snapshot dst = - Os.sudo ["zfs"; "clone"; "-o"; "canmount=noauto"; "--"; Dataset.full_name t src ~snapshot; Dataset.full_name t dst] >>= fun () -> - Os.sudo ["zfs"; "mount"; Dataset.full_name t dst] >>= fun () -> + Os.sudo ["zfs"; "clone"; "-o"; "canmount=noauto"; "--"; Dataset.full_name t src ~snapshot; Dataset.full_name t dst]; + Os.sudo ["zfs"; "mount"; Dataset.full_name t dst]; let vol = Dataset.full_name t src in let len = String.length vol in - Lwt_process.pread ("", [| "zfs"; "list"; "-H"; "-r"; "-o"; "name"; vol |]) >>= fun output -> + let output = Os.pread ["zfs"; "list"; "-H"; "-r"; "-o"; "name"; vol] in String.split_on_char '\n' output |> List.map (fun s -> (s, String.length s)) |> List.filter (fun (_, l) -> l > len) |> List.map (fun (s, l) -> String.sub s (len + 1) (l - len - 1)) |> - Lwt_list.iter_s (fun subvolume -> Os.sudo ["zfs"; "clone"; "-o"; "mountpoint=none"; "--"; + List.iter (fun subvolume -> Os.sudo ["zfs"; "clone"; "-o"; "mountpoint=none"; "--"; Dataset.full_name t src ~subvolume ~snapshot; Dataset.full_name t dst ~subvolume]) let snapshot t ds ~snapshot = @@ -169,19 +165,19 @@ module Zfs = struct end let delete_if_exists t ds mode = - Dataset.exists t ds >>= function + match Dataset.exists t ds with | true -> Zfs.destroy t ds mode - | false -> Lwt.return_unit + | false -> () let state_dir t = Dataset.path t Dataset.state let root t = t.pool let df t = - Lwt_process.pread ("", [| "zpool"; "list"; "-Hp"; "-o"; "capacity"; t.pool |]) >>= fun s -> + let s = Os.pread ["zpool"; "list"; "-Hp"; "-o"; "capacity"; t.pool] in match (String.trim s) with - | "" -> Lwt.return 0. - | s -> Lwt.return (100. -. float_of_string s) + | "" -> 0. + | s -> 100. -. float_of_string s let prefix_and_pool path = let pool = Filename.basename path in @@ -194,12 +190,12 @@ let create ~path = let prefix, pool = prefix_and_pool path in let t = { pool; prefix; caches = Hashtbl.create 10; next = 0 } in (* Ensure any left-over temporary datasets are removed before we start. *) - delete_if_exists t (Dataset.cache_tmp_group) `And_snapshots_and_clones >>= fun () -> - Dataset.groups |> Lwt_list.iter_s (fun group -> - Dataset.if_missing t group (fun () -> Zfs.create t group) >>= fun () -> + delete_if_exists t (Dataset.cache_tmp_group) `And_snapshots_and_clones; + Dataset.groups |> List.iter (fun group -> + Dataset.if_missing t group (fun () -> Zfs.create t group); Zfs.chown ~user t group - ) >>= fun () -> - Lwt.return t + ); + t (* The builder will always delete child datasets before their parent. It's possible that we crashed after cloning this but before recording that @@ -219,49 +215,43 @@ let build t ?base ~id fn = we don't create the snapshot unless the build succeeds. If we crash with a partially written directory, `result` will see there is no snapshot and we'll end up here and delete it. *) - delete_if_exists t ds `Only >>= fun () -> + delete_if_exists t ds `Only; let clone = Dataset.path t ds in - begin match base with + (match base with | None -> - Zfs.create t ds >>= fun () -> + Zfs.create t ds; Zfs.chown ~user t ds | Some base -> let src = Dataset.result base in - Zfs.clone_with_children t ~src ~snapshot:default_snapshot ds - end - >>= fun () -> - Lwt.try_bind - (fun () -> fn clone) - (function - | Ok () -> - Log.debug (fun f -> f "zfs: build %S succeeded" id); - Zfs.snapshot t ds ~snapshot:default_snapshot >>= fun () -> - (* ZFS can't delete the clone while the snapshot still exists. So I guess we'll just - keep it around? *) - Lwt_result.return () - | Error _ as e -> - Log.debug (fun f -> f "zfs: build %S failed" id); - Zfs.destroy t ds `And_snapshots >>= fun () -> - Lwt.return e - ) - (fun ex -> - Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); - Zfs.destroy t ds `And_snapshots >>= fun () -> - Lwt.reraise ex - ) + Zfs.clone_with_children t ~src ~snapshot:default_snapshot ds); + match (try Ok (fn clone) with ex -> Error ex) with + | Ok (Ok () as e) -> + Log.debug (fun f -> f "zfs: build %S succeeded" id); + Zfs.snapshot t ds ~snapshot:default_snapshot; + (* ZFS can't delete the clone while the snapshot still exists. So I guess we'll just + keep it around? *) + e + | Ok (Error _ as e) -> + Log.debug (fun f -> f "zfs: build %S failed" id); + Zfs.destroy t ds `And_snapshots; + e + | Error ex -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn ex); + Zfs.destroy t ds `And_snapshots; + raise ex let result t id = let ds = Dataset.result id in - Dataset.exists t ds ~snapshot:default_snapshot >>= fun e -> - if e then - Zfs.mount t ~ds >>= fun () -> - Zfs.mount t ~ds ~snapshot:default_snapshot >>= fun () -> + let e = Dataset.exists t ds ~snapshot:default_snapshot in + if e then ( + Zfs.mount t ~ds; + Zfs.mount t ~ds ~snapshot:default_snapshot; let path = Dataset.path t ds ~snapshot:default_snapshot in - Lwt.return_some path - else Lwt.return_none + Some path + ) else None let log_file t id = - result t id >|= function + match result t id with | Some dir -> Filename.concat dir "log" | None -> let ds = Dataset.result id in @@ -272,7 +262,7 @@ let get_cache t name = match Hashtbl.find_opt t.caches name with | Some c -> c | None -> - let c = { lock = Lwt_mutex.create (); gen = 0; n_clones = 0 } in + let c = { lock = Mutex.create (); gen = 0; n_clones = 0 } in Hashtbl.add t.caches name c; c @@ -307,25 +297,27 @@ let get_tmp_ds t name = - We might crash before making the main@snap tag. If main is missing this tag, it is safe to create it, since we must have been just about to do that. *) -let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t = +let cache ~user t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> Log.debug (fun f -> f "zfs: get cache %S" (name :> string)); let gen = cache.gen in let main_ds = Dataset.cache name in let tmp_ds = get_tmp_ds t name in (* Create the cache as an empty directory if it doesn't exist. *) - Dataset.if_missing t main_ds (fun () -> Zfs.create t main_ds) >>= fun () -> + Dataset.if_missing t main_ds (fun () -> Zfs.create t main_ds); (* Ensure we have the snapshot. This is needed on first creation, and also to recover from crashes. *) Dataset.if_missing t main_ds ~snapshot:default_snapshot (fun () -> - Zfs.chown ~user t main_ds >>= fun () -> + Zfs.chown ~user t main_ds; Zfs.snapshot t main_ds ~snapshot:default_snapshot - ) >>= fun () -> + ); cache.n_clones <- cache.n_clones + 1; - Zfs.clone t ~src:main_ds ~snapshot:default_snapshot tmp_ds >>= fun () -> + Zfs.clone t ~src:main_ds ~snapshot:default_snapshot tmp_ds; let release () = - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> Log.debug (fun f -> f "zfs: release cache %S" (name :> string)); cache.n_clones <- cache.n_clones - 1; if cache.gen = gen then ( @@ -335,51 +327,51 @@ let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t = (* Rename main to something temporary, so if we crash here then we'll just start again with an empty cache next time. *) let delete_me = get_tmp_ds t name in - Zfs.rename t ~old:main_ds delete_me >>= fun () -> - Zfs.promote t tmp_ds >>= fun () -> + Zfs.rename t ~old:main_ds delete_me; + Zfs.promote t tmp_ds; (* At this point: - All the other clones of main are now clones of tmp_ds. - main@snap has moved to tmp@snap. - Any other tags were older than snap and so have also moved to tmp. *) - Zfs.destroy t delete_me `Only >>= fun () -> + Zfs.destroy t delete_me `Only; (* Move the old @snap tag out of the way. *) let archive_name = strf "old-%d" gen in (* We know [archive_name] doesn't exist because [gen] is unique for this process, and we delete stale tmp dirs from previous runs at start-up, which would remove any such deferred tags. *) - Zfs.rename_snapshot t tmp_ds ~old:default_snapshot archive_name >>= fun () -> + Zfs.rename_snapshot t tmp_ds ~old:default_snapshot archive_name; (* Mark the archived snapshot for removal. If other clones are using it, this will defer the deletion until they're done *) - Zfs.destroy_snapshot t tmp_ds archive_name `Defer >>= fun () -> + Zfs.destroy_snapshot t tmp_ds archive_name `Defer; (* Create the new snapshot and rename this as the new main_ds. *) - Zfs.snapshot t tmp_ds ~snapshot:default_snapshot >>= fun () -> + Zfs.snapshot t tmp_ds ~snapshot:default_snapshot; Zfs.rename t ~old:tmp_ds main_ds ) else ( (* We have no snapshots or clones here. *) - Lwt.catch (fun () -> Zfs.destroy t tmp_ds `Only) - (fun ex -> - Log.warn (fun f -> f "Error trying to release cache (will retry): %a" Fmt.exn ex); - (* XXX: Don't know what's causing this. By the time fuser runs, the problem has disappeared! *) - Unix.system (strf "fuser -mv %S" (Dataset.path t tmp_ds)) |> ignore; - Lwt_unix.sleep 10.0 >>= fun () -> - Zfs.destroy t tmp_ds `Only - ) - ) + (try Zfs.destroy t tmp_ds `Only + with ex -> + Log.warn (fun f -> f "Error trying to release cache (will retry): %a" Fmt.exn ex); + (* XXX: Don't know what's causing this. By the time fuser runs, the problem has disappeared! *) + Unix.system (strf "fuser -mv %S" (Dataset.path t tmp_ds)) |> ignore; + Unix.sleepf 10.0; + Zfs.destroy t tmp_ds `Only) + )) in - Lwt.return (Dataset.path t tmp_ds, release) + (Dataset.path t tmp_ds, release)) let delete_cache t name = let cache = get_cache t name in - Lwt_mutex.with_lock cache.lock @@ fun () -> + Mutex.lock cache.lock; + Fun.protect ~finally:(fun () -> Mutex.unlock cache.lock) (fun () -> Log.debug (fun f -> f "zfs: delete_cache %S" (name :> string)); - if cache.n_clones > 0 then Lwt_result.fail `Busy + if cache.n_clones > 0 then Error `Busy else let main_ds = Dataset.cache name in - Dataset.exists t main_ds >>= function - | true -> Zfs.destroy t main_ds `And_snapshots >>= fun () -> - Lwt_result.return () - | false -> Lwt_result.return () + match Dataset.exists t main_ds with + | true -> Zfs.destroy t main_ds `And_snapshots; + Ok () + | false -> Ok ()) let complete_deletes _t = (* The man-page says "Pending changes are generally accounted for within a few seconds" *) - Lwt_unix.sleep 5.0 + Unix.sleepf 5.0 diff --git a/lib/zfs_store.mli b/lib/zfs_store.mli index fa22c552..f3807202 100644 --- a/lib/zfs_store.mli +++ b/lib/zfs_store.mli @@ -2,7 +2,7 @@ include S.STORE -val create : path:string -> t Lwt.t +val create : path:string -> t (** [create ~path] creates a new zfs store in a pool mounted at [path]. The pool name is [Filename.basename path]. If only a poolname is passed such as [tank] the path is inferred as [/tank].*) diff --git a/main.ml b/main.ml index 3b4e0870..76ed04ae 100644 --- a/main.ml +++ b/main.ml @@ -1,5 +1,3 @@ -open Lwt.Infix - let ( / ) = Filename.concat module Native_sandbox = Obuilder.Native_sandbox @@ -19,25 +17,25 @@ let log tag msg = | `Note -> Fmt.pr "%a@." Fmt.(styled (`Fg `Yellow) string) msg | `Output -> output_string stdout msg; flush stdout -let create_builder store_spec conf = - store_spec >>= fun (Store_spec.Store ((module Store), store)) -> +let create_builder ~sw store_spec conf = + let (Store_spec.Store ((module Store), store)) = store_spec in let module Builder = Obuilder.Builder (Store) (Native_sandbox) (Docker_extract) in - Native_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> - let builder = Builder.v ~store ~sandbox in + let sandbox = Native_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf in + let builder = Builder.v ~sw ~store ~sandbox in Builder ((module Builder), builder) -let create_docker_builder store_spec conf = - store_spec >>= fun (Store_spec.Store ((module Store), store)) -> +let create_docker_builder ~sw store_spec conf = + let (Store_spec.Store ((module Store), store)) = store_spec in let module Builder = Obuilder.Docker_builder (Store) in - Docker_sandbox.create conf >|= fun sandbox -> - let builder = Builder.v ~store ~sandbox in + let sandbox = Docker_sandbox.create conf in + let builder = Builder.v ~sw ~store ~sandbox in Builder ((module Builder), builder) -let create_qemu_builder store_spec conf = - store_spec >>= fun (Store_spec.Store ((module Store), store)) -> +let create_qemu_builder ~sw store_spec conf = + let (Store_spec.Store ((module Store), store)) = store_spec in let module Builder = Obuilder.Builder (Store) (Qemu_sandbox) (Qemu_snapshot) in - Qemu_sandbox.create conf >|= fun sandbox -> - let builder = Builder.v ~store ~sandbox in + let sandbox = Qemu_sandbox.create conf in + let builder = Builder.v ~sw ~store ~sandbox in Builder ((module Builder), builder) let read_whole_file path = @@ -46,68 +44,74 @@ let read_whole_file path = let len = in_channel_length ic in really_input_string ic len -let select_backend (sandbox, store_spec) native_conf docker_conf qemu_conf = +let select_backend ~sw (sandbox, store_spec) native_conf docker_conf qemu_conf = match sandbox with - | `Native -> create_builder store_spec native_conf - | `Docker -> create_docker_builder store_spec docker_conf - | `Qemu -> create_qemu_builder store_spec qemu_conf + | `Native -> create_builder ~sw store_spec native_conf + | `Docker -> create_docker_builder ~sw store_spec docker_conf + | `Qemu -> create_qemu_builder ~sw store_spec qemu_conf let build () store spec native_conf docker_conf qemu_conf src_dir secrets = - Lwt_main.run begin - select_backend store native_conf docker_conf qemu_conf - >>= fun (Builder ((module Builder), builder)) -> - Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> - let spec = - try Obuilder.Spec.t_of_sexp (Sexplib.Sexp.load_sexp spec) - with Failure msg -> - print_endline msg; - exit 1 - in - let secrets = List.map (fun (id, path) -> id, read_whole_file path) secrets in - let context = Obuilder.Context.v ~log ~src_dir ~shell:(Builder.shell builder) ~secrets () in - Builder.build builder context spec >>= function - | Ok x -> - Fmt.pr "Got: %S@." (x :> string); - Lwt.return_unit - | Error `Cancelled -> - Fmt.epr "Cancelled at user's request@."; - exit 1 - | Error (`Msg m) -> - Fmt.epr "Build step failed: %s@." m; + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:(Eio.Stdenv.clock env) @@ fun () -> + Eio.Switch.run @@ fun sw -> + let (Builder ((module Builder), builder)) = + select_backend ~sw store native_conf docker_conf qemu_conf + in + Fun.protect ~finally:(fun () -> Builder.finish builder) @@ fun () -> + let spec = + try Obuilder.Spec.t_of_sexp (Sexplib.Sexp.load_sexp spec) + with Failure msg -> + print_endline msg; exit 1 - end + in + let secrets = List.map (fun (id, path) -> id, read_whole_file path) secrets in + let context = Obuilder.Context.v ~log ~src_dir ~shell:(Builder.shell builder) ~secrets () in + match Builder.build builder context spec with + | Ok x -> + Fmt.pr "Got: %S@." (x :> string) + | Error `Cancelled -> + Fmt.epr "Cancelled at user's request@."; + exit 1 + | Error (`Msg m) -> + Fmt.epr "Build step failed: %s@." m; + exit 1 let healthcheck () store native_conf docker_conf qemu_conf = - Lwt_main.run begin - select_backend store native_conf docker_conf qemu_conf - >>= fun (Builder ((module Builder), builder)) -> - Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> - Builder.healthcheck builder >|= function - | Error (`Msg m) -> - Fmt.epr "Healthcheck failed: %s@." m; - exit 1 - | Ok () -> - Fmt.pr "Healthcheck passed@." - end + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:(Eio.Stdenv.clock env) @@ fun () -> + Eio.Switch.run @@ fun sw -> + let (Builder ((module Builder), builder)) = + select_backend ~sw store native_conf docker_conf qemu_conf + in + Fun.protect ~finally:(fun () -> Builder.finish builder) @@ fun () -> + match Builder.healthcheck builder with + | Error (`Msg m) -> + Fmt.epr "Healthcheck failed: %s@." m; + exit 1 + | Ok () -> + Fmt.pr "Healthcheck passed@." let delete () store native_conf docker_conf qemu_conf id = - Lwt_main.run begin - select_backend store native_conf docker_conf qemu_conf - >>= fun (Builder ((module Builder), builder)) -> - Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> - Builder.delete builder id ~log:(fun id -> Fmt.pr "Removing %s@." id) - end + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:(Eio.Stdenv.clock env) @@ fun () -> + Eio.Switch.run @@ fun sw -> + let (Builder ((module Builder), builder)) = + select_backend ~sw store native_conf docker_conf qemu_conf + in + Fun.protect ~finally:(fun () -> Builder.finish builder) @@ fun () -> + Builder.delete builder id ~log:(fun id -> Fmt.pr "Removing %s@." id) let clean () store native_conf docker_conf qemu_conf = - Lwt_main.run begin - select_backend store native_conf docker_conf qemu_conf - >>= fun (Builder ((module Builder), builder)) -> - Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ begin fun () -> - let now = Unix.(gmtime (gettimeofday ())) in - Builder.prune builder ~before:now max_int ~log:(fun id -> Fmt.pr "Removing %s@." id) - end >|= fun n -> - Fmt.pr "Removed %d items@." n - end + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:(Eio.Stdenv.clock env) @@ fun () -> + Eio.Switch.run @@ fun sw -> + let (Builder ((module Builder), builder)) = + select_backend ~sw store native_conf docker_conf qemu_conf + in + Fun.protect ~finally:(fun () -> Builder.finish builder) @@ fun () -> + let now = Unix.(gmtime (gettimeofday ())) in + let n = Builder.prune builder ~before:now max_int ~log:(fun id -> Fmt.pr "Removing %s@." id) in + Fmt.pr "Removed %d items@." n let dockerfile () buildkit escape spec = Sexplib.Sexp.load_sexp spec diff --git a/obuilder.opam b/obuilder.opam index 5346a1b2..d4b7205c 100644 --- a/obuilder.opam +++ b/obuilder.opam @@ -25,12 +25,15 @@ doc: "https://ocurrent.github.io/obuilder/" bug-reports: "https://github.com/ocurrent/obuilder/issues" depends: [ "dune" {>= "3.16"} + "eio" {>= "1.3"} + "eio_main" "lwt" {>= "5.7.0"} + "lwt_eio" "astring" "fmt" {>= "0.8.9"} "logs" "cmdliner" {>= "1.3.0"} - "tar-unix" {>= "2.6.0" & < "3.0.0"} + "tar-unix" {>= "2.6.0"} "yojson" {>= "1.6.0"} "sexplib" "ppx_deriving" @@ -41,8 +44,8 @@ depends: [ "obuilder-spec" {= version} "fpath" "extunix" {>= "0.4.2"} - "ocaml" {>= "4.14.2"} - "alcotest-lwt" {>= "1.7.0" & with-test} + "ocaml" {>= "5.2.0"} + "alcotest" {>= "1.7.0" & with-test} "odoc" {with-doc} ] build: [ diff --git a/stress/dune b/stress/dune index 4d59814c..0ee5ccb9 100644 --- a/stress/dune +++ b/stress/dune @@ -1,6 +1,6 @@ ; No-op test to attach stress.exe to the obuilder package (test (name stress) - (libraries obuilder cmdliner fmt.tty) + (libraries obuilder eio_main cmdliner fmt.tty) (package obuilder) (action (progn))) diff --git a/stress/stress.ml b/stress/stress.ml index 95df2ff4..cd66af32 100644 --- a/stress/stress.ml +++ b/stress/stress.ml @@ -1,14 +1,13 @@ -open Lwt.Infix open Obuilder let ( / ) = Filename.concat let strf = Printf.sprintf let read path = - Lwt_io.(with_file ~mode:input) path Lwt_io.read + In_channel.with_open_bin path In_channel.input_all let write ~path data = - Lwt_io.(with_file ~mode:output) path (fun ch -> Lwt_io.write ch data) + Out_channel.with_open_bin path (fun ch -> Out_channel.output_string ch data) let assert_str expected got = if expected <> got then ( @@ -18,40 +17,38 @@ let assert_str expected got = module Test(Store : S.STORE) = struct let assert_output expected t id = - Store.result t id >>= function + match Store.result t id with | None -> Fmt.failwith "%S not in store!" id | Some path -> let ch = open_in (path / "output") in let data = really_input_string ch (in_channel_length ch) in close_in ch; - assert_str expected data; - Lwt.return_unit + assert_str expected data let test_store t = - Store.result t "unknown" >>= fun r -> assert (r = None); + let r = Store.result t "unknown" in assert (r = None); (* Build without a base *) - Store.delete t "base" >>= fun () -> - Store.build t ~id:"base" (fun tmpdir -> write ~path:(tmpdir / "output") "ok" >|= Result.ok) >>= fun r -> + Store.delete t "base"; + let r = Store.build t ~id:"base" (fun tmpdir -> write ~path:(tmpdir / "output") "ok"; Ok ()) in assert (r = Ok ()); - assert_output "ok" t "base" >>= fun () -> + assert_output "ok" t "base"; (* Build with a base *) - Store.delete t "sub" >>= fun () -> - Store.build t ~base:"base" ~id:"sub" (fun tmpdir -> - read (tmpdir / "output") >>= fun orig -> - write ~path:(tmpdir / "output") (orig ^ "+") >|= Result.ok - ) >>= fun r -> + Store.delete t "sub"; + let r = Store.build t ~base:"base" ~id:"sub" (fun tmpdir -> + let orig = read (tmpdir / "output") in + write ~path:(tmpdir / "output") (orig ^ "+"); Ok () + ) in assert (r = Ok ()); - assert_output "ok+" t "sub" >>= fun () -> + assert_output "ok+" t "sub"; (* Test deletion *) - Store.result t "sub" >>= fun r -> assert (r <> None); - Store.delete t "sub" >>= fun () -> - Store.result t "sub" >>= fun r -> assert (r = None); + let r = Store.result t "sub" in assert (r <> None); + Store.delete t "sub"; + let r = Store.result t "sub" in assert (r = None); (* A failing build isn't saved *) - Store.delete t "fail" >>= fun () -> - Store.build t ~id:"fail" (fun _tmpdir -> Lwt_result.fail `Failed) >>= fun r -> + Store.delete t "fail"; + let r = Store.build t ~id:"fail" (fun _tmpdir -> Error `Failed) in assert (r = Error `Failed); - Store.result t "fail" >>= fun r -> assert (r = None); - Lwt.return_unit + let r = Store.result t "fail" in assert (r = None) let test_cache t = let uid = Unix.getuid () in @@ -59,56 +56,54 @@ module Test(Store : S.STORE) = struct let user = `Unix { Spec.uid = 123; gid = 456 } in let id = "c1" in (* Create a new cache *) - Store.delete_cache t id >>= fun x -> + let x = Store.delete_cache t id in assert (x = Ok ()); - Store.cache ~user t id >>= fun (c, r) -> + let (c, r) = Store.cache ~user t id in assert ((Unix.lstat c).Unix.st_uid = 123); assert ((Unix.lstat c).Unix.st_gid = 456); let user = `Unix { Spec.uid; gid } in - Os.exec ["sudo"; "chown"; Printf.sprintf "%d:%d" uid gid; "--"; c] >>= fun () -> + Os.exec ["sudo"; "chown"; Printf.sprintf "%d:%d" uid gid; "--"; c]; assert (Sys.readdir c = [| |]); - write ~path:(c / "data") "v1" >>= fun () -> - r () >>= fun () -> + write ~path:(c / "data") "v1"; + r (); (* Check it worked *) - Store.cache ~user t id >>= fun (c, r) -> - read (c / "data") >>= fun data -> + let (c, r) = Store.cache ~user t id in + let data = read (c / "data") in assert_str "v1" data; - r () >>= fun () -> + r (); (* Concurrent updates *) - Store.cache ~user t id >>= fun (c1, r1) -> - Store.cache ~user t id >>= fun (c2, r2) -> - write ~path:(c1 / "data") "v2a" >>= fun () -> - write ~path:(c2 / "data") "v2b" >>= fun () -> - r2 () >>= fun () -> (* v2b wins *) - r1 () >>= fun () -> + let (c1, r1) = Store.cache ~user t id in + let (c2, r2) = Store.cache ~user t id in + write ~path:(c1 / "data") "v2a"; + write ~path:(c2 / "data") "v2b"; + r2 (); (* v2b wins *) + r1 (); (* Check it worked *) - Store.cache ~user t id >>= fun (c, r) -> - read (c / "data") >>= fun data -> + let (c, r) = Store.cache ~user t id in + let data = read (c / "data") in assert_str "v2b" data; - r () >>= fun () -> + r (); (* Concurrent delete *) - Store.cache ~user t id >>= fun (c, r) -> - write ~path:(c / "data") "v3" >>= fun () -> - Store.delete_cache t id >>= function + let (c, r) = Store.cache ~user t id in + write ~path:(c / "data") "v3"; + match Store.delete_cache t id with | Ok () -> (* Btrfs allows deletion here *) - r () >>= fun () -> (* (not saved) *) - Store.cache ~user t id >>= fun (c, r) -> + r (); (* (not saved) *) + let (c, r) = Store.cache ~user t id in assert (not (Sys.file_exists (c / "data"))); - r () >>= fun () -> - Lwt.return_unit + r () | Error `Busy -> (* Zfs does not *) - r () >>= fun () -> + r (); (* Now it can be deleted. *) - Store.delete_cache t id >>= fun x -> - assert (x = Ok ()); - Lwt.return_unit + let x = Store.delete_cache t id in + assert (x = Ok ()) type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder - let create_builder store conf = + let create_builder ~sw store conf = let module Builder = Obuilder.Builder(Store)(Native_sandbox)(Obuilder.Docker_extract) in - Native_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> - let builder = Builder.v ~store ~sandbox in + let sandbox = Native_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf in + let builder = Builder.v ~sw ~store ~sandbox in Builder ((module Builder), builder) let n_steps = 4 @@ -153,60 +148,61 @@ module Test(Store : S.STORE) = struct in let ctx = Context.v ~shell:["/bin/sh"; "-c"] ~log ~src_dir () in let check_log, spec = random_build () in - Builder.build builder ctx spec >>= function + match Builder.build builder ctx spec with | Ok _ -> - check_log (Buffer.contents buf); - Lwt.return_unit + check_log (Buffer.contents buf) | Error (`Msg m) -> failwith m | Error `Cancelled -> assert false - let stress_builds store conf = - create_builder store conf >>= fun builder -> + let stress_builds ~sw store conf = + let builder = create_builder ~sw store conf in let (Builder ((module Builder), _)) = builder in let pending = ref n_jobs in let running = ref 0 in - let cond = Lwt_condition.create () in + let cond = Eio.Condition.create () in + let mutex = Eio.Mutex.create () in let failures = ref 0 in + Eio.Switch.run @@ fun sw -> let rec aux () = - if !running = 0 && !pending = 0 then Lwt.return_unit + if !running = 0 && !pending = 0 then () else if !running < max_running && !pending > 0 then ( if !pending mod 10 = 0 then Fmt.pr "%d pending: starting new build@." !pending; incr running; decr pending; - let th = do_build builder in - Lwt.on_any th - (fun () -> - decr running; - Lwt_condition.broadcast cond () - ) - (fun ex -> - Logs.warn (fun f -> f "Build failed: %a" Fmt.exn ex); - decr running; - incr failures; - Lwt_condition.broadcast cond () - ); + Eio.Fiber.fork ~sw (fun () -> + begin + try do_build builder + with ex -> + Logs.warn (fun f -> f "Build failed: %a" Fmt.exn ex); + incr failures + end; + decr running; + Eio.Condition.broadcast cond + ); aux () ) else ( - Lwt_condition.wait cond >>= aux + Eio.Mutex.lock mutex; + Eio.Condition.await cond mutex; + Eio.Mutex.unlock mutex; + aux () ) in let t0 = Unix.gettimeofday () in - aux () >>= fun () -> + aux (); let time = Unix.gettimeofday () -. t0 in Fmt.pr "Ran %d jobs (max %d at once). %d failures. Took %.1f s (%.1f jobs/s)@." n_jobs max_running !failures time (float n_jobs /. time); if !failures > 0 then Fmt.failwith "%d failures!" !failures - else Lwt.return_unit - let prune store conf = - create_builder store conf >>= fun (Builder ((module Builder), builder)) -> + let prune ~sw store conf = + let (Builder ((module Builder), builder)) = create_builder ~sw store conf in let log id = Logs.info (fun f -> f "Deleting %S" id) in let end_time = Unix.(gettimeofday () +. 60.0 |> gmtime) in let rec aux () = - Fmt.pr "Pruning…@."; - Builder.prune ~log builder ~before:end_time 1000 >>= function - | 0 -> Lwt.return_unit + Fmt.pr "Pruning...@."; + match Builder.prune ~log builder ~before:end_time 1000 with + | 0 -> () | _ -> aux () in aux () @@ -217,14 +213,15 @@ let stress (sandbox, spec) conf = prerr_endline "Cannot stress-test the Docker backend"; exit 1 end; - Lwt_main.run begin - spec >>= fun (Store_spec.Store ((module Store), store)) -> - let module T = Test(Store) in - T.test_store store >>= fun () -> - T.test_cache store >>= fun () -> - T.stress_builds store conf >>= fun () -> - T.prune store conf - end + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:(Eio.Stdenv.clock env) @@ fun () -> + Eio.Switch.run @@ fun sw -> + let (Store_spec.Store ((module Store), store)) = spec in + let module T = Test(Store) in + T.test_store store; + T.test_cache store; + T.stress_builds ~sw store conf; + T.prune ~sw store conf open Cmdliner diff --git a/test/dune b/test/dune index c56d7242..285f4dc5 100644 --- a/test/dune +++ b/test/dune @@ -10,7 +10,7 @@ (name test) (package obuilder) (deps base.tar manifest.bash %{bin:dummy}) - (libraries alcotest-lwt obuilder str logs.fmt) + (libraries alcotest eio_main obuilder str logs.fmt) (modules log mock_exec mock_sandbox mock_store test)) (dirs :standard \ test1) diff --git a/test/log.ml b/test/log.ml index fe02f540..3231baca 100644 --- a/test/log.ml +++ b/test/log.ml @@ -1,17 +1,17 @@ (* Collect log data from builds, for unit-tests. *) -open Lwt.Infix - type t = { label : string; buf : Buffer.t; - cond : unit Lwt_condition.t; + cond : Eio.Condition.t; + mutex : Eio.Mutex.t; } let create label = let buf = Buffer.create 1024 in - let cond = Lwt_condition.create () in - { label; buf; cond } + let cond = Eio.Condition.create () in + let mutex = Eio.Mutex.create () in + { label; buf; cond; mutex } let add t tag x = Logs.info (fun f -> f "%s: %S" t.label x); @@ -20,7 +20,7 @@ let add t tag x = | `Note -> Buffer.add_string t.buf (";" ^ x ^ "\n") | `Output -> Buffer.add_string t.buf x end; - Lwt_condition.broadcast t.cond () + Eio.Condition.broadcast t.cond let contents t = Buffer.contents t.buf @@ -36,13 +36,18 @@ let remove_notes x = let rec await t expect = let got = Buffer.contents t.buf |> remove_notes in - if got = expect then Lwt.return_unit + if got = expect then () else if String.length got > String.length expect then ( Fmt.failwith "Log expected %S but got %S" expect got ) else ( let common = min (String.length expect) (String.length got) in if String.sub got 0 common = String.sub expect 0 common then ( - Lwt_condition.wait t.cond >>= fun () -> + Eio.Mutex.lock t.mutex; + (* Re-check under the lock to avoid missing broadcasts *) + let got2 = Buffer.contents t.buf |> remove_notes in + if got2 = got then + Eio.Condition.await t.cond t.mutex; + Eio.Mutex.unlock t.mutex; await t expect ) else ( Fmt.failwith "Log expected %S but got %S" expect got diff --git a/test/mock_exec.ml b/test/mock_exec.ml index 4f2828a2..a0306efa 100644 --- a/test/mock_exec.ml +++ b/test/mock_exec.ml @@ -1,5 +1,3 @@ -open Lwt.Infix - module Os = Obuilder.Os let ( / ) = Filename.concat @@ -8,18 +6,16 @@ let strf = Printf.sprintf let unix_path path = if Sys.win32 then - Lwt_process.pread ("", [| "cygpath"; "-u"; path|]) >|= fun str -> String.trim str + String.trim (Os.pread ["cygpath"; "-u"; path]) else - Lwt.return path + path let next_container_id = ref 0 let base_tar = let mydir = Sys.getcwd () in - Lwt_main.run begin - let base_tar = mydir / "base.tar" in - Lwt_io.(with_file ~mode:input) base_tar Lwt_io.read - end + let base_tar = mydir / "base.tar" in + In_channel.with_open_bin base_tar In_channel.input_all |> Bytes.of_string let with_fd x f = @@ -27,9 +23,9 @@ let with_fd x f = | `FD_move_safely fd -> let copy = Unix.dup ~cloexec:true fd.Os.raw in Os.close fd; - Lwt.finalize + Fun.protect (fun () -> f copy) - (fun () -> Unix.close copy; Lwt.return_unit) + ~finally:(fun () -> (try Unix.close copy with Unix.Unix_error _ -> ())) | _ -> failwith "Unsupported mock FD redirection" let docker_create ?stdout base = @@ -38,7 +34,7 @@ let docker_create ?stdout base = incr next_container_id; let rec aux i = let len = String.length id - i in - if len = 0 then Lwt_result.return 0 + if len = 0 then Ok 0 else ( let sent = Unix.single_write_substring stdout id i len in aux (i + sent) @@ -48,36 +44,33 @@ let docker_create ?stdout base = let docker_export ?stdout _id = with_fd (Option.get stdout) @@ fun stdout -> - let stdout = Lwt_unix.of_unix_file_descr stdout in - Os.write_all stdout base_tar 0 (Bytes.length base_tar) >|= fun () -> + Os.write_all stdout base_tar 0 (Bytes.length base_tar); Ok 0 let docker_inspect ?stdout _id = with_fd (Option.get stdout) @@ fun stdout -> - let stdout = Lwt_unix.of_unix_file_descr stdout in let msg = Bytes.of_string "PATH=/usr/bin:/usr/local/bin" in - Os.write_all stdout msg 0 (Bytes.length msg) >|= fun () -> + Os.write_all stdout msg 0 (Bytes.length msg); Ok 0 let exec_docker ?stdout = function | ["create"; "--"; base] -> docker_create ?stdout base | ["export"; "--"; id] -> docker_export ?stdout id | ["image"; "inspect"; "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|}; "--"; base] -> docker_inspect ?stdout base - | ["rm"; "--force"; "--"; id] -> Fmt.pr "docker rm --force %S@." id; Lwt_result.return 0 + | ["rm"; "--force"; "--"; id] -> Fmt.pr "docker rm --force %S@." id; Ok 0 | x -> Fmt.failwith "Unknown mock docker command %a" Fmt.(Dump.list string) x let mkdir = function - | ["-m"; "755"; "--"; path] -> Unix.mkdir path 0o755; Lwt_result.return 0 + | ["-m"; "755"; "--"; path] -> Unix.mkdir path 0o755; Ok 0 | x -> Fmt.failwith "Unexpected mkdir %a" Fmt.(Dump.list string) x let closing redir fn = - Lwt.finalize fn - (fun () -> + Fun.protect fn + ~finally:(fun () -> begin match redir with | Some (`FD_move_safely fd) -> Os.ensure_closed_unix fd | _ -> () - end; - Lwt.return_unit + end ) let exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp cmd = @@ -93,7 +86,7 @@ let exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp cmd = | "sudo" :: "--" :: ("tar" :: _ as tar) when not Os.running_as_root -> Os.default_exec ?cwd ?stdin ?stdout ~pp ("", Array.of_list tar) | "tar" :: "-C" :: path :: opts when Os.running_as_root -> - unix_path path >>= fun path -> + let path = unix_path path in let tar = (if Sys.win32 then "C:\\cygwin64\\bin\\tar.exe" else "tar") :: "-C" :: path :: opts in Os.default_exec ?cwd ?stdin ?stdout ~pp ("", Array.of_list tar) | "mkdir" :: args when Os.running_as_root -> mkdir args diff --git a/test/mock_sandbox.ml b/test/mock_sandbox.ml index becc01c5..1176a6ff 100644 --- a/test/mock_sandbox.ml +++ b/test/mock_sandbox.ml @@ -3,12 +3,12 @@ include Obuilder.S.Sandbox_default type t = { expect : - (cancelled:unit Lwt.t -> + (cancelled:unit Eio.Promise.t -> ?stdin:Obuilder.Os.unix_fd -> log:Obuilder.Build_log.t -> Obuilder.Config.t -> string -> - (unit, [`Msg of string | `Cancelled]) Lwt_result.t) Queue.t; + (unit, [`Msg of string | `Cancelled]) result) Queue.t; } let expect t x = Queue.add x t.expect @@ -17,13 +17,11 @@ let run ~cancelled ?stdin ~log t (config:Obuilder.Config.t) dir = match Queue.take_opt t.expect with | None -> Fmt.failwith "Unexpected sandbox execution: %a" Fmt.(Dump.list string) config.argv | Some fn -> - Lwt.catch - (fun () -> fn ~cancelled ?stdin ~log config dir) - (function - | Failure ex -> Lwt_result.fail (`Msg ex) - | ex -> Lwt_result.fail (`Msg (Printexc.to_string ex)) - ) + try fn ~cancelled ?stdin ~log config dir + with + | Failure ex -> Error (`Msg ex) + | ex -> Error (`Msg (Printexc.to_string ex)) let create () = { expect = Queue.create () } -let finished () = Lwt.return () +let finished () = () diff --git a/test/mock_sandbox.mli b/test/mock_sandbox.mli index a61ef6de..2edb9419 100644 --- a/test/mock_sandbox.mli +++ b/test/mock_sandbox.mli @@ -2,11 +2,11 @@ include Obuilder.S.SANDBOX val create : unit -> t val expect : - t -> (cancelled:unit Lwt.t -> + t -> (cancelled:unit Eio.Promise.t -> ?stdin:Obuilder.Os.unix_fd -> log:Obuilder.Build_log.t -> Obuilder.Config.t -> string -> - (unit, [`Msg of string | `Cancelled]) Lwt_result.t) -> + (unit, [`Msg of string | `Cancelled]) result) -> unit -val finished : unit -> unit Lwt.t +val finished : unit -> unit diff --git a/test/mock_store.ml b/test/mock_store.ml index fcb5917e..c1fdc2d1 100644 --- a/test/mock_store.ml +++ b/test/mock_store.ml @@ -1,22 +1,26 @@ -open Lwt.Infix - module Os = Obuilder.Os let ( / ) = Filename.concat type t = { dir : string; - cond : unit Lwt_condition.t; + cond : Eio.Condition.t; + mutex : Eio.Mutex.t; mutable builds : int; } let unix_path path = if Sys.win32 then - Lwt_process.pread ("", [| "cygpath"; "-u"; path|]) >|= fun str -> String.trim str + String.trim (Os.pread ["cygpath"; "-u"; path]) else - Lwt.return path + path + +let already_resolved = + let p, r = Eio.Promise.create () in + Eio.Promise.resolve r (); + p -let delay_store = ref Lwt.return_unit +let delay_store : unit Eio.Promise.t ref = ref already_resolved let rec waitpid_non_intr pid = try Unix.waitpid [] pid @@ -30,7 +34,7 @@ let rm_r path = let build t ?base ~id fn = t.builds <- t.builds + 1; - Lwt.finalize + Fun.protect (fun () -> base |> Option.iter (fun base -> assert (not (String.contains base '/'))); let dir = t.dir / id in @@ -38,28 +42,30 @@ let build t ?base ~id fn = let tmp_dir = dir ^ "-tmp" in assert (not (Sys.file_exists tmp_dir)); begin match base with - | None -> Os.ensure_dir tmp_dir; Lwt.return_unit + | None -> Os.ensure_dir tmp_dir | Some base -> - Lwt.both (unix_path (t.dir / base)) (unix_path tmp_dir) >>= fun (src, dst) -> - Lwt_process.exec ("", [| "cp"; "-r"; src; dst |]) >>= function - | Unix.WEXITED 0 -> Lwt.return_unit - | _ -> failwith "cp failed!" - end >>= fun () -> - fn tmp_dir >>= fun r -> - !delay_store >>= fun () -> + let src = unix_path (t.dir / base) in + let dst = unix_path tmp_dir in + let cp = Unix.create_process "cp" [| "cp"; "-r"; src; dst |] Unix.stdin Unix.stdout Unix.stderr in + begin match waitpid_non_intr cp with + | _, Unix.WEXITED 0 -> () + | _ -> failwith "cp failed!" + end + end; + let r = fn tmp_dir in + Eio.Promise.await !delay_store; match r with | Ok () -> Unix.rename tmp_dir dir; - Lwt_result.return () + Ok () | Error _ as e -> - unix_path tmp_dir >>= fun tmp_dir -> + let tmp_dir = unix_path tmp_dir in rm_r tmp_dir; - Lwt.return e + e ) - (fun () -> + ~finally:(fun () -> t.builds <- t.builds - 1; - Lwt_condition.broadcast t.cond (); - Lwt.return_unit + Eio.Condition.broadcast t.cond ) let state_dir t = t.dir / "state" @@ -69,41 +75,44 @@ let path t id = t.dir / id let result t id = let dir = path t id in match Os.check_dir dir with - | `Present -> Lwt.return_some dir - | `Missing -> Lwt.return_none + | `Present -> Some dir + | `Missing -> None let log_file t id = - Lwt.return (t.dir / "logs" / (id ^ ".log")) + t.dir / "logs" / (id ^ ".log") let rec finish t = if t.builds > 0 then ( Logs.info (fun f -> f "Waiting for %d builds to finish" t.builds); - Lwt_condition.wait t.cond >>= fun () -> + Eio.Mutex.lock t.mutex; + if t.builds > 0 then + Eio.Condition.await t.cond t.mutex; + Eio.Mutex.unlock t.mutex; finish t - ) else Lwt.return_unit + ) else () let with_store fn = - Lwt_io.with_temp_dir ~prefix:"mock-store-" @@ fun dir -> - let t = { dir; cond = Lwt_condition.create (); builds = 0 } in + let dir = Filename.temp_dir "mock-store-" "" in + let t = { dir; cond = Eio.Condition.create (); mutex = Eio.Mutex.create (); builds = 0 } in Obuilder.Os.ensure_dir (state_dir t); Obuilder.Os.ensure_dir (t.dir / "logs"); - Lwt.finalize + Fun.protect (fun () -> fn t) - (fun () -> finish t) + ~finally:(fun () -> finish t) let delete t id = - result t id >>= function - | Some path -> rm_r path; Lwt.return_unit - | None -> Lwt.return_unit + match result t id with + | Some path -> rm_r path + | None -> () let find ~output t = let rec aux = function - | [] -> Lwt.return_none + | [] -> None | x :: xs -> let output_path = t.dir / x / "rootfs" / "output" in if Sys.file_exists output_path then ( - Lwt_io.(with_file ~mode:input) output_path Lwt_io.read >>= fun data -> - if data = output then Lwt.return_some x + let data = In_channel.with_open_bin output_path In_channel.input_all in + if data = output then Some x else aux xs ) else aux xs in @@ -114,8 +123,8 @@ let cache ~user:_ _t _ = assert false let delete_cache _t _ = assert false -let complete_deletes _t = Lwt.return_unit +let complete_deletes _t = () let root t = t.dir -let df _ = Lwt.return 100. +let df _ = 100. diff --git a/test/mock_store.mli b/test/mock_store.mli index b64c7d3d..8fcca143 100644 --- a/test/mock_store.mli +++ b/test/mock_store.mli @@ -1,13 +1,16 @@ include Obuilder.S.STORE -val with_store : (t -> 'a Lwt.t) -> 'a Lwt.t +val with_store : (t -> 'a) -> 'a (** [with_store t fn] runs [fn] with a fresh store, which is deleted when [fn] returns. *) val path : t -> Obuilder.S.id -> string (** [path t id] is the path that [id] is or would be stored at. *) -val find : output:string -> t -> Obuilder.S.id option Lwt.t +val find : output:string -> t -> Obuilder.S.id option (** [find ~output t] returns the ID of a build whose "rootfs/output" file contains [output], if any. *) -val delay_store : (unit Lwt.t) ref +val already_resolved : unit Eio.Promise.t +(** An already-resolved promise for use as a default. *) + +val delay_store : (unit Eio.Promise.t) ref (** Wait for this to resolve after a build function finishes, but before handling the result. *) diff --git a/test/test.ml b/test/test.ml index 2a085897..07075e3c 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,17 +1,15 @@ -open Lwt.Infix open Obuilder module B = Builder(Mock_store)(Mock_sandbox)(Docker_extract) let ( / ) = Filename.concat -let ( >>!= ) = Lwt_result.bind let sprintf = Printf.sprintf let root = if Sys.win32 then "C:/" else "/" let () = Logs.(set_level ~all:true (Some Info)); Logs.set_reporter @@ Logs_fmt.reporter (); - Os.lwt_process_exec := Mock_exec.exec + Os.process_exec := Mock_exec.exec let build_result = Alcotest.of_pp @@ fun f x -> @@ -22,28 +20,40 @@ let build_result = let get store path id = let result = Mock_store.path store id in - Lwt_io.(with_file ~mode:input) (result / "rootfs" / path) Lwt_io.read >|= Result.ok + Ok (In_channel.with_open_bin (result / "rootfs" / path) In_channel.input_all) let with_config fn = + Eio.Switch.run @@ fun sw -> Mock_store.with_store @@ fun store -> let sandbox = Mock_sandbox.create () in - let builder = B.v ~store ~sandbox in - Fun.flip Lwt.finalize (fun () -> B.finish builder) @@ fun () -> + let builder = B.v ~sw ~store ~sandbox in + Fun.protect ~finally:(fun () -> B.finish builder) @@ fun () -> let src_dir = Mock_store.state_dir store / "src" in Os.ensure_dir src_dir; fn ~src_dir ~store ~sandbox ~builder let with_default_exec fn = - Lwt.finalize (fun () -> - Os.lwt_process_exec := Os.default_exec; + Fun.protect (fun () -> + Os.process_exec := Os.default_exec; fn ()) - (fun () -> Os.lwt_process_exec := Mock_exec.exec; Lwt.return_unit) + ~finally:(fun () -> Os.process_exec := Mock_exec.exec) let with_file path flags perms fn = - Lwt_unix.openfile path flags perms >>= fun fd -> - Lwt.finalize (fun () -> fn fd) (fun () -> Lwt_unix.close fd) - -let mock_op ?(result=Lwt_result.return ()) ?(delay_store=Lwt.return_unit) ?cancel ?output () = + let fd = Unix.openfile path flags perms in + Fun.protect (fun () -> fn fd) ~finally:(fun () -> (try Unix.close fd with Unix.Unix_error _ -> ())) + +(* In direct-style, [result] is an Eio promise that will be resolved later + to provide the mock operation's return value. When not specified, it defaults + to a pre-resolved [Ok ()]. + [cancel] is a resolver: when the build is cancelled, it resolves the [result] + promise to [Error `Cancelled]. *) +let mock_op ?result ?(delay_store=Mock_store.already_resolved) ?cancel ?output () = + let default_result = + let p, r = Eio.Promise.create () in + Eio.Promise.resolve r (Ok ()); + p + in + let result = Option.value ~default:default_result result in fun ~cancelled ?stdin:_ ~log (config:Obuilder.Config.t) dir -> Mock_store.delay_store := delay_store; let cmd = @@ -51,30 +61,38 @@ let mock_op ?(result=Lwt_result.return ()) ?(delay_store=Lwt.return_unit) ?cance | ["/usr/bin/env" ; "bash"; "-c"; cmd] | ["cmd"; "/S"; "/C"; cmd] -> cmd | x -> Fmt.str "%a" Fmt.(Dump.list string) x in - Build_log.printf log "%s@." cmd >>= fun () -> - cancel |> Option.iter (fun cancel -> - Lwt.on_termination cancelled (fun () -> Lwt.wakeup cancel (Error `Cancelled)) - ); + Build_log.printf log "%s@." cmd; let rootfs = dir / "rootfs" in begin match output with - | Some (`Constant v) -> Lwt_io.(with_file ~mode:output) (rootfs / "output") (fun ch -> Lwt_io.write ch v) + | Some (`Constant v) -> Out_channel.with_open_bin (rootfs / "output") (fun ch -> Out_channel.output_string ch v) | Some (`Append (v, src)) -> - Lwt_io.(with_file ~mode:input) (rootfs / src) Lwt_io.read >>= fun src -> - Lwt_io.(with_file ~mode:output) (rootfs / "output") (fun ch -> Lwt_io.write ch (src ^ v)) + let src = In_channel.with_open_bin (rootfs / src) In_channel.input_all in + Out_channel.with_open_bin (rootfs / "output") (fun ch -> Out_channel.output_string ch (src ^ v)) | Some `Append_cmd -> - Lwt_io.(with_file ~mode:input) (rootfs / "output") Lwt_io.read >>= fun src -> - Lwt_io.(with_file ~mode:output) (rootfs / "output") (fun ch -> Lwt_io.write ch (src ^ cmd)) - | None -> Lwt.return_unit - end >>= fun () -> - result - -let test_simple _switch () = + let src = In_channel.with_open_bin (rootfs / "output") In_channel.input_all in + Out_channel.with_open_bin (rootfs / "output") (fun ch -> Out_channel.output_string ch (src ^ cmd)) + | None -> () + end; + match cancel with + | Some cancel -> + (* Race between: the result being resolved normally, or cancelled firing. *) + Eio.Fiber.first + (fun () -> Eio.Promise.await result) + (fun () -> + Eio.Promise.await cancelled; + (* Also resolve the result promise so the other fiber can complete *) + Eio.Promise.resolve cancel (Error `Cancelled); + Error `Cancelled) + | None -> + Eio.Promise.await result + +let test_simple () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let log = Log.create "b" in let context = Context.v ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log) () in let spec = Spec.(stage ~from:"base" [ run "Append" ]) in Mock_sandbox.expect sandbox (mock_op ~output:(`Append ("runner", "base-id")) ()); - B.build builder context spec >>!= get store "output" >>= fun result -> + let result = Result.bind (B.build builder context spec) (get store "output") in Alcotest.(check build_result) "Final result" (Ok "base-distro\nrunner") result; Log.check "Check log" (sprintf {|(from base) @@ -85,7 +103,7 @@ let test_simple _switch () = |} root) log; (* Check result is cached *) Log.clear log; - B.build builder context spec >>!= get store "output" >>= fun result -> + let result = Result.bind (B.build builder context spec) (get store "output") in Alcotest.(check build_result) "Final result cached" (Ok "base-distro\nrunner") result; Log.check "Check cached log" (sprintf {|(from base) @@ -93,17 +111,16 @@ let test_simple _switch () = %s: (run (shell Append)) Append ;---> using .* from cache - |} root) log; - Lwt.return_unit + |} root) log -let test_prune _switch () = +let test_prune () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let start = Unix.(gettimeofday () |> gmtime) in let log = Log.create "b" in let context = Context.v ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log) () in let spec = Spec.(stage ~from:"base" [ run "Append" ]) in Mock_sandbox.expect sandbox (mock_op ~output:(`Append ("runner", "base-id")) ()); - B.build builder context spec >>!= get store "output" >>= fun result -> + let result = Result.bind (B.build builder context spec) (get store "output") in Alcotest.(check build_result) "Final result" (Ok "base-distro\nrunner") result; Log.check "Check log" (sprintf {|(from base) @@ -113,16 +130,21 @@ let test_prune _switch () = ;---> saved as .* |} root) log; let log id = Logs.info (fun f -> f "Deleting %S" id) in - B.prune ~log builder ~before:start 10 >>= fun n -> + let n = B.prune ~log builder ~before:start 10 in Alcotest.(check int) "Nothing before start time" 0 n; let end_time = Unix.(gettimeofday () +. 60.0 |> gmtime) in - B.prune ~log builder ~before:end_time 10 >>= fun n -> - Alcotest.(check int) "Prune" 2 n; - Lwt.return_unit + let n = B.prune ~log builder ~before:end_time 10 in + Alcotest.(check int) "Prune" 2 n + +(* Helper to fork a build into a fiber and get a promise for the result *) +let fork_build ~sw builder context spec = + Eio.Fiber.fork_promise ~sw (fun () -> + B.build builder context spec + ) (* Two builds, [A;B] and [A;C] are started together. The [A] command is only run once, with the log visible to both while the build is still in progress. *) -let test_concurrent _switch () = +let test_concurrent () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let log1 = Log.create "b1" in let log2 = Log.create "b2" in @@ -130,17 +152,18 @@ let test_concurrent _switch () = let context2 = Obuilder.Context.v ~shell:(Mock_sandbox.shell sandbox) ~log:(Log.add log2) ~src_dir () in let spec1 = Obuilder.Spec.(stage ~from:"base"[ run "A"; run "B" ]) in let spec2 = Obuilder.Spec.(stage ~from:"base"[ run "A"; run "C" ]) in - let a, a_done = Lwt.wait () in + let a, a_done = Eio.Promise.create () in Mock_sandbox.expect sandbox (mock_op ~result:a ~output:(`Constant "A") ()); Mock_sandbox.expect sandbox (mock_op ~output:`Append_cmd ()); Mock_sandbox.expect sandbox (mock_op ~output:`Append_cmd ()); - let b1 = B.build builder context1 spec1 in - Log.await log1 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root) >>= fun () -> - let b2 = B.build builder context2 spec2 in - Log.await log2 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root) >>= fun () -> - Lwt.wakeup a_done (Ok ()); - b1 >>!= get store "output" >>= fun b1 -> - b2 >>!= get store "output" >>= fun b2 -> + Eio.Switch.run @@ fun sw -> + let b1 = fork_build ~sw builder context1 spec1 in + Log.await log1 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root); + let b2 = fork_build ~sw builder context2 spec2 in + Log.await log2 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root); + Eio.Promise.resolve a_done (Ok ()); + let b1 = Eio.Promise.await_exn b1 |> fun r -> Result.bind r (get store "output") in + let b2 = Eio.Promise.await_exn b2 |> fun r -> Result.bind r (get store "output") in Alcotest.(check build_result) "Final result" (Ok "AB") b1; Alcotest.(check build_result) "Final result" (Ok "AC") b2; Log.check "Check AB log" @@ -164,11 +187,10 @@ let test_concurrent _switch () = C ;---> saved as .* |} root root) - log2; - Lwt.return_unit + log2 (* Two builds, [A;B] and [A;C] are started together. The [A] command fails. *) -let test_concurrent_failure _switch () = +let test_concurrent_failure () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let log1 = Log.create "b1" in let log2 = Log.create "b2" in @@ -176,15 +198,16 @@ let test_concurrent_failure _switch () = let context2 = Obuilder.Context.v ~shell:(Mock_sandbox.shell sandbox) ~log:(Log.add log2) ~src_dir () in let spec1 = Obuilder.Spec.(stage ~from:"base" [ run "A"; run "B" ]) in let spec2 = Obuilder.Spec.(stage ~from:"base" [ run "A"; run "C" ]) in - let a, a_done = Lwt.wait () in + let a, a_done = Eio.Promise.create () in Mock_sandbox.expect sandbox (mock_op ~result:a ()); - let b1 = B.build builder context1 spec1 in - Log.await log1 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root) >>= fun () -> - let b2 = B.build builder context2 spec2 in - Log.await log2 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root) >>= fun () -> - Lwt.wakeup a_done (Error (`Msg "Mock build failure")); - b1 >>!= get store "output" >>= fun b1 -> - b2 >>!= get store "output" >>= fun b2 -> + Eio.Switch.run @@ fun sw -> + let b1 = fork_build ~sw builder context1 spec1 in + Log.await log1 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root); + let b2 = fork_build ~sw builder context2 spec2 in + Log.await log2 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root); + Eio.Promise.resolve a_done (Error (`Msg "Mock build failure")); + let b1 = Eio.Promise.await_exn b1 |> fun r -> Result.bind r (get store "output") in + let b2 = Eio.Promise.await_exn b2 |> fun r -> Result.bind r (get store "output") in Alcotest.(check build_result) "B1 result" (Error (`Msg "Mock build failure")) b1; Alcotest.(check build_result) "B2 result" (Error (`Msg "Mock build failure")) b2; Log.check "Check AB log" @@ -200,12 +223,11 @@ let test_concurrent_failure _switch () = %s: (run (shell A)) A |} root) - log2; - Lwt.return_unit + log2 (* Two builds, [A;B] and [A;C] are started together. The [A] command fails just as the second build is trying to open the log file. *) -let test_concurrent_failure_2 _switch () = +let test_concurrent_failure_2 () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let log1 = Log.create "b1" in let log2 = Log.create "b2" in @@ -213,15 +235,21 @@ let test_concurrent_failure_2 _switch () = let context2 = Obuilder.Context.v ~shell:(Mock_sandbox.shell sandbox) ~log:(Log.add log2) ~src_dir () in let spec1 = Obuilder.Spec.(stage ~from:"base" [ run "A"; run "B" ]) in let spec2 = Obuilder.Spec.(stage ~from:"base" [ run "A"; run "C" ]) in - let a, a_done = Lwt.wait () in - Mock_sandbox.expect sandbox (mock_op ~result:(Lwt_result.fail (`Msg "Mock build failure")) ~delay_store:a ()); - let b1 = B.build builder context1 spec1 in - Log.await log1 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root) >>= fun () -> - let b2 = B.build builder context2 spec2 in - Log.await log2 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root) >>= fun () -> - Lwt.wakeup a_done (); - b1 >>!= get store "output" >>= fun b1 -> - b2 >>!= get store "output" >>= fun b2 -> + let a, a_done = Eio.Promise.create () in + let fail_result = + let p, r = Eio.Promise.create () in + Eio.Promise.resolve r (Error (`Msg "Mock build failure")); + p + in + Mock_sandbox.expect sandbox (mock_op ~result:fail_result ~delay_store:a ()); + Eio.Switch.run @@ fun sw -> + let b1 = fork_build ~sw builder context1 spec1 in + Log.await log1 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root); + let b2 = fork_build ~sw builder context2 spec2 in + Log.await log2 (sprintf "(from base)\n%s: (run (shell A))\nA\n" root); + Eio.Promise.resolve a_done (); + let b1 = Eio.Promise.await_exn b1 |> fun r -> Result.bind r (get store "output") in + let b2 = Eio.Promise.await_exn b2 |> fun r -> Result.bind r (get store "output") in Alcotest.(check build_result) "B1 result" (Error (`Msg "Mock build failure")) b1; Alcotest.(check build_result) "B2 result" (Error (`Msg "Mock build failure")) b2; Log.check "Check AB log" @@ -237,48 +265,48 @@ let test_concurrent_failure_2 _switch () = %s: (run (shell A)) A |} root) - log2; - Lwt.return_unit + log2 -let test_cancel _switch () = +let test_cancel () = with_config @@ fun ~src_dir ~store:_ ~sandbox ~builder -> let log = Log.create "b" in - let switch = Lwt_switch.create () in - let context = Context.v ~shell:(Mock_sandbox.shell sandbox) ~switch ~src_dir ~log:(Log.add log) () in + let cancelled, resolve_cancelled = Eio.Promise.create () in + let context = Context.v ~shell:(Mock_sandbox.shell sandbox) ~cancelled ~src_dir ~log:(Log.add log) () in let spec = Spec.(stage ~from:"base" [ run "Wait" ]) in - let r, set_r = Lwt.wait () in + let r, set_r = Eio.Promise.create () in Mock_sandbox.expect sandbox (mock_op ~result:r ~cancel:set_r ()); - let b = B.build builder context spec in - Log.await log (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root) >>= fun () -> - Lwt_switch.turn_off switch >>= fun () -> - b >>= fun result -> + Eio.Switch.run @@ fun sw -> + let b = fork_build ~sw builder context spec in + Log.await log (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root); + Eio.Promise.resolve resolve_cancelled (); + let result = Eio.Promise.await_exn b in Alcotest.(check build_result) "Final result" (Error `Cancelled) result; Log.check "Check log" (sprintf {|(from base) ;---> saved as .* %s: (run (shell Wait)) Wait - |} root) log; - Lwt.return_unit + |} root) log (* Two users are sharing a build. One cancels. *) -let test_cancel_2 _switch () = +let test_cancel_2 () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let spec = Spec.(stage ~from:"base" [ run "Wait" ]) in - let r, set_r = Lwt.wait () in + let r, set_r = Eio.Promise.create () in Mock_sandbox.expect sandbox (mock_op ~result:r ~cancel:set_r ~output:(`Constant "ok") ()); let log1 = Log.create "b1" in let log2 = Log.create "b2" in - let switch1 = Lwt_switch.create () in - let switch2 = Lwt_switch.create () in - let context1 = Context.v ~switch:switch1 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in - let context2 = Context.v ~switch:switch2 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in - let b1 = B.build builder context1 spec in - Log.await log1 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root) >>= fun () -> - let b2 = B.build builder context2 spec in - Log.await log2 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root) >>= fun () -> - Lwt_switch.turn_off switch1 >>= fun () -> - b1 >>= fun result1 -> + let cancelled1, resolve_cancelled1 = Eio.Promise.create () in + let cancelled2, _resolve_cancelled2 = Eio.Promise.create () in + let context1 = Context.v ~cancelled:cancelled1 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in + let context2 = Context.v ~cancelled:cancelled2 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in + Eio.Switch.run @@ fun sw -> + let b1 = fork_build ~sw builder context1 spec in + Log.await log1 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root); + let b2 = fork_build ~sw builder context2 spec in + Log.await log2 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root); + Eio.Promise.resolve resolve_cancelled1 (); + let result1 = Eio.Promise.await_exn b1 in Alcotest.(check build_result) "User 1 result" (Error `Cancelled) result1; Log.check "Check log" (sprintf {|(from base) @@ -286,8 +314,8 @@ let test_cancel_2 _switch () = %s: (run (shell Wait)) Wait |} root) log1; - Lwt.wakeup set_r (Ok ()); - b2 >>!= get store "output" >>= fun result2 -> + Eio.Promise.resolve set_r (Ok ()); + let result2 = Eio.Promise.await_exn b2 |> fun r -> Result.bind r (get store "output") in Alcotest.(check build_result) "Final result" (Ok "ok") result2; Log.check "Check log" (sprintf {|(from base) @@ -295,27 +323,27 @@ let test_cancel_2 _switch () = %s: (run (shell Wait)) Wait ;---> saved as .* - |} root) log2; - Lwt.return_unit + |} root) log2 (* Two users are sharing a build. Both cancel. *) -let test_cancel_3 _switch () = +let test_cancel_3 () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let spec = Spec.(stage ~from:"base" [ run "Wait" ]) in - let r, set_r = Lwt.wait () in + let r, set_r = Eio.Promise.create () in Mock_sandbox.expect sandbox (mock_op ~result:r ~cancel:set_r ()); let log1 = Log.create "b1" in let log2 = Log.create "b2" in - let switch1 = Lwt_switch.create () in - let switch2 = Lwt_switch.create () in - let context1 = Context.v ~switch:switch1 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in - let context2 = Context.v ~switch:switch2 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in - let b1 = B.build builder context1 spec in - Log.await log1 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root) >>= fun () -> - let b2 = B.build builder context2 spec in - Log.await log2 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root) >>= fun () -> - Lwt_switch.turn_off switch1 >>= fun () -> - b1 >>= fun result1 -> + let cancelled1, resolve_cancelled1 = Eio.Promise.create () in + let cancelled2, resolve_cancelled2 = Eio.Promise.create () in + let context1 = Context.v ~cancelled:cancelled1 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in + let context2 = Context.v ~cancelled:cancelled2 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in + Eio.Switch.run @@ fun sw -> + let b1 = fork_build ~sw builder context1 spec in + Log.await log1 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root); + let b2 = fork_build ~sw builder context2 spec in + Log.await log2 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root); + Eio.Promise.resolve resolve_cancelled1 (); + let result1 = Eio.Promise.await_exn b1 in Alcotest.(check build_result) "User 1 result" (Error `Cancelled) result1; Log.check "Check log" (sprintf {|(from base) @@ -323,8 +351,8 @@ let test_cancel_3 _switch () = %s: (run (shell Wait)) Wait |} root) log1; - Lwt_switch.turn_off switch2 >>= fun () -> - b2 >>!= get store "output" >>= fun result2 -> + Eio.Promise.resolve resolve_cancelled2 (); + let result2 = Eio.Promise.await_exn b2 |> fun r -> Result.bind r (get store "output") in Alcotest.(check build_result) "User 2 result" (Error `Cancelled) result2; Log.check "Check log" (sprintf {|(from base) @@ -332,115 +360,110 @@ let test_cancel_3 _switch () = %s: (run (shell Wait)) Wait |} root) log2; - r >>= fun r -> + let r = Eio.Promise.await r in let r = Result.map (fun () -> "-") r in - Alcotest.(check build_result) "Build cancelled" (Error `Cancelled) r; - Lwt.return_unit + Alcotest.(check build_result) "Build cancelled" (Error `Cancelled) r (* One user cancels a failed build after its replacement has started. *) -let test_cancel_4 _switch () = +let test_cancel_4 () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let spec = Spec.(stage ~from:"base" [ run "Wait" ]) in - let r, set_r = Lwt.wait () in + let r, set_r = Eio.Promise.create () in Mock_sandbox.expect sandbox (mock_op ~result:r ~cancel:set_r ()); let log1 = Log.create "b1" in let log2 = Log.create "b2" in - let switch1 = Lwt_switch.create () in - let switch2 = Lwt_switch.create () in - let context1 = Context.v ~switch:switch1 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in - let context2 = Context.v ~switch:switch2 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in - let b1 = B.build builder context1 spec in - Log.await log1 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root) >>= fun () -> - Lwt.wakeup set_r (Error (`Msg "Build failed")); + let cancelled1, _resolve_cancelled1 = Eio.Promise.create () in + let cancelled2, _resolve_cancelled2 = Eio.Promise.create () in + let context1 = Context.v ~cancelled:cancelled1 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in + let context2 = Context.v ~cancelled:cancelled2 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in + Eio.Switch.run @@ fun sw -> + let b1 = fork_build ~sw builder context1 spec in + Log.await log1 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root); + Eio.Promise.resolve set_r (Error (`Msg "Build failed")); + (* Ensure b1's build completes and is cleaned up before starting b2. + In Eio, unlike Lwt, promise resolution doesn't eagerly run continuations, + so we must explicitly wait for the failed build to be fully processed. *) + let result1 = Eio.Promise.await_exn b1 in + Alcotest.(check build_result) "User 1 result" (Error (`Msg "Build failed")) result1; (* Begin a new build. *) - let r2, set_r2 = Lwt.wait () in + let r2, set_r2 = Eio.Promise.create () in Mock_sandbox.expect sandbox (mock_op ~result:r2 ~cancel:set_r2 ~output:(`Constant "ok") ()); - let b2 = B.build builder context2 spec in - Log.await log2 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root) >>= fun () -> - (* Cancel the original build. *) - Lwt_switch.turn_off switch1 >>= fun () -> - b1 >>= fun result1 -> - Alcotest.(check build_result) "User 1 result" (Error (`Msg "Build failed")) result1; + let b2 = fork_build ~sw builder context2 spec in + Log.await log2 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root); (* Start a third build. It should attach to the second build. *) let log3 = Log.create "b3" in - let switch3 = Lwt_switch.create () in - let context3 = Context.v ~switch:switch3 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log3) () in - let b3 = B.build builder context3 spec in - Log.await log3 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root) >>= fun () -> - Lwt.wakeup set_r2 (Ok ()); - b2 >>!= get store "output" >>= fun result2 -> + let cancelled3, _resolve_cancelled3 = Eio.Promise.create () in + let context3 = Context.v ~cancelled:cancelled3 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log3) () in + let b3 = fork_build ~sw builder context3 spec in + Log.await log3 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root); + Eio.Promise.resolve set_r2 (Ok ()); + let result2 = Eio.Promise.await_exn b2 |> fun r -> Result.bind r (get store "output") in Alcotest.(check build_result) "User 2 result" (Ok "ok") result2; - b3 >>!= get store "output" >>= fun result3 -> - Alcotest.(check build_result) "User 3 result" (Ok "ok") result3; - Lwt.return_unit + let result3 = Eio.Promise.await_exn b3 |> fun r -> Result.bind r (get store "output") in + Alcotest.(check build_result) "User 3 result" (Ok "ok") result3 (* Start a new build while the previous one is cancelling. *) -let test_cancel_5 _switch () = +let test_cancel_5 () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let spec = Spec.(stage ~from:"base" [ run "Wait" ]) in - let r, set_r = Lwt.wait () in - let delay_store, set_delay = Lwt.wait () in + let r, set_r = Eio.Promise.create () in + let delay_store, set_delay = Eio.Promise.create () in Mock_sandbox.expect sandbox (mock_op ~result:r ~cancel:set_r ~delay_store ()); let log1 = Log.create "b1" in - let switch1 = Lwt_switch.create () in - let context1 = Context.v ~switch:switch1 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in - let b1 = B.build builder context1 spec in - Log.await log1 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root) >>= fun () -> - Lwt_switch.turn_off switch1 >>= fun () -> - b1 >>= fun result1 -> + let cancelled1, resolve_cancelled1 = Eio.Promise.create () in + let context1 = Context.v ~cancelled:cancelled1 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in + Eio.Switch.run @@ fun sw -> + let b1 = fork_build ~sw builder context1 spec in + Log.await log1 (sprintf "(from base)\n%s: (run (shell Wait))\nWait\n" root); + Eio.Promise.resolve resolve_cancelled1 (); + let result1 = Eio.Promise.await_exn b1 in Alcotest.(check build_result) "User 1 result" (Error `Cancelled) result1; (* Begin a new build. *) Mock_sandbox.expect sandbox (mock_op ~output:(`Constant "ok") ()); let log2 = Log.create "b2" in - let switch2 = Lwt_switch.create () in - let context2 = Context.v ~switch:switch2 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in - let b2 = B.build builder context2 spec in - Log.await log2 (sprintf "(from base)\n%s: (run (shell Wait))\n" root) >>= fun () -> - Lwt.wakeup set_delay (); - b2 >>!= get store "output" >>= fun result1 -> - Alcotest.(check build_result) "User 2 result" (Ok "ok") result1; - Lwt.return_unit - -let test_delete _switch () = + let cancelled2, _resolve_cancelled2 = Eio.Promise.create () in + let context2 = Context.v ~cancelled:cancelled2 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in + let b2 = fork_build ~sw builder context2 spec in + Log.await log2 (sprintf "(from base)\n%s: (run (shell Wait))\n" root); + Eio.Promise.resolve set_delay (); + let result2 = Eio.Promise.await_exn b2 |> fun r -> Result.bind r (get store "output") in + Alcotest.(check build_result) "User 2 result" (Ok "ok") result2 + +let test_delete () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let spec = Spec.(stage ~from:"base" [ run "A"; run "B" ]) in Mock_sandbox.expect sandbox (mock_op ~output:(`Constant "A") ()); Mock_sandbox.expect sandbox (mock_op ~output:(`Constant "B") ()); let log1 = Log.create "b1" in - let switch1 = Lwt_switch.create () in - let context1 = Context.v ~switch:switch1 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in - let b1 = B.build builder context1 spec in - b1 >>!= get store "output" >>= fun result1 -> + let context1 = Context.v ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log1) () in + let result1 = B.build builder context1 spec |> fun r -> Result.bind r (get store "output") in Alcotest.(check build_result) "Build 1 result" (Ok "B") result1; (* Remove A *) - Mock_store.find ~output:"A" store >>= fun id -> + let id = Mock_store.find ~output:"A" store in let id = Option.get id in let log = ref [] in - B.delete ~log:(fun x -> log := x :: !log) builder id >>= fun () -> + B.delete ~log:(fun x -> log := x :: !log) builder id; Alcotest.(check int) "Deleted 2 items" 2 (List.length !log); (* Check rebuild works *) Mock_sandbox.expect sandbox (mock_op ~output:(`Constant "A") ()); Mock_sandbox.expect sandbox (mock_op ~output:(`Constant "B") ()); let log2 = Log.create "b2" in - let switch2 = Lwt_switch.create () in - let context2 = Context.v ~switch:switch2 ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in - let b2 = B.build builder context2 spec in - b2 >>!= get store "output" >>= fun result2 -> - Alcotest.(check build_result) "Build 2 result" (Ok "B") result2; - Lwt.return_unit - -let test_tar_long_filename _switch () = + let context2 = Context.v ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log2) () in + let result2 = B.build builder context2 spec |> fun r -> Result.bind r (get store "output") in + Alcotest.(check build_result) "Build 2 result" (Ok "B") result2 + +let test_tar_long_filename () = let do_test length = Logs.info (fun f -> f "Test copy length %d " length); - Lwt_io.with_temp_dir ~prefix:"test-copy-src-" @@ fun src_dir -> - Lwt_io.with_temp_dir ~prefix:"test-copy-dst-" @@ fun dst_dir -> + let src_dir = Filename.temp_dir "test-copy-src-" "" in + let dst_dir = Filename.temp_dir "test-copy-dst-" "" in + Fun.protect ~finally:(fun () -> + ignore (Sys.command (Printf.sprintf "rm -rf %s %s" (Filename.quote src_dir) (Filename.quote dst_dir))) + ) @@ fun () -> let filename = src_dir / String.make length 'a' in Logs.info (fun f -> f "length: %d %s" (String.length filename) filename); - Lwt_io.(with_file ~mode:output) - filename - (fun ch -> Lwt_io.write ch "file-data") - >>= fun () -> - with_file (dst_dir / "out.tar") Lwt_unix.[O_WRONLY; O_CREAT; O_CLOEXEC] 0 + Out_channel.with_open_bin filename (fun ch -> Out_channel.output_string ch "file-data"); + with_file (dst_dir / "out.tar") Unix.[O_WRONLY; O_CREAT; O_CLOEXEC] 0 @@ fun to_untar -> let src_manifest = Manifest.generate ~exclude:[] ~src_dir "." |> Result.get_ok in let user = Spec.(`Unix { uid=1000; gid=1000 }) in @@ -451,8 +474,8 @@ let test_tar_long_filename _switch () = ~user ~to_untar in - do_test 80 >>= fun () -> - do_test 160 >>= fun () -> + do_test 80; + do_test 160; (* Maximum path length on Windows is 260 characters. *) do_test (260 - 1 (* NUL *) - String.length {|C:\cygwin64\tmp\build_123456_dune\test-copy-src-123456\|}) @@ -659,65 +682,68 @@ let manifest = (* Test copy step. *) let test_copy generate = - Lwt_io.with_temp_dir ~prefix:"test-copy-bash-" @@ fun src_dir -> - Lwt_io.(with_file ~mode:output) (src_dir / "file") (fun ch -> Lwt_io.write ch "file-data") >>= fun () -> + let src_dir = Filename.temp_dir "test-copy-src-" "" in + Fun.protect ~finally:(fun () -> + ignore (Sys.command (Printf.sprintf "rm -rf %s" (Filename.quote src_dir))) + ) @@ fun () -> + Out_channel.with_open_bin (src_dir / "file") (fun ch -> Out_channel.output_string ch "file-data"); let root = if Sys.unix then "/root" else "C:/Windows" in (* Files *) let f1hash = Sha256.string "file-data" in - generate ~exclude:[] ~src_dir "file" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "file" in Alcotest.(check manifest) "File" (Ok (`File ("file", f1hash))) r; - generate ~exclude:[] ~src_dir "./file" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "./file" in Alcotest.(check manifest) "File relative" (Ok (`File ("file", f1hash))) r; - generate ~exclude:[] ~src_dir "/file" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "/file" in Alcotest.(check manifest) "File absolute" (Ok (`File ("file", f1hash))) r; - generate ~exclude:[] ~src_dir "file2" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "file2" in Alcotest.(check manifest) "Missing" (Error (`Msg {|Source path "file2" not found|})) r; - generate ~exclude:[] ~src_dir "file/file2" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "file/file2" in Alcotest.(check manifest) "Not dir" (Error (`Msg {|Not a directory: file (in "file/file2")|})) r; - generate ~exclude:[] ~src_dir "../file" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "../file" in Alcotest.(check manifest) "Parent" (Error (`Msg {|Can't use .. in source paths! (in "../file")|})) r; (* Symlinks *) Unix.symlink ~to_dir:true root (src_dir / "link"); - generate ~exclude:[] ~src_dir "link" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "link" in Alcotest.(check manifest) "Link" (Ok (`Symlink (("link", root)))) r; - generate ~exclude:[] ~src_dir "link/file" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "link/file" in Alcotest.(check manifest) "Follow link" (Error (`Msg {|Not a regular file: link (in "link/file")|})) r; (* Directories *) - generate ~exclude:["file"] ~src_dir "" >>= fun r -> + let r = generate ~exclude:["file"] ~src_dir "" in Alcotest.(check manifest) "Tree" (Ok (`Dir ("", [`Symlink ("link", root)]))) r; - generate ~exclude:[] ~src_dir "." >>= fun r -> + let r = generate ~exclude:[] ~src_dir "." in Alcotest.(check manifest) "Tree" (Ok (`Dir ("", [`File ("file", f1hash); `Symlink ("link", root)]))) r; Unix.mkdir (src_dir / "dir1") 0o700; Unix.mkdir (src_dir / "dir1" / "dir2") 0o700; - Lwt_io.(with_file ~mode:output) (src_dir / "dir1" / "dir2" / "file2") (fun ch -> Lwt_io.write ch "file2") >>= fun () -> + Out_channel.with_open_bin (src_dir / "dir1" / "dir2" / "file2") (fun ch -> Out_channel.output_string ch "file2"); let f2hash = Sha256.string "file2" in - generate ~exclude:[] ~src_dir "dir1/dir2/file2" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "dir1/dir2/file2" in Alcotest.(check manifest) "Nested file" (Ok (`File ("dir1/dir2/file2", f2hash))) r; - generate ~exclude:[] ~src_dir "dir1" >>= fun r -> + let r = generate ~exclude:[] ~src_dir "dir1" in Alcotest.(check manifest) "Tree" - (Ok (`Dir ("dir1", [`Dir ("dir1/dir2", [`File ("dir1/dir2/file2", f2hash)])]))) r; - Lwt.return_unit + (Ok (`Dir ("dir1", [`Dir ("dir1/dir2", [`File ("dir1/dir2/file2", f2hash)])]))) r (* Test the Manifest module. *) -let test_copy_ocaml _switch () = +let test_copy_ocaml () = if Sys.win32 then Alcotest.skip (); - test_copy (fun ~exclude ~src_dir src -> Lwt_result.lift (Manifest.generate ~exclude ~src_dir src)) + test_copy (fun ~exclude ~src_dir src -> Manifest.generate ~exclude ~src_dir src) (* Test the manifest.bash script. *) -let test_copy_bash _switch () = +let test_copy_bash () = let generate ~exclude ~src_dir src = - begin if Sys.win32 then - Os.pread ["cygpath"; "-m"; "/usr/bin/bash"] >>= fun bash -> - Os.pread ["cygpath"; "-m"; src_dir] >>= fun src_dir -> - Lwt.return (String.trim bash, String.trim src_dir) + let bash, src_dir = + if Sys.win32 then + let bash = Os.pread ["cygpath"; "-m"; "/usr/bin/bash"] in + let src_dir_cyg = Os.pread ["cygpath"; "-m"; src_dir] in + (String.trim bash, String.trim src_dir_cyg) else - Os.pread ["which"; "bash"] >>= fun bash -> - Lwt.return (String.trim bash, src_dir) - end >>= fun (bash, src_dir) -> + let bash = Os.pread ["which"; "bash"] in + (String.trim bash, src_dir) + in let manifest_bash = Printf.sprintf "exec %s %S %S %d %s %d %s" "./manifest.bash" @@ -730,24 +756,24 @@ let test_copy_bash _switch () = in let argv = [ "--login"; "-c"; manifest_bash ] in let pp f = Os.pp_cmd f (bash, argv) in - Os.pread_all ~pp ~cmd:bash argv >>= fun (n, stdout, stderr) -> + let (n, stdout, stderr) = Os.pread_all ~pp ~cmd:bash argv in if n = 0 then - Lwt_result.return @@ Manifest.t_of_sexp (Sexplib.Sexp.of_string stdout) + Ok (Manifest.t_of_sexp (Sexplib.Sexp.of_string stdout)) else if n = 1 then - Lwt_result.fail (`Msg stderr) + Error (`Msg stderr) else - Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n + Fmt.error_msg "%t failed with exit status %d" pp n in with_default_exec (fun () -> test_copy generate) (* Test the manifest.bash module. *) -let test_copy_bash switch () = +let test_copy_bash_wrapper () = let ch = Unix.open_process_in "uname -s" in let os = input_line ch in close_in ch; if os = "Darwin" then Alcotest.skip (); - test_copy_bash switch () + test_copy_bash () let test_cache_id () = let check expected id = @@ -763,23 +789,22 @@ let test_cache_id () = check "c-foo%3abar" "foo:bar"; check "c-Az09-id.foo_orig" "Az09-id.foo_orig" -let test_secrets_not_provided _switch () = +let test_secrets_not_provided () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let log = Log.create "b" in let context = Context.v ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log) () in let spec = Spec.(stage ~from:"base" [ run ~secrets:[Secret.v ~target:"/run/secrets/test" "test"] "Append" ]) in Mock_sandbox.expect sandbox (mock_op ~output:(`Append ("runner", "base-id")) ()); - B.build builder context spec >>!= get store "output" >>= fun result -> - Alcotest.(check build_result) "Final result" (Error (`Msg "Couldn't find value for requested secret 'test'")) result; - Lwt.return_unit + let result = Result.bind (B.build builder context spec) (get store "output") in + Alcotest.(check build_result) "Final result" (Error (`Msg "Couldn't find value for requested secret 'test'")) result -let test_secrets_simple _switch () = +let test_secrets_simple () = with_config @@ fun ~src_dir ~store ~sandbox ~builder -> let log = Log.create "b" in let context = Context.v ~shell:(Mock_sandbox.shell sandbox) ~src_dir ~log:(Log.add log) ~secrets:["test", "top secret value"; "test2", ""] () in let spec = Spec.(stage ~from:"base" [ run ~secrets:[Secret.v ~target:"/testsecret" "test"; Secret.v "test2"] "Append" ]) in Mock_sandbox.expect sandbox (mock_op ~output:(`Append ("runner", "base-id")) ()); - B.build builder context spec >>!= get store "output" >>= fun result -> + let result = Result.bind (B.build builder context spec) (get store "output") in Alcotest.(check build_result) "Final result" (Ok "base-distro\nrunner") result; Log.check "Check b log" (sprintf {| (from base) @@ -789,82 +814,69 @@ let test_secrets_simple _switch () = Append ;---> saved as ".*" |} root) - log; - Lwt.return_unit + log -let test_exec_nul _switch () = +let test_exec_nul () = with_default_exec @@ fun () -> let args = ["dummy"; "stdout"] in - Os.exec ~stdout:`Dev_null ~stderr:`Dev_null args >>= fun actual -> - Alcotest.(check unit) "stdout" actual (); + Os.exec ~stdout:`Dev_null ~stderr:`Dev_null args; let args = ["dummy"; "stderr"] in - Os.exec ~stdout:`Dev_null ~stderr:`Dev_null args >|= fun actual -> - Alcotest.(check unit) "stderr" actual () + Os.exec ~stdout:`Dev_null ~stderr:`Dev_null args -let test_pread_nul _switch () = +let test_pread_nul () = with_default_exec @@ fun () -> let expected = "the quick brown fox jumps over the lazy dog" in let args = ["dummy"; "stdout"] in - Os.pread ~stderr:`Dev_null args >|= fun actual -> + let actual = Os.pread ~stderr:`Dev_null args in Alcotest.(check string) "stdout" actual expected let () = - let open Alcotest_lwt in - let test_case name speed f = - let wrap switch () = - let s = 10.0 in - let timeout = Lwt_unix.sleep s >|= fun () -> - Alcotest.(check reject (sprintf "timeout %fs" s) () ()) in - Lwt.pick ([f switch (); timeout]) - in - test_case name speed wrap - in let is_win32_gha = match Sys.getenv "CI", Sys.getenv "GITHUB_ACTIONS", Sys.win32 with | "true", "true", true -> true | _ | exception _ -> false in let needs_docker = - let test_case name speed f = - if is_win32_gha then test_case name speed (fun _ -> Alcotest.skip) - else test_case name speed f + let skip_if_gha name speed f = + if is_win32_gha then Alcotest.test_case name speed (fun () -> Alcotest.skip ()) + else Alcotest.test_case name speed f in [ "build", [ - test_case "Simple" `Quick test_simple; - test_case "Prune" `Quick test_prune; - test_case "Concurrent" `Quick test_concurrent; - test_case "Concurrent failure" `Quick test_concurrent_failure; - test_case "Concurrent failure 2" `Quick test_concurrent_failure_2; - test_case "Cancel" `Quick test_cancel; - test_case "Cancel 2" `Quick test_cancel_2; - test_case "Cancel 3" `Quick test_cancel_3; - test_case "Cancel 4" `Quick test_cancel_4; - test_case "Cancel 5" `Quick test_cancel_5; - test_case "Delete" `Quick test_delete; + skip_if_gha "Simple" `Quick test_simple; + skip_if_gha "Prune" `Quick test_prune; + skip_if_gha "Concurrent" `Quick test_concurrent; + skip_if_gha "Concurrent failure" `Quick test_concurrent_failure; + skip_if_gha "Concurrent failure 2" `Quick test_concurrent_failure_2; + skip_if_gha "Cancel" `Quick test_cancel; + skip_if_gha "Cancel 2" `Quick test_cancel_2; + skip_if_gha "Cancel 3" `Quick test_cancel_3; + skip_if_gha "Cancel 4" `Quick test_cancel_4; + skip_if_gha "Cancel 5" `Quick test_cancel_5; + skip_if_gha "Delete" `Quick test_delete; ]; "secrets", [ - test_case "Simple" `Quick test_secrets_simple; - test_case "No secret provided" `Quick test_secrets_not_provided; + skip_if_gha "Simple" `Quick test_secrets_simple; + skip_if_gha "No secret provided" `Quick test_secrets_not_provided; ]; ] in - Lwt_main.run begin - run "OBuilder" ([ - "spec", [ - test_case_sync "Sexp" `Quick test_sexp; - test_case_sync "Cache ID" `Quick test_cache_id; - test_case_sync "Docker Windows" `Quick test_docker_windows; - test_case_sync "Docker UNIX" `Quick test_docker_unix; - ]; - "tar_transfer", [ - test_case "Long filename" `Quick test_tar_long_filename; - ]; - "manifest", [ - test_case "Copy using manifest.bash" `Quick test_copy_bash; - test_case "Copy using Manifest" `Quick test_copy_ocaml - ]; - "process", [ - test_case "Execute a process" `Quick test_exec_nul; - test_case "Read stdout of a process" `Quick test_pread_nul; - ]; - ] @ needs_docker) - end + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:(Eio.Stdenv.clock env) @@ fun () -> + Alcotest.run "OBuilder" ([ + "spec", [ + Alcotest.test_case "Sexp" `Quick test_sexp; + Alcotest.test_case "Cache ID" `Quick test_cache_id; + Alcotest.test_case "Docker Windows" `Quick test_docker_windows; + Alcotest.test_case "Docker UNIX" `Quick test_docker_unix; + ]; + "tar_transfer", [ + Alcotest.test_case "Long filename" `Quick test_tar_long_filename; + ]; + "manifest", [ + Alcotest.test_case "Copy using manifest.bash" `Quick test_copy_bash_wrapper; + Alcotest.test_case "Copy using Manifest" `Quick test_copy_ocaml + ]; + "process", [ + Alcotest.test_case "Execute a process" `Quick test_exec_nul; + Alcotest.test_case "Read stdout of a process" `Quick test_pread_nul; + ]; + ] @ needs_docker)