From 7d8adabf856c9cde23f77094dc87dfbf4c3f36db Mon Sep 17 00:00:00 2001 From: Mark Elvers Date: Sat, 14 Feb 2026 09:21:18 +0000 Subject: [PATCH] Add HCS (Host Compute Service) backend for Windows containers Add a new Windows-native backend using containerd for VHDX-based copy-on-write snapshots and container execution. New files: - lib/hcs_store.ml: Store implementation using containerd snapshots - lib/hcs_sandbox.ml: Sandbox using ctr run with OCI config - lib/hcs_fetch.ml: Base image fetcher using ctr image pull The store and sandbox are coupled through layerinfo.json files containing containerd snapshot keys and layer paths. Container networking uses HCN namespaces for NAT connectivity. --- example.spec | 4 +- example.windows.hcs.spec | 25 ++++ lib/build.ml | 46 +++--- lib/build_log.ml | 2 +- lib/db_store.ml | 3 +- lib/docker_sandbox.ml | 3 +- lib/hcs.ml | 47 +++++++ lib/hcs_fetch.ml | 173 +++++++++++++++++++++++ lib/hcs_sandbox.ml | 189 +++++++++++++++++++++++++ lib/hcs_store.ml | 297 +++++++++++++++++++++++++++++++++++++++ lib/obuilder.ml | 3 + lib/os.ml | 72 +++++++--- lib/store_spec.ml | 13 +- lib/tar_transfer.ml | 89 ++++++++++-- main.ml | 36 +++-- 15 files changed, 933 insertions(+), 69 deletions(-) create mode 100644 example.windows.hcs.spec create mode 100644 lib/hcs.ml create mode 100644 lib/hcs_fetch.ml create mode 100644 lib/hcs_sandbox.ml create mode 100644 lib/hcs_store.ml diff --git a/example.spec b/example.spec index 328ff144..de4384ff 100644 --- a/example.spec +++ b/example.spec @@ -7,11 +7,11 @@ ; The result can then be found in /tank/HASH/rootfs/ (where HASH is displayed at the end of the build). ((build dev - ((from ocaml/opam@sha256:02f01da51f1ed2ae4191f143a46a508e2a34652c11ad2715e2bbe8e0d36fc30d) + ((from ocaml/opam:debian) (workdir /src) (user (uid 1000) (gid 1000)) ; Build as the "opam" user (run (shell "sudo chown opam /src")) - (env OPAM_HASH "8187cd8d3681d53f5042b5da316fa3f5e005a247") + (env OPAM_HASH "fb593fd72351e22b3778cfd880158a3c4542aa3f") (run (network host) (shell "sudo apt-get --allow-releaseinfo-change update")) diff --git a/example.windows.hcs.spec b/example.windows.hcs.spec new file mode 100644 index 00000000..f7fe01bf --- /dev/null +++ b/example.windows.hcs.spec @@ -0,0 +1,25 @@ +; This script builds OBuilder itself using the HCS backend on Windows. +; +; Run it from the top-level of the OBuilder source tree, e.g. +; +; obuilder build -f example.windows.hcs.spec . --store=hcs:C:\obuilder +; + +((from ocaml/opam:windows-server-msvc-ltsc2025-ocaml-5.4) + (workdir "C:/src") + ; Copy just the opam files first (helps caching) + (copy (src obuilder-spec.opam obuilder.opam) (dst ./)) + ; Create a dummy dune-project so dune subst works for pinned dev packages + (run (shell "echo (lang dune 3.0)> dune-project")) + (run (shell "opam pin add -yn .")) + ; Install OCaml dependencies + (run + (network host) + (shell "opam install --deps-only -t obuilder")) + ; Copy the rest of the source code + (copy + (src .) + (dst "C:/src/") + (exclude .git _build _opam)) + ; Build and test + (run (shell "opam exec -- dune build @install @runtest"))) diff --git a/lib/build.ml b/lib/build.ml index b8a0b8fd..97248217 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -9,8 +9,18 @@ let hostname = "builder" let healthcheck_base () = if Sys.win32 then - Docker_sandbox.servercore () >>= fun (`Docker_image servercore) -> - Lwt.return servercore + let keyname = {|HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion|} in + let valuename = "CurrentBuild" in + Os.pread ["reg"; "query"; keyname; "/v"; valuename] >>= fun value -> + 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 tag = match version with + | 17763 -> "ltsc2019" + | 20348 -> "ltsc2022" + | 26100 -> "ltsc2025" + | _ -> "ltsc2025" + in + Lwt.return ("mcr.microsoft.com/windows/nanoserver:" ^ tag) else Lwt.return "busybox" let healthcheck_ops = @@ -149,11 +159,12 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st 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:"/" + ~cwd:(if Sys.win32 then "C:/" else "/") ~argv ~hostname ~user:Obuilder_spec.root - ~env:["PATH", "/bin:/usr/bin"] + ~env:(if Sys.win32 then ["PATH", {|C:\Windows\System32;C:\Windows|}] + else ["PATH", "/bin:/usr/bin"]) ~mount_secrets:[] ~mounts:[] ~network:[] @@ -183,9 +194,18 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st Fmt.pf f "@[%s: %a@]" context.workdir Obuilder_spec.pp_op op let update_workdir ~(context:Context.t) path = + let is_absolute = + Astring.String.is_prefix ~affix:"/" path || + (* Windows absolute paths: C:\ or C:/ *) + (String.length path >= 3 && + Char.uppercase_ascii path.[0] >= 'A' && + Char.uppercase_ascii path.[0] <= 'Z' && + path.[1] = ':' && + (path.[2] = '/' || path.[2] = '\\')) + in let workdir = - if Astring.String.is_prefix ~affix:"/" path then path - else context.workdir ^ "/" ^ path + if is_absolute then path + else context.workdir // path in { context with workdir } @@ -236,7 +256,8 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st 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 () -> + (if Sys.win32 then (Os.ensure_dir rootfs; Lwt.return_unit) + else Os.sudo ["mkdir"; "-m"; "755"; "--"; rootfs]) >>= fun () -> Fetch.fetch ~log ~root ~rootfs base >>= fun env -> Os.write_file ~path:(tmp / "env") (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () -> @@ -293,19 +314,12 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st | `Output -> Buffer.add_string buffer x 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 + let src_dir = if Sys.win32 then {|C:\TEMP|} else "/tmp" in + let context = Context.v ~shell:(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 diff --git a/lib/build_log.ml b/lib/build_log.ml index 7eb7abba..34df37fd 100644 --- a/lib/build_log.ml +++ b/lib/build_log.ml @@ -78,7 +78,7 @@ let create path = let finish t = match t.state with - | `Finished -> invalid_arg "Log is already finished!" + | `Finished -> Lwt.return_unit | `Open (fd, cond) -> t.state <- `Finished; Lwt_unix.close fd >|= fun () -> diff --git a/lib/db_store.ml b/lib/db_store.ml index a2be43b5..1b7c95a5 100644 --- a/lib/db_store.ml +++ b/lib/db_store.ml @@ -67,7 +67,8 @@ module Make (Raw : S.STORE) = struct if Sys.file_exists log_file then Unix.unlink log_file; Build_log.create log_file >>= fun log -> Lwt.wakeup set_log log; - fn ~cancelled ~log dir + fn ~cancelled ~log dir >>= fun r -> + Build_log.finish log >|= fun () -> r ) >>!= fun () -> let now = Unix.(gmtime (gettimeofday () )) in diff --git a/lib/docker_sandbox.ml b/lib/docker_sandbox.ml index b6874503..6d280b8d 100644 --- a/lib/docker_sandbox.ml +++ b/lib/docker_sandbox.ml @@ -355,7 +355,8 @@ let servercore = | 18363 -> "1909" | 19041 -> "2004" | 19042 -> "20H2" - | _ -> "ltsc2022" + | 20348 -> "ltsc2022" + | _ -> "ltsc2025" 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'); diff --git a/lib/hcs.ml b/lib/hcs.ml new file mode 100644 index 00000000..9ffc4543 --- /dev/null +++ b/lib/hcs.ml @@ -0,0 +1,47 @@ +open Sexplib.Conv + +let ( / ) = Filename.concat + +type layerinfo = { + snapshot_key : string; + source : string; + parent_layer_paths : string list; +} [@@deriving sexp] + +let layerinfo_path dir = dir / "layerinfo" + +let write_layerinfo ~dir li = + Os.write_file ~path:(layerinfo_path dir) + (Sexplib.Sexp.to_string_hum (sexp_of_layerinfo li) ^ "\n") + +let read_layerinfo dir = + layerinfo_of_sexp (Sexplib.Sexp.load_sexp (layerinfo_path dir)) + +(* Parse the JSON output of `ctr snapshot prepare --mounts`. + Format: + [{"Type":"windows-layer","Source":"C:\\...\\snapshots\\N","Target":"", + "Options":["rw","parentLayerPaths=[\"C:\\\\...\\\\snapshots\\\\M\"]"]}] + Returns (source_path, parent_layer_paths). *) +let parse_mount_json output = + try + let json = Yojson.Safe.from_string (String.trim output) in + let open Yojson.Safe.Util in + match to_list json with + | [] -> ("", []) + | mount :: _ -> + let source = mount |> member "Source" |> to_string in + let options = mount |> member "Options" |> to_list |> List.map to_string in + let parents = + List.find_map (fun opt -> + match Astring.String.cut ~sep:"parentLayerPaths=" opt with + | Some (_, json_str) -> + (try + let arr = Yojson.Safe.from_string json_str in + Some (to_list arr |> List.map to_string) + with _ -> None) + | None -> None + ) options + |> Option.value ~default:[] + in + (source, parents) + with _ -> ("", []) diff --git a/lib/hcs_fetch.ml b/lib/hcs_fetch.ml new file mode 100644 index 00000000..b3e8b6f2 --- /dev/null +++ b/lib/hcs_fetch.ml @@ -0,0 +1,173 @@ +open Lwt.Infix + +let ( / ) = Filename.concat + +let ctr_exec args = + let pp f = Os.pp_cmd f ("", "ctr" :: args) in + Os.exec_result ~pp ("ctr" :: args) + +let ctr_pread args = + if Sys.win32 then + Os.win32_pread ("ctr" :: args) + else + let pp f = Os.pp_cmd f ("", "ctr" :: args) in + Os.pread_result ~pp ("ctr" :: args) + +(* Parse the config digest from `ctr images inspect` tree output. + Look for lines like: "application/vnd.docker.container.image.v1+json @sha256:..." *) +let parse_config_digest output = + let lines = String.split_on_char '\n' output in + List.find_map (fun line -> + if Astring.String.is_infix ~affix:"container.image.v1+json" line then + match Astring.String.cut ~sep:"@" line with + | Some (_, digest) -> + let digest = String.trim digest in + (* Extract just the digest, removing any trailing info like "(123 bytes)" *) + (match Astring.String.cut ~sep:" " digest with + | Some (d, _) -> Some d + | None -> Some digest) + | None -> None + else None + ) lines + +let parse_env_from_config output = + try + let json = Yojson.Safe.from_string output in + let open Yojson.Safe.Util in + let config = json |> member "config" in + let env_list = config |> member "Env" |> to_list |> List.map to_string in + List.filter_map (fun s -> + match String.index_opt s '=' with + | Some i -> + let key = String.sub s 0 i in + let value = String.sub s (i + 1) (String.length s - i - 1) in + Some (key, value) + | None -> None + ) env_list + with _ -> [] + + +(* Parse the chain ID from `ctr images pull --print-chainid --local` output. + The output contains a line like: "image chain ID: sha256:abc123..." *) +let parse_chain_id output = + let lines = String.split_on_char '\n' output in + List.find_map (fun line -> + match Astring.String.cut ~sep:"image chain ID: " line with + | Some (_, chain_id) -> Some (String.trim chain_id) + | None -> None + ) lines + +(* Normalize image reference for containerd. + Docker Hub images need docker.io/ prefix: + - "ubuntu:latest" -> "docker.io/library/ubuntu:latest" + - "ocaml/opam:tag" -> "docker.io/ocaml/opam:tag" + - "mcr.microsoft.com/..." -> unchanged (already has registry) + - "docker.io/..." -> unchanged *) +let normalize_image_ref image = + if String.contains image '/' then + (* Has a slash - check if it starts with a registry *) + let first_part = + match String.index_opt image '/' with + | Some i -> String.sub image 0 i + | None -> image + in + (* If first part contains a dot or colon, it's a registry *) + if String.contains first_part '.' || String.contains first_part ':' then + image (* Already has registry prefix *) + else + "docker.io/" ^ image (* Docker Hub user/repo format *) + else + (* No slash - it's a Docker Hub library image *) + "docker.io/library/" ^ image + +let fetch ~log:(_log : Build_log.t) ~root:(_root : string) ~rootfs base : Config.env Lwt.t = + let image = normalize_image_ref base in + let hash = Sha256.to_hex (Sha256.string base) in + let key = "obuilder-base-" ^ hash in + (* Pull the image — on Windows containerd, pull also unpacks layers *) + Log.info (fun f -> f "HCS fetch: pulling image %s (from %s)" image base); + let platform = ["--platform"; "windows/amd64"] in + (ctr_exec (["images"; "pull"] @ platform @ [image]) >>= function + | Ok () -> Log.info (fun f -> f "HCS fetch: pull succeeded"); Lwt.return_unit + | Error (`Msg m) -> Fmt.failwith "Failed to pull image %s: %s" image m) + >>= fun () -> + (* Get the image's chain ID (the snapshot key for the top layer). + Using --local makes this fast since the image is already pulled. *) + Log.info (fun f -> f "HCS fetch: getting chain ID"); + (ctr_pread (["images"; "pull"; "--print-chainid"; "--local"] @ platform @ [image]) >>= function + | Ok output -> + Log.info (fun f -> f "HCS fetch: got chainid output"); + (match parse_chain_id output with + | Some chain_id -> Log.info (fun f -> f "HCS fetch: chain ID = %s" chain_id); Lwt.return chain_id + | None -> Fmt.failwith "Could not find chain ID for image %s" image) + | Error (`Msg m) -> + Fmt.failwith "Failed to get chain ID for image %s: %s" image m) + >>= fun chain_id -> + (* Clean up any existing snapshots with this key first (for idempotency). + Remove any snapshots that depend on our key, then remove our key itself. *) + Log.info (fun f -> f "HCS fetch: cleaning up any existing snapshots for %s" key); + let committed_key = key ^ "-committed" in + (* Use ctr snapshot ls and parse to find snapshots that have our committed key as parent *) + (ctr_pread ["snapshot"; "ls"] >>= function + | Ok output -> + let lines = String.split_on_char '\n' output in + let children = lines |> List.filter_map (fun line -> + (* Format: KEY\s+PARENT\s+KIND *) + let parts = Astring.String.cuts ~empty:false ~sep:" " (String.trim line) in + match parts with + | child :: parent :: _ when parent = committed_key -> Some child + | _ -> None + ) in + Lwt_list.iter_s (fun child -> + Log.info (fun f -> f "HCS fetch: removing child snapshot %s" child); + ctr_exec ["snapshot"; "rm"; child] >>= fun _ -> Lwt.return_unit + ) children + | Error _ -> Lwt.return_unit) + >>= fun () -> + (* Now remove the main snapshots *) + (ctr_exec ["snapshot"; "rm"; key] >>= function + | Ok () -> Log.info (fun f -> f "HCS fetch: removed existing snapshot"); Lwt.return_unit + | Error (`Msg _) -> Log.info (fun f -> f "HCS fetch: no existing snapshot to remove"); Lwt.return_unit) + >>= fun () -> + (ctr_exec ["snapshot"; "rm"; committed_key] >>= function + | Ok () -> Log.info (fun f -> f "HCS fetch: removed existing committed snapshot"); Lwt.return_unit + | Error (`Msg m) -> Log.info (fun f -> f "HCS fetch: could not remove committed snapshot: %s" m); Lwt.return_unit) + >>= fun () -> + (* Prepare a writable snapshot from the image's top layer *) + Log.info (fun f -> f "HCS fetch: preparing snapshot %s from %s" key chain_id); + (ctr_pread ["snapshot"; "prepare"; "--mounts"; key; chain_id] >>= function + | Ok mounts_json -> + Log.info (fun f -> f "HCS fetch: snapshot prepared, parsing mount json"); + let source, parent_layer_paths = Hcs.parse_mount_json mounts_json in + Log.info (fun f -> f "HCS fetch: source=%s, parents=%d" source (List.length parent_layer_paths)); + Log.info (fun f -> f "HCS fetch: writing layerinfo to %s" rootfs); + Hcs.write_layerinfo ~dir:rootfs { snapshot_key = key; source; parent_layer_paths } >>= fun () -> + Log.info (fun f -> f "HCS fetch: layerinfo written"); + Lwt.return_unit + | Error (`Msg m) -> + Fmt.failwith "Failed to prepare snapshot for base %s: %s" base m) + >>= fun () -> + (* Get environment variables from the image config. + First get the config digest from inspect, then get the config content. *) + Log.info (fun f -> f "HCS fetch: getting image config"); + (ctr_pread ["images"; "inspect"; image] >>= function + | Ok inspect_output -> + (match parse_config_digest inspect_output with + | Some config_digest -> + Log.info (fun f -> f "HCS fetch: config digest = %s" config_digest); + ctr_pread ["content"; "get"; config_digest] >>= (function + | Ok config_json -> + Log.info (fun f -> f "HCS fetch: got config, parsing env"); + Lwt.return (parse_env_from_config config_json) + | Error (`Msg m) -> + Log.warn (fun f -> f "HCS fetch: failed to get config content: %s" m); + Lwt.return []) + | None -> + Log.warn (fun f -> f "HCS fetch: could not find config digest in inspect output"); + Lwt.return []) + | Error (`Msg m) -> + Log.warn (fun f -> f "HCS fetch: failed to inspect image: %s" m); + Lwt.return []) + >>= fun env -> + Log.info (fun f -> f "HCS fetch: done, got %d env vars" (List.length env)); + Lwt.return env diff --git a/lib/hcs_sandbox.ml b/lib/hcs_sandbox.ml new file mode 100644 index 00000000..1768f4c5 --- /dev/null +++ b/lib/hcs_sandbox.ml @@ -0,0 +1,189 @@ +open Lwt.Infix +open Sexplib.Conv + +let finished () = Lwt.return_unit + +let ( / ) = Filename.concat + +type t = { + ctr_path : string; + hcn_namespace_path : string; +} + +type config = { + ctr_path : string; + hcn_namespace_path : string; +} [@@deriving sexp] + +let next_id = ref (int_of_float (Unix.gettimeofday () *. 100.) mod 1_000_000) + + + +module Json_config = struct + let strings xs = `List (List.map (fun x -> `String x) xs) + + let make {Config.cwd; argv; hostname; user; env; mounts; network; mount_secrets = _; entrypoint = _} + ~layer_folders ~network_namespace : Yojson.Safe.t = + let username = + match user with + | `Windows { Obuilder_spec.name } -> name + | `Unix _ -> "ContainerAdministrator" + in + let windows_section = + let base = [ + "layerFolders", `List (List.map (fun p -> `String p) layer_folders); + "ignoreFlushesDuringBoot", `Bool true; + ] in + match network, network_namespace with + | ["host"], Some ns -> + base @ [ + "network", `Assoc [ + "allowUnqualifiedDNSQuery", `Bool true; + "networkNamespace", `String ns; + ]; + ] + | _ -> base + in + let oci_mounts = List.map (fun { Config.Mount.src; dst; readonly; ty = _ } -> + `Assoc [ + "destination", `String dst; + "type", `String "bind"; + "source", `String src; + "options", `List ( + (if readonly then [`String "ro"] else [`String "rw"]) @ + [`String "rbind"; `String "rprivate"] + ); + ] + ) mounts in + `Assoc ([ + "ociVersion", `String "1.1.0"; + "process", `Assoc [ + "terminal", `Bool false; + "user", `Assoc [ + "username", `String username; + ]; + "args", strings argv; + "env", strings (List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) env); + "cwd", `String cwd; + ]; + "root", `Assoc [ + "path", `String ""; + "readonly", `Bool false; + ]; + "hostname", `String hostname; + "windows", `Assoc windows_section; + ] @ + (if oci_mounts <> [] then ["mounts", `List oci_mounts] else []) + ) +end + +let run ~cancelled ?stdin:stdin ~log (t : t) config results_dir = + let pp f = Os.pp_cmd f ("", config.Config.argv) in + let container_id = Printf.sprintf "obuilder-run-%d" !next_id in + incr next_id; + let layer_folders = + if Sys.file_exists (Hcs.layerinfo_path results_dir) then + let li = Hcs.read_layerinfo results_dir in + li.parent_layer_paths @ [li.source] + else + Fmt.failwith "No layerinfo found in %s" results_dir + in + (* Create HCN namespace for networking if requested *) + let use_network = config.Config.network = ["host"] in + (if use_network && Sys.win32 then begin + Log.info (fun f -> f "hcs_sandbox: creating HCN namespace for networking"); + (Os.win32_pread [t.hcn_namespace_path; "create"] >>= function + | Ok output -> Lwt.return output + | Error (`Msg m) -> Fmt.failwith "Failed to create HCN namespace: %s" m) >>= fun output -> + let ns = String.trim output in + Log.info (fun f -> f "hcs_sandbox: created HCN namespace %s" ns); + Lwt.return (Some ns) + end else Lwt.return_none) >>= fun network_namespace -> + Lwt.finalize (fun () -> + Lwt_io.with_temp_dir ~perm:0o700 ~prefix:"obuilder-hcs-" @@ fun tmp -> + (* Generate OCI config.json *) + let json_config = Json_config.make config ~layer_folders ~network_namespace in + let json_str = Yojson.Safe.pretty_to_string json_config ^ "\n" in + Log.info (fun f -> f "hcs_sandbox: OCI config.json:\n%s" json_str); + Os.write_file ~path:(tmp / "config.json") json_str >>= fun () -> + (* Write secrets *) + Lwt_list.iteri_s + (fun id Config.Secret.{value; _} -> + let secret_dir = tmp / "secrets" / string_of_int id in + Os.ensure_dir (tmp / "secrets"); + Os.ensure_dir secret_dir; + Os.write_file ~path:(secret_dir / "secret") value + ) config.mount_secrets + >>= fun () -> + (* Build the ctr run command *) + let cmd = [t.ctr_path; "run"; "--rm"] @ + (if Option.is_some network_namespace then ["--cni"] else []) @ + ["--config"; tmp / "config.json"; + container_id] in + 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 proc = + let stdin = Option.map (fun x -> `FD_move_safely x) stdin in + Os.exec_result ?stdin ~stdout ~stderr ~pp cmd + in + Lwt.on_termination cancelled (fun () -> + let aux () = + if Lwt.is_sleeping proc then ( + let pp f = Fmt.pf f "ctr task kill %S" container_id in + Os.exec_result [t.ctr_path; "task"; "kill"; "-s"; "SIGKILL"; container_id] ~pp >>= fun _ -> + Lwt.return_unit + ) else Lwt.return_unit + 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 + ) (fun () -> + (* Clean up HCN namespace if we created one *) + match network_namespace with + | Some ns -> + Log.info (fun f -> f "hcs_sandbox: deleting HCN namespace %s" ns); + Os.win32_pread [t.hcn_namespace_path; "delete"; ns] >>= fun result -> + (match result with + | Ok _ -> () + | Error (`Msg m) -> Log.warn (fun f -> f "hcs_sandbox: failed to delete HCN namespace %s: %s" ns m)); + Lwt.return_unit + | None -> Lwt.return_unit + ) + +let create ~state_dir:_ (c : config) : t Lwt.t = + Lwt.return ({ ctr_path = c.ctr_path; hcn_namespace_path = c.hcn_namespace_path } : t) + +let shell _ = [{|C:\cygwin64\bin\bash.exe|}; "-lc"] + +let tar _ = ["tar"; "-xf"; "-"] + +open Cmdliner + +let docs = "HCS SANDBOX" + +let ctr_path = + Arg.value @@ + Arg.opt Arg.string "ctr" @@ + Arg.info ~docs + ~doc:"Path to the ctr (containerd) CLI." + ~docv:"CTR_PATH" + ["hcs-ctr-path"] + +let hcn_namespace_path = + Arg.value @@ + Arg.opt Arg.string "hcn-namespace" @@ + Arg.info ~docs + ~doc:"Path to the hcn-namespace tool for Windows container networking." + ~docv:"HCN_NAMESPACE_PATH" + ["hcs-hcn-namespace-path"] + +let cmdliner : config Term.t = + let make ctr_path hcn_namespace_path = + { ctr_path; hcn_namespace_path } + in + Term.(const make $ ctr_path $ hcn_namespace_path) diff --git a/lib/hcs_store.ml b/lib/hcs_store.ml new file mode 100644 index 00000000..8f965998 --- /dev/null +++ b/lib/hcs_store.ml @@ -0,0 +1,297 @@ +open Lwt.Infix + +let strf = Printf.sprintf + +type cache = { + lock : Lwt_mutex.t; + mutable gen : int; +} + +type t = { + root : string; + caches : (string, cache) Hashtbl.t; + mutable next : int; +} + +let ( / ) = Filename.concat + +module Path = struct + let result t id = t.root / "result" / id + let result_tmp t id = t.root / "result-tmp" / id + let state t = t.root / "state" + let cache t name = t.root / "cache" / Escape.cache name + let cache_tmp t i name = t.root / "cache-tmp" / strf "%d-%s" i (Escape.cache name) +end + +module Ctr = struct + let ctr_with_output args = + if Sys.win32 then + Os.win32_pread ("ctr" :: args) + else begin + let pp f = Os.pp_cmd f ("", "ctr" :: args) in + Os.pread_all ~pp ("ctr" :: args) >>= fun (exit_code, stdout, stderr) -> + if exit_code = 0 then + Lwt_result.return stdout + else begin + Log.warn (fun f -> f "ctr %s failed (exit %d): stdout=%s stderr=%s" + (String.concat " " args) exit_code stdout stderr); + Lwt.return (Fmt.error_msg "ctr %s failed with exit status %d: %s" + (String.concat " " args) exit_code stderr) + end + end + + let ctr args = + ctr_with_output args >|= Result.map (fun _ -> ()) + + let ctr_pread args = + ctr_with_output args + + (* Prepare a writable snapshot from an optional parent. + Uses --mounts to get JSON mount info in the output. *) + let snapshot_prepare ~key ?parent () = + let parent_args = match parent with + | Some p -> [p] + | None -> [] + in + ctr_pread (["snapshot"; "prepare"; "--mounts"; key] @ parent_args) + + let snapshot_commit ~key ~committed_key () = + ctr (["snapshot"; "commit"; committed_key; key]) + + let snapshot_rm ~key () = + ctr (["snapshot"; "rm"; key]) + + let image_pull image = + ctr (["image"; "pull"; image]) +end + +let snapshot_key id = "obuilder-" ^ id + + +let delete t id = + let path = Path.result t id in + match Os.check_dir path with + | `Missing -> Lwt.return_unit + | `Present -> + let rootfs = path / "rootfs" in + let key = + if Sys.file_exists (Hcs.layerinfo_path rootfs) then + (Hcs.read_layerinfo rootfs).snapshot_key + else if Sys.file_exists (Hcs.layerinfo_path path) then + (Hcs.read_layerinfo path).snapshot_key + else + snapshot_key id + in + Log.info (fun f -> f "Deleting snapshot %s for result %s" key id); + (Ctr.snapshot_rm ~key () >>= function + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + Log.warn (fun f -> f "Failed to remove snapshot %s: %s" key m); + Lwt.return_unit) >>= fun () -> + (* Also try to remove the committed snapshot *) + let committed_key = key ^ "-committed" in + (Ctr.snapshot_rm ~key:committed_key () >>= function + | Ok () -> Lwt.return_unit + | Error (`Msg _) -> Lwt.return_unit) >>= fun () -> + Os.rm ~directory:path + +let purge path = + Sys.readdir path |> Array.to_list |> Lwt_list.iter_s (fun item -> + let item = path / item in + Log.warn (fun f -> f "Removing left-over temporary item %S" item); + Os.rm ~directory:item + ) + +let root t = t.root + +let df t = Lwt.return (Os.free_space_percent t.root) + +let create ~root = + Os.ensure_dir root; + 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 } + +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)); + let key = snapshot_key id in + begin match base with + | None -> + (* No parent — this is a base image import. + The fetcher (fn) will handle snapshot preparation and write layerinfo. + We just need to create the result_tmp directory. *) + Os.ensure_dir result_tmp; + Lwt.return_unit + | Some base_id -> + (* Build step with a parent — prepare a snapshot from the parent's committed snapshot. *) + let parent_dir = Path.result t base_id in + let parent_rootfs = parent_dir / "rootfs" in + let parent_key = + if Sys.file_exists (Hcs.layerinfo_path parent_rootfs) then + (Hcs.read_layerinfo parent_rootfs).snapshot_key + else if Sys.file_exists (Hcs.layerinfo_path parent_dir) then + (Hcs.read_layerinfo parent_dir).snapshot_key + else + snapshot_key base_id + in + let parent = parent_key ^ "-committed" in + (* Clean up any existing snapshot with this key (for idempotency) *) + (Ctr.snapshot_rm ~key () >>= function + | Ok () -> Log.info (fun f -> f "Removed existing snapshot %s" key); Lwt.return_unit + | Error _ -> Lwt.return_unit) >>= fun () -> + Log.info (fun f -> f "Preparing snapshot from parent %s" parent); + Ctr.snapshot_prepare ~key ~parent () >>= function + | Ok mounts_json -> + let source, parent_layer_paths = Hcs.parse_mount_json mounts_json in + Os.ensure_dir result_tmp; + Hcs.write_layerinfo ~dir:result_tmp { snapshot_key = key; source; parent_layer_paths } + | Error (`Msg m) -> + Fmt.failwith "Failed to prepare snapshot %s: %s" key m + end + >>= fun () -> + Lwt.try_bind + (fun () -> fn result_tmp) + (fun r -> + begin match r with + | Ok () -> + let rootfs = result_tmp / "rootfs" in + let snap_key = + if Sys.file_exists (Hcs.layerinfo_path rootfs) then + (Hcs.read_layerinfo rootfs).snapshot_key + else if Sys.file_exists (Hcs.layerinfo_path result_tmp) then + (Hcs.read_layerinfo result_tmp).snapshot_key + else + key + in + Log.info (fun f -> f "Snapshot key is %s" snap_key); + let committed_key = snap_key ^ "-committed" in + Log.info (fun f -> f "Committing snapshot %s -> %s" snap_key committed_key); + (* Remove any existing committed snapshot first (idempotency) *) + (Ctr.snapshot_rm ~key:committed_key () >>= function + | Ok () -> Log.info (fun f -> f "Removed existing committed snapshot %s" committed_key); Lwt.return_unit + | Error _ -> Lwt.return_unit) >>= fun () -> + (Ctr.snapshot_commit ~key:snap_key ~committed_key () >>= function + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + Log.warn (fun f -> f "Failed to commit snapshot %s: %s" snap_key m); + Lwt.return_unit) >>= fun () -> + (* On Windows, Sys.rename cannot replace an existing directory. + Remove the target first if it exists (idempotency for retried builds). *) + (if Sys.win32 && Sys.file_exists result then + Os.rm ~directory:result + else Lwt.return_unit) >>= fun () -> + Os.mv ~src:result_tmp result + | Error _ -> + (* Clean up snapshot if we created one *) + (if base <> None then + Ctr.snapshot_rm ~key () >>= function + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + Log.warn (fun f -> f "Failed to remove snapshot %s: %s" key m); + Lwt.return_unit + else Lwt.return_unit) >>= fun () -> + 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); + (if base <> None then + Ctr.snapshot_rm ~key () >>= function + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + Log.warn (fun f -> f "Failed to remove snapshot %s: %s" key m); + Lwt.return_unit + else Lwt.return_unit) >>= fun () -> + Os.rm ~directory:result_tmp >>= fun () -> + Lwt.reraise 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 + +let log_file t id = + result t id >|= function + | Some dir -> dir / "log" + | None -> (Path.result_tmp t id) / "log" + +let state_dir = Path.state + +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 + 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 () -> + let tmp = Path.cache_tmp t t.next name in + t.next <- t.next + 1; + let master = Path.cache t name in + begin match Os.check_dir master with + | `Missing -> + Os.ensure_dir master; + Lwt.return_unit + | `Present -> Lwt.return_unit + end >>= fun () -> + let gen = cache.gen in + Os.ensure_dir tmp; + Os.cp ~src:master tmp >>= fun () -> + let release () = + Lwt_mutex.with_lock cache.lock @@ fun () -> + begin + if cache.gen = gen then ( + cache.gen <- cache.gen + 1; + Os.rm ~directory:master >>= fun () -> + Os.mv ~src:tmp master + ) else + Os.rm ~directory:tmp + end + in + Lwt.return (tmp, release) + +let delete_cache t name = + let cache = get_cache t name in + Lwt_mutex.with_lock cache.lock @@ fun () -> + cache.gen <- cache.gen + 1; + 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 () + +(* After pruning, try to remove all obuilder-base-* containerd snapshots. + Snapshots still in use (have children) will fail harmlessly. + Orphaned ones (whose obuilder entry was already pruned) get cleaned up, + freeing the underlying image layer disk space. *) +let complete_deletes _ = + Ctr.ctr_pread ["snapshot"; "ls"] >>= function + | Error _ -> Lwt.return_unit + | Ok output -> + let lines = String.split_on_char '\n' output in + let base_keys = List.filter_map (fun line -> + let parts = Astring.String.cuts ~empty:false ~sep:" " (String.trim line) in + match parts with + | key :: _ when Astring.String.is_prefix ~affix:"obuilder-base-" key -> Some key + | _ -> None + ) lines in + Lwt_list.iter_s (fun key -> + Ctr.snapshot_rm ~key () >>= function + | Ok () -> + Log.info (fun f -> f "Removed orphaned base snapshot %s" key); + Lwt.return_unit + | Error _ -> Lwt.return_unit + ) base_keys diff --git a/lib/obuilder.ml b/lib/obuilder.ml index f54fed61..3390e599 100644 --- a/lib/obuilder.ml +++ b/lib/obuilder.ml @@ -16,12 +16,14 @@ module Xfs_store = Xfs_store module Store_spec = Store_spec module Docker_store = Docker_store module Qemu_store = Qemu_store +module Hcs_store = Hcs_store (** {2 Fetchers} *) module Zfs_clone = Zfs_clone module Qemu_snapshot = Qemu_snapshot module Docker_extract = Docker.Extract module Archive_extract = Archive_extract +module Hcs_fetch = Hcs_fetch (** {2 Sandboxes} *) @@ -29,6 +31,7 @@ module Config = Config module Native_sandbox = Sandbox module Docker_sandbox = Docker_sandbox module Qemu_sandbox = Qemu_sandbox +module Hcs_sandbox = Hcs_sandbox (** {2 Builders} *) diff --git a/lib/os.ml b/lib/os.ml index 3b371b8f..c1071b41 100644 --- a/lib/os.ml +++ b/lib/os.ml @@ -195,6 +195,11 @@ let pread_result ?cwd ?stdin ?stderr ~pp ?is_success ?cmd argv = (fun () -> Lwt_io.close r) >>= fun data -> child >|= fun r -> Result.map (fun () -> data) r +(* Simple command output capture used by HCS components on Windows. *) +let win32_pread argv = + let pp f = pp_cmd f ("", argv) in + pread_result ~pp argv + 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 -> @@ -231,30 +236,61 @@ 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 - | Error (`Msg m) -> - Log.warn (fun f -> f "Failed to remove %s because %s" directory m); - Lwt.return_unit + if Sys.win32 then begin + (* rmdir is a cmd.exe built-in; use \000 prefix to suppress Lwt_process quoting *) + exec_result ~pp:(pp "RM") ["cmd.exe"; "/c"; "\000rmdir /s /q " ^ Filename.quote directory ] >>= fun t -> + match t with + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + Log.warn (fun f -> f "Failed to remove %s because %s" directory m); + Lwt.return_unit + end else begin + sudo_result ~pp:(pp "RM") ["rm"; "-r"; directory ] >>= fun t -> + match t with + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + Log.warn (fun f -> f "Failed to remove %s because %s" directory m); + Lwt.return_unit + end 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 - | Error (`Msg m) -> - Log.warn (fun f -> f "Failed to move %s to %s because %s" src dst m); - Lwt.return_unit + if Sys.win32 then begin + (* Use synchronous rename on Windows *) + Lwt.catch (fun () -> + Sys.rename src dst; + Lwt.return_unit + ) (fun exn -> + Log.warn (fun f -> f "Failed to move %s to %s because %s" src dst (Printexc.to_string exn)); + Lwt.return_unit + ) + end else begin + sudo_result ~pp:(pp "MV") ["mv"; src; dst ] >>= fun t -> + match t with + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + Log.warn (fun f -> f "Failed to move %s to %s because %s" src dst m); + Lwt.return_unit + end 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 - | Error (`Msg m) -> - Log.warn (fun f -> f "Failed to copy from %s to %s because %s" src dst m); - Lwt.return_unit + if Sys.win32 then + exec_result ~pp:(pp "CP") ["robocopy"; src; dst; "/E"; "/NFL"; "/NDL"; "/NJH"; "/NJS"] + ~is_success:(fun n -> n < 8) (* robocopy exit codes < 8 are success *) + >>= fun t -> + match t with + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + Log.warn (fun f -> f "Failed to copy from %s to %s because %s" src dst m); + Lwt.return_unit + else + sudo_result ~pp:(pp "CP") ["cp"; "-pRduT"; "--reflink=auto"; src; dst ] >>= fun t -> + match t with + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + Log.warn (fun f -> f "Failed to copy from %s to %s because %s" src dst m); + Lwt.return_unit let normalise_path root_dir = if Sys.win32 then diff --git a/lib/store_spec.ml b/lib/store_spec.ml index f676651e..01a07571 100644 --- a/lib/store_spec.ml +++ b/lib/store_spec.ml @@ -10,6 +10,7 @@ type t = [ | `Overlayfs of string (* Path *) | `Docker of string (* Path *) | `Qemu of string (* Path *) + | `Hcs of string (* Path *) ] let is_absolute path = not (Filename.is_relative path) @@ -23,7 +24,8 @@ let of_string s = | Some ("overlayfs", path) when is_absolute path -> Ok (`Overlayfs path) | Some ("docker", path) -> Ok (`Docker path) | Some ("qemu", path) -> Ok (`Qemu path) - | _ -> Error (`Msg "Store must start with zfs:, btrfs:/, rsync:/, xfs:/, qemu:/ or overlayfs:") + | Some ("hcs", path) -> Ok (`Hcs path) + | _ -> Error (`Msg "Store must start with zfs:, btrfs:/, rsync:/, xfs:/, qemu:/, hcs: or overlayfs:") let pp f = function | `Zfs path -> Fmt.pf f "zfs:%s" path @@ -33,6 +35,7 @@ let pp f = function | `Overlayfs path -> Fmt.pf f "overlayfs:%s" path | `Docker path -> Fmt.pf f "docker:%s" path | `Qemu path -> Fmt.pf f "qemu:%s" path + | `Hcs path -> Fmt.pf f "hcs:%s" path type store = Store : (module S.STORE with type t = 'a) * 'a -> store @@ -58,6 +61,9 @@ let to_store = function | `Qemu root -> `Qemu, Qemu_store.create ~root >|= fun store -> Store ((module Qemu_store), store) + | `Hcs root -> + `Hcs, Hcs_store.create ~root >|= fun store -> + Store ((module Hcs_store), store) open Cmdliner @@ -66,7 +72,7 @@ let store_t = Arg.conv (of_string, pp) let store ?docs names = Arg.opt Arg.(some store_t) None @@ Arg.info - ~doc:"$(docv) must be one of $(b,btrfs:/path), $(b,rsync:/path), $(b,xfs:/path), $(b,overlayfs:/path), $(b,zfs:pool), $(b,qemu:/path) or $(b,docker:path) for the OBuilder cache." + ~doc:"$(docv) must be one of $(b,btrfs:/path), $(b,rsync:/path), $(b,xfs:/path), $(b,overlayfs:/path), $(b,zfs:pool), $(b,qemu:/path), $(b,hcs:path) or $(b,docker:path) for the OBuilder cache." ~docv:"STORE" ?docs names @@ -102,7 +108,8 @@ let of_t store rsync_mode = | Some (`Overlayfs path), None -> (`Overlayfs path) | Some (`Docker path), None -> (`Docker path) | Some (`Qemu path), None -> (`Qemu path) - | _, _ -> failwith "Store type required must be one of btrfs:/path, rsync:/path, xfs:/path, zfs:pool, qemu:/path or docker:path for the OBuilder cache." + | Some (`Hcs path), None -> (`Hcs path) + | _, _ -> failwith "Store type required must be one of btrfs:/path, rsync:/path, xfs:/path, zfs:pool, qemu:/path, hcs:path or docker:path for the OBuilder cache." (** Parse cli arguments for t *) let v = diff --git a/lib/tar_transfer.ml b/lib/tar_transfer.ml index c16cbeb3..e84aa205 100644 --- a/lib/tar_transfer.ml +++ b/lib/tar_transfer.ml @@ -29,7 +29,8 @@ module Tar_lwt_unix = struct 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)) + let really_write fd cs = + Os.write_all fd (Cstruct.to_bytes cs) 0 (Cstruct.length cs) end module HW = Tar.HeaderWriter(Lwt)(Writer) @@ -64,18 +65,51 @@ let get_ids = function | `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 + if Sys.win32 then begin + (* On Windows, Lwt I/O hangs. Use synchronous stat and file reads. *) + let stat = Unix.LargeFile.stat src in + let user_id, group_id, uname, gname = get_ids user in + let hdr = Tar.Header.make + ~file_mode:(if stat.Unix.LargeFile.st_perm land 0o111 <> 0 then 0o755 else 0o644) + ~mod_time:(Int64.of_float stat.Unix.LargeFile.st_mtime) + ?user_id ?group_id ?uname ?gname + dst stat.Unix.LargeFile.st_size + in + Tar_lwt_unix.write_block ~level hdr (fun ofd -> + let unix_fd = Lwt_unix.unix_file_descr ofd in + let ic = open_in_bin src in + Fun.protect ~finally:(fun () -> close_in ic) @@ fun () -> + let buf = Bytes.create 4096 in + let rec loop () = + let n = input ic buf 0 4096 in + if n = 0 then () + else begin + let rec write_all ofs len = + if len > 0 then + let w = Unix.write unix_fd buf ofs len in + write_all (ofs + w) (len - w) + in + write_all 0 n; + loop () + end + in + loop (); + Lwt.return_unit + ) to_untar + end else begin + 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 + end let copy_symlink ~src ~target ~dst ~to_untar ~user = Lwt_unix.LargeFile.lstat src >>= fun stat -> @@ -119,10 +153,37 @@ and send_dir ~src_dir ~dst ~to_untar ~user items = copy_dir ~src_dir ~src ~dst ~items ~to_untar ~user ) -let remove_leading_slashes = Astring.String.drop ~sat:((=) '/') +let remove_leading_slashes s = + (* Strip Windows drive letter prefix (e.g. "C:/") *) + let s = + if String.length s >= 2 && Char.uppercase_ascii s.[0] >= 'A' && + Char.uppercase_ascii s.[0] <= 'Z' && s.[1] = ':' then + String.sub s 2 (String.length s - 2) + else s + in + Astring.String.drop ~sat:((=) '/') s + +let ensure_dir_entries ~to_untar ~user path = + (* Emit tar directory entries for each component of path so that + extractors that don't auto-create intermediate directories work. *) + let user_id, group_id, uname, gname = get_ids user in + let parts = String.split_on_char '/' path in + let rec loop acc = function + | [] -> Lwt.return_unit + | "" :: rest | "." :: rest -> loop acc rest + | p :: rest -> + let dir = match acc with "" -> p | _ -> acc ^ "/" ^ p in + let hdr = Tar.Header.make ~file_mode:0o755 + ?user_id ?group_id ?uname ?gname + (dir ^ "/") 0L in + Tar_lwt_unix.write_block ~level hdr (fun _ -> Lwt.return_unit) to_untar >>= fun () -> + loop dir rest + in + loop "" parts let send_files ~src_dir ~src_manifest ~dst_dir ~user ~to_untar = let dst = remove_leading_slashes dst_dir in + ensure_dir_entries ~to_untar ~user dst >>= fun () -> send_dir ~src_dir ~dst ~to_untar ~user src_manifest >>= fun () -> Tar_lwt_unix.write_end to_untar diff --git a/main.ml b/main.ml index 3b4e0870..70312b81 100644 --- a/main.ml +++ b/main.ml @@ -9,6 +9,8 @@ module Docker_store = Obuilder.Docker_store module Docker_extract = Obuilder.Docker_extract module Archive_extract = Obuilder.Archive_extract module Qemu_snapshot = Obuilder.Qemu_snapshot +module Hcs_sandbox = Obuilder.Hcs_sandbox +module Hcs_fetch = Obuilder.Hcs_fetch module Store_spec = Obuilder.Store_spec type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder @@ -40,21 +42,29 @@ let create_qemu_builder store_spec conf = let builder = Builder.v ~store ~sandbox in Builder ((module Builder), builder) +let create_hcs_builder store_spec conf = + store_spec >>= fun (Store_spec.Store ((module Store), store)) -> + let module Builder = Obuilder.Builder (Store) (Hcs_sandbox) (Hcs_fetch) in + Hcs_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> + let builder = Builder.v ~store ~sandbox in + Builder ((module Builder), builder) + let read_whole_file path = let ic = open_in_bin path in Fun.protect ~finally:(fun () -> close_in ic) @@ fun () -> 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 (sandbox, store_spec) native_conf docker_conf qemu_conf hcs_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 + | `Hcs -> create_hcs_builder store_spec hcs_conf -let build () store spec native_conf docker_conf qemu_conf src_dir secrets = +let build () store spec native_conf docker_conf qemu_conf hcs_conf src_dir secrets = Lwt_main.run begin - select_backend store native_conf docker_conf qemu_conf + select_backend store native_conf docker_conf qemu_conf hcs_conf >>= fun (Builder ((module Builder), builder)) -> Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> let spec = @@ -77,9 +87,9 @@ let build () store spec native_conf docker_conf qemu_conf src_dir secrets = exit 1 end -let healthcheck () store native_conf docker_conf qemu_conf = +let healthcheck () store native_conf docker_conf qemu_conf hcs_conf = Lwt_main.run begin - select_backend store native_conf docker_conf qemu_conf + select_backend store native_conf docker_conf qemu_conf hcs_conf >>= fun (Builder ((module Builder), builder)) -> Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> Builder.healthcheck builder >|= function @@ -90,17 +100,17 @@ let healthcheck () store native_conf docker_conf qemu_conf = Fmt.pr "Healthcheck passed@." end -let delete () store native_conf docker_conf qemu_conf id = +let delete () store native_conf docker_conf qemu_conf hcs_conf id = Lwt_main.run begin - select_backend store native_conf docker_conf qemu_conf + select_backend store native_conf docker_conf qemu_conf hcs_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 -let clean () store native_conf docker_conf qemu_conf = +let clean () store native_conf docker_conf qemu_conf hcs_conf = Lwt_main.run begin - select_backend store native_conf docker_conf qemu_conf + select_backend store native_conf docker_conf qemu_conf hcs_conf >>= fun (Builder ((module Builder), builder)) -> Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ begin fun () -> let now = Unix.(gmtime (gettimeofday ())) in @@ -167,21 +177,21 @@ let build = let info = Cmd.info "build" ~doc in Cmd.v info Term.(const build $ setup_log $ store $ spec_file $ Native_sandbox.cmdliner - $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner $ src_dir $ secrets) + $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner $ Hcs_sandbox.cmdliner $ src_dir $ secrets) let delete = let doc = "Recursively delete a cached build result." in let info = Cmd.info "delete" ~doc in Cmd.v info Term.(const delete $ setup_log $ store $ Native_sandbox.cmdliner - $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner $ id) + $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner $ Hcs_sandbox.cmdliner $ id) let clean = let doc = "Clean all cached build results." in let info = Cmd.info "clean" ~doc in Cmd.v info Term.(const clean $ setup_log $ store $ Native_sandbox.cmdliner - $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner) + $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner $ Hcs_sandbox.cmdliner) let buildkit = Arg.value @@ @@ -210,7 +220,7 @@ let healthcheck = let info = Cmd.info "healthcheck" ~doc in Cmd.v info Term.(const healthcheck $ setup_log $ store $ Native_sandbox.cmdliner - $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner) + $ Docker_sandbox.cmdliner $ Qemu_sandbox.cmdliner $ Hcs_sandbox.cmdliner) let cmds = [build; delete; clean; dockerfile; healthcheck]