Add support for Docker/Windows spec

.gitattributes

@@ -1,3 +1,4 @@
 *.cmd   text eol=crlf
 *.bash  text eol=lf
 *.sh    text eol=lf
+test/test.ml    text eol=lf

README.md

@@ -104,7 +104,7 @@ The initial filesystem snapshot is `BASE`. `run` and `copy` operations create ne
 The initial context is supplied by the user (see [build.mli](lib/build.mli) for details).
 By default:
 - The environment is taken from the Docker configuration of `BASE`.
-- The user is `(uid 0) (gid 0)`.
+- The user is `(uid 0) (gid 0)` on Linux, `(name ContainerAdministrator)` on Windows.
 - The workdir is `/`.
 - The shell is `/bin/bash -c`.
 
@@ -268,6 +268,7 @@ Notes:
 
 ```sexp
 (user (uid UID) (gid GID))
+(user (name NAME))      ; on Windows
 ```
 
 Example:

example.windows.spec

@@ -0,0 +1,64 @@
+; This script builds OBuilder itself using a snapshot of the
+; ocaml/opam:windows-mingw-ocaml-4.14 base image.
+;
+; Run it from the top-level of the OBuilder source tree, e.g.
+;
+;   root=../var
+;   dune exec -- obuilder build --docker-backend="$root" -f example.windows.spec .
+;
+; The result can then be found in the Docker image "obuilder-ROOTID-image-HASH"
+; (where HASH is displayed at the end of the build).
+; The logs can be found in "$root/logs/HASH.log".
+; ROOTID is computed as follows: $(realpath "$(root)" | sha256sum | cut -b -7)
+
+((build dev
+	((from ocaml/opam@sha256:63f5f8207ea61195988d9d49afcc4044bee3183645c58de6959f0864fabd9383)
+	 (workdir /src)
+	 (env OPAM_HASH "74176d75a60a6ec4d90d4178733b1e09f8becc6f") ; Fix the version of opam-repository-mingw we want
+	 (shell /cygwin64/bin/bash.exe --login -c)
+	 (run
+	  (network "nat")
+	  (shell
+	   "cd /home/opam/opam-repository \
+	    && (git cat-file -e $OPAM_HASH || git fetch origin opam2) \
+	    && git reset -q --hard $OPAM_HASH \
+	    && git --no-pager log --no-decorate -n1 --oneline \
+	    && rsync -ar --update --exclude='.git' ./ /cygdrive/c/opam/.opam/repo/default \
+	    && ocaml-env exec --64 -- opam update -u"))
+         ; opam update -u fails because of patch, so I'm overriding the repo with rsync
+	 (shell cmd /S /C)
+	 ; Copy just the opam file first (helps caching)
+	 (copy (src obuilder-spec.opam obuilder.opam) (dst ./))
+	 (run
+	  (network "nat")
+	  (cache (opam-archives (target /opam/.opam/download-cache)))
+	  (shell "ocaml-env exec --64 -- opam pin add -yn ."))
+	 ; Install OS package dependencies
+	 (run
+	  (network "nat")
+	  (cache (opam-archives (target /opam/.opam/download-cache)))
+	  (shell "ocaml-env exec --64 -- opam depext -yu obuilder"))
+	 ; Install OCaml dependencies
+	 (run
+	  (network "nat")
+	  (cache (opam-archives (target /opam/.opam/download-cache)))
+	  (shell "ocaml-env exec --64 -- opam install --deps-only -t obuilder-spec"))
+	 (run
+	  (network "nat")
+	  (cache (opam-archives (target /opam/.opam/download-cache)))
+	  (shell "ocaml-env exec --64 -- opam install --deps-only -t obuilder"))
+	 (copy                                                  ; Copy the rest of the source code
+	  (src .)
+	  (dst /src/)
+	  (exclude .git _build _opam duniverse))
+	 (run (shell "ocaml-env exec --64 -- dune build @install"))))    ; Build
+ ; Now generate a small runtime image with just the resulting binary:
+ (from mcr.microsoft.com/windows/servercore:ltsc2022)
+ (run (shell "mkdir C:\obuilder"))
+ (copy (from (build dev))
+       (src /cygwin64/usr/x86_64-w64-mingw32/sys-root/mingw/bin/libsqlite3-0.dll)
+       (dst /obuilder/libsqlite3-0.dll))
+ (copy (from (build dev))
+       (src /src/_build/default/main.exe)
+       (dst /obuilder/obuilder.exe))
+ (run (shell "/obuilder/obuilder.exe --help")))

