Support exporting Windows Dockerfiles

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_spec/docker.ml

@@ -2,17 +2,19 @@ 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
@@ -40,19 +42,22 @@ let pp_mount_secret ~ctx f { Secret.id; target; 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 (
       match ctx.user with
       | `Unix { uid; gid } -> Some (Printf.sprintf "%d:%d" uid gid)
@@ -79,31 +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 (`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
+  | `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. *)

lib_spec/spec.ml

@@ -178,9 +178,9 @@ let env k v = `Env (k, v)
 let user_unix ~uid ~gid = `User (`Unix { uid; gid })
 let user_windows ~name = `User (`Windows { name })
 
-let root =
-  if Sys.win32 then `Windows { name = "ContainerAdministrator" }
-  else `Unix { uid = 0; gid = 0 }
+let root_unix = `Unix { uid = 0; gid = 0 }
+let root_windows = `Windows { name = "ContainerAdministrator" }
+let root = if Sys.win32 then root_windows else root_unix
 
 let rec pp_no_boxes f : Sexplib.Sexp.t -> unit = function
   | List xs -> Fmt.pf f "(%a)" (Fmt.list ~sep:Fmt.sp pp_no_boxes) xs

lib_spec/spec.mli

@@ -53,6 +53,8 @@ val env : string -> string -> op
 val user_unix : uid:int -> gid:int -> op
 val user_windows : name:string -> op
 
+val root_unix : [`Unix of unix_user]
+val root_windows : [`Windows of windows_user]
 val root : user
 
 val pp : t Fmt.t

main.ml

@@ -67,10 +67,10 @@ let delete () store conf id =
     Builder.delete builder id ~log:(fun id -> Fmt.pr "Removing %s@." id)
   end
 
-let dockerfile () buildkit spec =
+let dockerfile () buildkit escape spec =
   Sexplib.Sexp.load_sexp spec
   |> Obuilder_spec.t_of_sexp
-  |> Obuilder_spec.Docker.dockerfile_of_spec ~buildkit
+  |> Obuilder_spec.Docker.dockerfile_of_spec ~buildkit ~os:escape
   |> print_endline
 
 open Cmdliner
@@ -139,11 +139,20 @@ let buildkit =
     ~doc:"Output extended BuildKit syntax."
     ["buildkit"]
 
+let escape =
+  let styles = [("unix", `Unix); ("windows", `Windows)] in
+  let doc = Arg.doc_alts_enum styles |> Printf.sprintf "Dockerfile escape style, must be %s." in
+  Arg.value @@
+  Arg.opt Arg.(enum styles) (if Sys.unix then `Unix else `Windows) @@
+  Arg.info ~doc
+    ~docv:"STYLE"
+    ["escape"]
+
 let dockerfile =
   let doc = "Convert a spec to Dockerfile format." in
   let info = Cmd.info ~doc "dockerfile" in
   Cmd.v info
-    Term.(const dockerfile $ setup_log $ buildkit $ spec_file)
+    Term.(const dockerfile $ setup_log $ buildkit $ escape $ spec_file)
 
 let healthcheck =
   let doc = "Perform a self-test." in

test/test.ml

@@ -485,10 +485,10 @@ let test_sexp () =
       (user (uid 1) (gid 2))
      )|}
 
-let test_docker () =
+let test_docker_unix () =
   let test ~buildkit name expect sexp =
     let spec = Spec.t_of_sexp (Sexplib.Sexp.of_string sexp) in
-    let got = Obuilder_spec.Docker.dockerfile_of_spec ~buildkit spec in
+    let got = Obuilder_spec.Docker.dockerfile_of_spec ~buildkit ~os:`Unix spec in
     let expect = remove_indent expect in
     Alcotest.(check string) name expect got
   in
@@ -582,6 +582,59 @@ let test_docker () =
        (shell "command1"))
      ) |}
 
+let test_docker_windows () =
+  let test ~buildkit name expect sexp =
+    let spec = Spec.t_of_sexp (Sexplib.Sexp.of_string sexp) in
+    let got = Obuilder_spec.Docker.dockerfile_of_spec ~buildkit ~os:`Windows spec in
+    let expect = remove_indent expect in
+    Alcotest.(check string) name expect got
+  in
+  test ~buildkit:false "Dockerfile"
+    {| #escape=`
+       FROM base
+       # A test comment
+       WORKDIR C:/src
+       RUN command1
+       SHELL [ "C:/Windows/System32/cmd.exe", "/c" ]
+       RUN command2 && `
+           command3
+       COPY a b c
+       COPY a b c
+       ENV DEBUG="1"
+       USER Zaphod
+       COPY a b c
+    |} {|
+     ((from base)
+      (comment "A test comment")
+      (workdir C:/src)
+      (run (shell "command1"))
+      (shell C:/Windows/System32/cmd.exe /c)
+      (run
+       (cache (a (target /data))
+              (b (target /srv)))
+       (shell "command2 &&
+               command3"))
+      (copy (src a b) (dst c))
+      (copy (src a b) (dst c) (exclude .git _build))
+      (env DEBUG 1)
+      (user (name Zaphod))
+      (copy (src a b) (dst c))
+     ) |};
+  test ~buildkit:false "Multi-stage"
+    {| #escape=`
+       FROM base as tools
+       RUN make tools
+
+       FROM base
+       COPY --from=tools binary /usr/local/bin/
+    |} {|
+     ((build tools
+             ((from base)
+              (run (shell "make tools"))))
+      (from base)
+      (copy (from (build tools)) (src binary) (dst /usr/local/bin/))
+     ) |}
+
 let manifest =
   Alcotest.result
     (Alcotest.testable
@@ -682,7 +735,8 @@ let () =
       "spec", [
         test_case_sync "Sexp"     `Quick test_sexp;
         test_case_sync "Cache ID" `Quick test_cache_id;
-        test_case_sync "Docker"   `Quick test_docker;
+        test_case_sync "Docker UNIX"    `Quick test_docker_unix;
+        test_case_sync "Docker Windows" `Quick test_docker_windows;
       ];
       "build", [
         test_case "Simple"     `Quick test_simple;