Add HCS (Host Compute Service) backend for Windows containers

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

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

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 "@[<v2>%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

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

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

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

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 _ -> ("", [])

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