lib/btrfs_store.ml

@@ -165,8 +165,11 @@ let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t =
   (* Create writeable clone. *)
   let gen = cache.gen in
   Btrfs.subvolume_snapshot `RW ~src:snapshot tmp >>= fun () ->
-  let { Obuilder_spec.uid; gid } = user in
-  Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; tmp] >>= fun () ->
+  begin 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 () ->
   let release () =
     Lwt_mutex.with_lock cache.lock @@ fun () ->
     begin

lib/rsync_store.ml

@@ -3,7 +3,7 @@
    efficient. *)
 open Lwt.Infix
 
-(* The caching approach (and much of the code) is copied from the btrfs 
+(* The caching approach (and much of the code) is copied from the btrfs
    implementation *)
 type cache = {
   lock : Lwt_mutex.t;
@@ -144,7 +144,10 @@ let cache ~user t name =
   end >>= fun () ->
   (* Create writeable clone. *)
   let gen = cache.gen in
-  let { Obuilder_spec.uid; gid } = user in
+  let { Obuilder_spec.uid; gid } = match user with
+    | `Unix user -> user
+    | `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 () ->

lib/sandbox.runc.ml

@@ -108,7 +108,9 @@ module Json_config = struct
 
   let make {Config.cwd; argv; hostname; user; env; mounts; network; mount_secrets} t ~config_dir ~results_dir : Yojson.Safe.t =
     let user =
-      let { Obuilder_spec.uid; gid } = user in
+      let { Obuilder_spec.uid; gid } = match user with
+        | `Unix user -> user
+        | `Windows _ -> assert false (* runc not supported on Windows *) in
       `Assoc [
         "uid", `Int uid;
         "gid", `Int gid;

lib/tar_transfer.ml

@@ -55,13 +55,21 @@ let copy_to ~dst src =
   in
   aux ()
 
+let get_ids = function
+  | `Unix user -> Some user.Obuilder_spec.uid, Some user.gid, None, None
+  | `Windows user when user.Obuilder_spec.name = "ContainerAdministrator" ->
+    (* https://cygwin.com/cygwin-ug-net/ntsec.html#ntsec-mapping *)
+    let x = 93 and rid = 1 in
+    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:user.Obuilder_spec.uid
-      ~group_id:user.Obuilder_spec.gid
+      ?user_id ?group_id ?uname ?gname
       dst stat.Lwt_unix.LargeFile.st_size
   in
   Tar_lwt_unix.write_block ~level hdr (fun ofd ->
@@ -71,13 +79,13 @@ let copy_file ~src ~dst ~to_untar ~user =
 
 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:user.Obuilder_spec.uid
-      ~group_id:user.Obuilder_spec.gid
+      ?user_id ?group_id ?uname ?gname
       dst 0L
   in
   Tar_lwt_unix.write_block ~level hdr (fun _ -> Lwt.return_unit) to_untar
@@ -86,11 +94,11 @@ let rec copy_dir ~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
+    let user_id, group_id, uname, gname = get_ids user in
     let hdr = Tar.Header.make
         ~file_mode:0o755
         ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime)
-        ~user_id:user.Obuilder_spec.uid
-        ~group_id:user.Obuilder_spec.gid
+        ?user_id ?group_id ?uname ?gname
         (dst ^ "/") 0L
     in
     Tar_lwt_unix.write_block ~level hdr (fun _ -> Lwt.return_unit) to_untar

lib/zfs_store.ml

@@ -89,11 +89,11 @@ end = struct
     else fn ()
 end
 
-let user = { Obuilder_spec.uid = Unix.getuid (); gid = Unix.getgid () }
+let user = `Unix { Obuilder_spec.uid = Unix.getuid (); gid = Unix.getgid () }
 
 module Zfs = struct
   let chown ~user t ds =
-    let { Obuilder_spec.uid; gid } = user in
+    let { Obuilder_spec.uid; gid } = match user with `Unix user -> user | `Windows _ -> assert false in
     Os.sudo ["chown"; strf "%d:%d" uid gid; Dataset.path t ds]
 
   let create t ds =

lib_spec/docker.ml

@@ -2,54 +2,66 @@ type ctx = {
   user : Spec.user;
 }
 
-let default_ctx = {
-  user = Spec.root;
-}
-
 (* Note: could do with some escaping here, but the rules are not clear. *)
 let pp_pair f (k, v) =
   Fmt.pf f "%s=%s" k v
 
-let pp_wrap =
+let pp_escape ~escape =
+  match escape with
+  | '\\' -> Fmt.any " \\@\n    "
+  | '`' -> Fmt.any " `@\n    "
+  | _ -> assert false
+
+let pp_wrap ~escape =
   Fmt.using (String.split_on_char '\n')
-    Fmt.(list ~sep:(any " \\@\n    ") (using String.trim string))
+    Fmt.(list ~sep:(pp_escape ~escape) (using String.trim string))
 
 let pp_cache ~ctx f { Cache.id; target; buildkit_options } =
+  let buildkit_options = match ctx.user with
+    | `Unix {uid; gid = _} -> ("uid", string_of_int uid) :: buildkit_options
+    | `Windows _ -> assert false
+  in
   let buildkit_options =
     ("--mount=type", "cache") ::
     ("id", id) ::
     ("target", target) ::
-    ("uid", string_of_int ctx.user.uid) ::
     buildkit_options
   in
   Fmt.pf f "%a" Fmt.(list ~sep:(any ",") pp_pair) buildkit_options
 
 let pp_mount_secret ~ctx f { Secret.id; target; buildkit_options } =
+  let buildkit_options = match ctx.user with
+    | `Unix {uid; gid = _} -> ("uid", string_of_int uid) :: buildkit_options
+    | `Windows _ -> assert false
+  in
   let buildkit_options =
     ("--mount=type", "secret") ::
     ("id", id) ::
     ("target", target) ::
-    ("uid", string_of_int ctx.user.uid) ::
     buildkit_options
   in
   Fmt.pf f "%a" Fmt.(list ~sep:(any ",") pp_pair) buildkit_options
 
-let pp_run ~ctx f { Spec.cache; shell; secrets; network = _ } =
+let pp_run ~escape ~ctx f { Spec.cache; shell; secrets; network = _ } =
   Fmt.pf f "RUN %a%a%a"
     Fmt.(list (pp_mount_secret ~ctx ++ const string " ")) secrets
     Fmt.(list (pp_cache ~ctx ++ const string " ")) cache
-    pp_wrap shell
+    (pp_wrap ~escape) shell
+
+let is_root user =
+  user = (Spec.root_windows :> Spec.user) || user = (Spec.root_unix :> Spec.user)
 
 let pp_copy ~ctx f { Spec.from; src; dst; exclude = _ } =
   let from = match from with
     | `Build name -> Some name
     | `Context -> None
   in
   let chown =
-    if ctx.user = Spec.root then None
+    if is_root ctx.user then None
     else (
-      let { Spec.uid; gid } = ctx.user in
-      Some (Printf.sprintf "%d:%d" uid gid)
+      match ctx.user with
+      | `Unix { uid; gid } -> Some (Printf.sprintf "%d:%d" uid gid)
+      | `Windows _ -> None
     )
   in
   Fmt.pf f "COPY %a%a%a %s"
@@ -72,30 +84,39 @@ let quote ~escape v =
   Buffer.add_substring buf v !j (len - !j);
   Buffer.contents buf
 
-let pp_op ~buildkit ctx f : Spec.op -> ctx = function
+let pp_op ~buildkit ~escape ctx f : Spec.op -> ctx = function
   | `Comment x                -> Fmt.pf f "# %s" x; ctx
   | `Workdir x                -> Fmt.pf f "WORKDIR %s" x; ctx
   | `Shell xs                 -> Fmt.pf f "SHELL [ %a ]" Fmt.(list ~sep:comma (quote string)) xs; ctx
-  | `Run x when buildkit      -> pp_run ~ctx f x; ctx
-  | `Run x                    -> pp_run ~ctx f { x with cache = []; secrets = []}; ctx
+  | `Run x when buildkit      -> pp_run ~escape ~ctx f x; ctx
+  | `Run x                    -> pp_run ~escape ~ctx f { x with cache = []; secrets = []}; ctx
   | `Copy x                   -> pp_copy ~ctx f x; ctx
-  | `User ({ uid; gid } as u) -> Fmt.pf f "USER %d:%d" uid gid; { user = u }
-  | `Env (k, v)               -> Fmt.pf f "ENV %s=\"%s\"" k (quote ~escape:'\\' v); ctx
+  | `User (`Unix { uid; gid } as u) -> Fmt.pf f "USER %d:%d" uid gid; { user = u }
+  | `User (`Windows { name } as u) -> Fmt.pf f "USER %s" name; { user = u }
+  | `Env (k, v)               -> Fmt.pf f "ENV %s=\"%s\"" k (quote ~escape v); ctx
 
-let rec convert ~buildkit f (name, { Spec.child_builds; from; ops }) =
+let rec convert ~buildkit ~escape ~ctx f (name, { Spec.child_builds; from; ops }) =
   child_builds |> List.iter (fun (name, spec) ->
-      convert ~buildkit f (Some name, spec);
+      convert ~buildkit ~escape ~ctx f (Some name, spec);
       Format.pp_print_newline f ();
     );
   Fmt.pf f "@[<h>FROM %s%a@]@." from Fmt.(option (const string " as " ++ string)) name;
   let (_ : ctx) = List.fold_left (fun ctx op ->
       Format.pp_open_hbox f ();
-      let ctx = pp_op ~buildkit ctx f op in
+      let ctx = pp_op ~buildkit ~escape ctx f op in
       Format.pp_close_box f ();
       Format.pp_print_newline f ();
       ctx
-    ) default_ctx ops
+    ) ctx ops
   in ()
 
-let dockerfile_of_spec ~buildkit t =
-  Fmt.str "%a" (convert ~buildkit) (None, t)
+let dockerfile_of_spec ~buildkit ~os t =
+  Fmt.str "%a" (fun f ->
+      match os with
+      | `Windows ->
+        let ctx = { user = (Spec.root_windows :> Spec.user) } in
+        (Fmt.pf f "@[<h>#escape=`@]@.";
+         convert ~buildkit ~escape:'`' ~ctx f)
+      | `Unix ->
+        let ctx = { user = (Spec.root_unix :> Spec.user) } in
+        convert ~buildkit ~escape:'\\' ~ctx f) (None, t)

lib_spec/docker.mli

@@ -1,11 +1,14 @@
-val dockerfile_of_spec : buildkit:bool -> Spec.t -> string
-(** [dockerfile_of_spec x] produces a Dockerfile that aims to be equivalent to [x].
+val dockerfile_of_spec : buildkit:bool -> os:[`Unix | `Windows] -> Spec.t -> string
+(** [dockerfile_of_spec ~buildkit ~os x] produces a Dockerfile
+   that aims to be equivalent to [x].
 
     However, note that:
 
     - In "(copy (excludes ...) ...)" the excludes part is ignored. You will need to ensure
       you have a suitable ".dockerignore" file.
     - The conversion is not robust against malicious input, as the escaping rules are unclear.
 
-    @param buildkit If true, the extended BuildKit syntax is used to support caches.
-                    If false, caches are ignored. *)
+    @param buildkit If true, the extended BuildKit syntax is used to
+      support caches.  If false, caches are ignored. BuildKit syntax
+      isn't supported on Windows.
+    @param os Use UNIX or Windows syntax and idiosyncrasies. *)