QEMU backend

doc/index.mld

@@ -8,3 +8,4 @@ The entry point of this library is the module:
 - {{!page-macOS}macOS implementation documentation}.
 - {{!page-freebsd}FreeBSD implementation documentation}.
 - {{!page-windows}Windows implementation documentation}.
+- {{!page-qemu}QEMU implementation documentation}.

doc/qemu.md

@@ -0,0 +1,117 @@
+# OBuilder's QEMU Sandbox
+
+This backend should work with any OS which can be booted in QEMU and
+which can provide an SSH interface.
+
+# Base Images
+
+These need to be provided as boot disks.  There is a `Makefile` in the
+`qemu` directory which builds two base images:
+
+- ubuntu-noble-x86_64-ocaml-4.14.img
+- windows-server-2022-x86_64-ocaml-4.14.img
+
+The base images build automatically using Cloud Init on Ubuntu and
+`autounattend.xml` on Windows.
+
+# Operation
+
+
+A spec which reference the required base image in using the `from`
+directive, then run the whatever commands are required.  An trivial
+example is given below.
+
+```
+(
+ (from windows-server-2022-x86_64-ocaml-4.14)
+ (run
+  (cache (opam-archives (target /Users/opam/AppData/Local/opam/download-cache)))
+  (shell "opam install tar")
+ )
+)
+```
+
+A typical invocation via `obuilder build` would be as below.  Note that
+in this example, the base images would be in `/data/base-image/*.img`.
+
+```
+./_build/install/default/bin/obuilder build --store=qemu:/data -v -f test.spec --qemu-memory 16 --qemu-cpus 8 .
+```
+
+The `from` directive causes `qemu-img` to create a snapshot of the base
+image and stage it in the `result-tmp` folder.  When this completes
+successfully, `result-tmp` is moved to `result`:
+
+```
+(from windows-server-2022-x86_64-ocaml-4.14)
+obuilder: [INFO] Base image not present; importing "windows-server-2022-x86_64-ocaml-4.14"…
+obuilder: [INFO] Exec "mkdir" "-m" "755" "--" "/var/lib/docker/test/result-tmp/dce4336e183de81da7537728ed710f2906e9f75431694d9de80b95a9d9ff1101/rootfs"
+obuilder: [INFO] Exec "qemu-img" "create" "-f" "qcow2" "-b" "/var/lib/docker/test/base-image/windows-server-2022-x86_64-ocaml-4.14.img" "-F" "qcow2" "/var/lib/docker/test/result-tmp/dce4336e183de81da7537728ed710f2906e9f75431694d9de80b95a9d9ff1101/rootfs/image.qcow2"
+Formatting '/var/lib/docker/test/result-tmp/dce4336e183de81da7537728ed710f2906e9f75431694d9de80b95a9d9ff1101/rootfs/image.qcow2', fmt=qcow2 cluster_size=65536 extended_l2=off compression_type=zlib size=42949672960 backing_file=/var/lib/docker/test/base-image/windows-server-2022-x86_64-ocaml-4.14.img backing_fmt=qcow2 lazy_refcounts=off refcount_bits=16
+obuilder: [INFO] Exec "mv" "/var/lib/docker/test/result-tmp/dce4336e183de81da7537728ed710f2906e9f75431694d9de80b95a9d9ff1101" "/var/lib/docker/test/result/dce4336e183de81da7537728ed710f2906e9f75431694d9de80b95a9d9ff1101"
+---> saved as “dce4336e183de81da7537728ed710f2906e9f75431694d9de80b95a9d9ff1101”
+```
+
+Moving on to the next stage in the build which is the `run` directive.
+First, `qemu-img` creates a snapshot of the current `result` layer into
+`result-tmp`.  Then any cache volumes are copied and `qemu-system-x86_64`
+is started with this snapshot as the base image and the cache volumes
+available as extra disks.  `ssh` is used to poll the machine until it is
+available.  Next, `ssh` commands are executed to create a NTFS junction
+point on the directory `c:\Users\opam\AppData\Local\opam\download-cache`.
+Finally, the actual commands are sent over `ssh` to install `tar`.
+The step completes with an `scp` of the cache back to the host followed
+by an ACPI shutdown command sent to the qemu console.
+
+```
+/: (run (cache (opam-archives (target "C:\\Users\\opam\\AppData\\Local\\opam\\download-cache")))
+        (shell "opam install tar"))
+obuilder: [INFO] Exec "qemu-img" "create" "-f" "qcow2" "-b" "/var/cache/obuilder/test/result/dce4336e183de81da7537728ed710f2906e9f75431694d9de80b95a9d9ff1101/rootfs/image.qcow2" "-F" "qcow2" "/var/cache/obuilder/test/result-tmp/8a897f21e54db877fc971c757ef7ffc2e1293e191dc60c3a18f24f0d3f0926f3/rootfs/image.qcow2" "40G"
+obuilder: [INFO] Exec "cp" "-pRduT" "--reflink=auto" "/var/cache/obuilder/test/cache/c-opam-archives" "/var/cache/obuilder/test/cache-tmp/0-c-opam-archives"
+obuilder: [INFO] Fork exec "qemu-system-x86_64" "-m" "16G" "-smp" "8" "-machine" "accel=kvm,type=q35" "-cpu" "host" "-nic" "user,hostfwd=tcp::56229-:22" "-display" "none" "-monitor" "stdio" "-drive" "file=/var/cache/obuilder/test/result-tmp/8a897f21e54db877fc971c757ef7ffc2e1293e191dc60c3a18f24f0d3f0926f3/rootfs/image.qcow2,format=qcow2" "-drive" "file=/var/cache/obuilder/test/cache-tmp/0-c-opam-archives/rootfs/image.qcow2,format=qcow2"
+obuilder: [INFO] Exec "ssh" "opam@localhost" "-p" "56229" "-o" "NoHostAuthenticationForLocalhost=yes" "exit"
+obuilder: [INFO] Exec "ssh" "opam@localhost" "-p" "56229" "-o" "NoHostAuthenticationForLocalhost=yes" "cmd" "/c" "rmdir /s /q 'C:\Users\opam\AppData\Local\opam\download-cache'"
+obuilder: [INFO] Exec "ssh" "opam@localhost" "-p" "56229" "-o" "NoHostAuthenticationForLocalhost=yes" "cmd" "/c" "mklink /j 'C:\Users\opam\AppData\Local\opam\download-cache' 'd:\'"
+Junction created for C:\Users\opam\AppData\Local\opam\download-cache <<===>> d:\
+obuilder: [INFO] Fork exec "ssh" "opam@localhost" "-p" "56229" "-o" "NoHostAuthenticationForLocalhost=yes" "cd" "/" "&&" "opam install tar"
+The following actions will be performed:
+=== install 8 packages
+  - install checkseum         0.5.2  [required by decompress]
+  - install cmdliner          1.3.0  [required by decompress]
+  - install csexp             1.5.2  [required by dune-configurator]
+  - install decompress        1.5.3  [required by tar]
+  - install dune              3.16.0 [required by tar]
+  - install dune-configurator 3.16.0 [required by checkseum]
+  - install optint            0.3.0  [required by decompress]
+  - install tar               3.1.2
+
+<><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><>
+-> retrieved checkseum.0.5.2  (cached)
+-> retrieved cmdliner.1.3.0  (cached)
+-> retrieved csexp.1.5.2  (cached)
+-> retrieved decompress.1.5.3  (cached)
+-> retrieved optint.0.3.0  (cached)
+-> retrieved tar.3.1.2  (cached)
+-> retrieved dune.3.16.0, dune-configurator.3.16.0  (cached)
+-> installed cmdliner.1.3.0
+-> installed dune.3.16.0
+-> installed csexp.1.5.2
+-> installed optint.0.3.0
+-> installed dune-configurator.3.16.0
+-> installed checkseum.0.5.2
+-> installed decompress.1.5.3
+-> installed tar.3.1.2
+Done.
+# Run eval $(opam env) to update the current shell environment
+obuilder: [INFO] Exec "cp" "-pRduT" "--reflink=auto" "/var/cache/obuilder/test/cache-tmp/0-c-opam-archives" "/var/cache/obuilder/test/cache/c-opam-archives"
+obuilder: [INFO] Exec "rm" "-r" "/var/cache/obuilder/test/cache-tmp/0-c-opam-archives"
+obuilder: [INFO] Exec "mv" "/var/cache/obuilder/test/result-tmp/8a897f21e54db877fc971c757ef7ffc2e1293e191dc60c3a18f24f0d3f0926f3" "/var/cache/obuilder/test/result/8a897f21e54db877fc971c757ef7ffc2e1293e191dc60c3a18f24f0d3f0926f3"
+---> saved as "8a897f21e54db877fc971c757ef7ffc2e1293e191dc60c3a18f24f0d3f0926f3"
+Got: "8a897f21e54db877fc971c757ef7ffc2e1293e191dc60c3a18f24f0d3f0926f3"
+```
+
+# Note
+
+While this initial version only runs on x86_64 targetting x86_64
+processors it would be entirely possibly to extend this to other
+architectures.

lib/archive_extract.ml

@@ -14,8 +14,7 @@ let invoke_fetcher base destdir =
     fetcher >>= fun () ->
     extracter
 
-let fetch ~log ~rootfs base =
-  let _ = log in
+let fetch ~log:_ ~root:_ ~rootfs base =
   Lwt.catch
     (fun () ->
      invoke_fetcher base rootfs >>= fun () ->

lib/build.ml

@@ -161,7 +161,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
               ()
           in
           Os.with_pipe_to_child @@ fun ~r:from_us ~w:to_untar ->
-          let proc = Sandbox.run ~cancelled ~stdin:from_us ~log t.sandbox config result_tmp in
+          let proc = Sandbox.tar_in ~cancelled ~stdin:from_us ~log t.sandbox config result_tmp in
           let send =
             (* If the sending thread finishes (or fails), close the writing socket
                immediately so that the tar process finishes too. *)
@@ -233,11 +233,12 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
   let get_base t ~log base =
     log `Heading (Fmt.str "(from %a)" Sexplib.Sexp.pp_hum (Atom base));
     let id = Sha256.to_hex (Sha256.string base) in
+    let root = Store.root t.store in
     Store.build t.store ~id ~log (fun ~cancelled:_ ~log tmp ->
         Log.info (fun f -> f "Base image not present; importing %S…" base);
         let rootfs = tmp / "rootfs" in
         Os.sudo ["mkdir"; "-m"; "755"; "--"; rootfs] >>= fun () ->
-        Fetch.fetch ~log ~rootfs base >>= fun env ->
+        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 () ->
         Lwt_result.return ()
@@ -278,6 +279,9 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
   let df t =
     Store.df t.store
 
+  let root t =
+    Store.root t.store
+
   let cache_stats t =
     Store.cache_stats t.store
 
@@ -537,6 +541,9 @@ module Make_Docker (Raw_store : S.STORE) = struct
   let df t =
     Store.df t.store
 
+  let root t =
+    Store.root t.store
+
   let cache_stats t =
     Store.cache_stats t.store
 

lib/db_store.ml

@@ -132,6 +132,7 @@ module Make (Raw : S.STORE) = struct
   let result t id = Raw.result t.raw id
   let count t = Dao.count t.dao
   let df t = Raw.df t.raw
+  let root t = Raw.root t.raw
   let cache_stats t = t.cache_hit, t.cache_miss
   let cache ~user t = Raw.cache ~user t.raw
 

lib/db_store.mli

@@ -24,6 +24,8 @@ module Make (Raw : S.STORE) : sig
 
   val df : t -> float Lwt.t
 
+  val root : t -> string
+
   val cache_stats : t -> int * int
 
   val cache :

lib/docker.ml

@@ -367,7 +367,7 @@ module Extract = struct
           | Some _ as pair -> pair
       )
 
-  let fetch ~log ~rootfs base =
+  let fetch ~log ~root:_ ~rootfs base =
     let* () = with_container ~log base (fun cid ->
         Os.with_pipe_between_children @@ fun ~r ~w ->
         let exporter = Cmd.export ~stdout:(`FD_move_safely w) (`Docker_container cid) in

lib/docker_sandbox.ml

@@ -155,6 +155,9 @@ let run ~cancelled ?stdin ~log t config (id:S.id) =
   if Lwt.is_sleeping cancelled then (r :> (unit, [`Msg of string | `Cancelled]) result)
   else Error `Cancelled
 
+let tar_in ~cancelled ?stdin ~log t config result_tmp =
+  run ~cancelled ?stdin ~log t config result_tmp
+
 (* Duplicate of Build.hostname. *)
 let hostname = "builder"
 

lib/obuilder.ml

@@ -1,33 +1,36 @@
 let log_src = Log.src
 
-(** {2 Types} *)
+(** {4 Types} *)
 
 module S = S
 module Spec = Obuilder_spec
 module Context = Build.Context
 module Docker = Docker
 
-(** {2 Stores} *)
+(** {7 Stores} *)
 
 module Btrfs_store = Btrfs_store
 module Zfs_store = Zfs_store
 module Rsync_store = Rsync_store
 module Xfs_store = Xfs_store
 module Store_spec = Store_spec
 module Docker_store = Docker_store
+module Qemu_store = Qemu_store
 
-(** {2 Fetchers} *)
+(** {4 Fetchers} *)
 module Zfs_clone = Zfs_clone
+module Qemu_snapshot = Qemu_snapshot
 module Docker_extract = Docker.Extract
 module Archive_extract = Archive_extract
 
-(** {2 Sandboxes} *)
+(** {3 Sandboxes} *)
 
 module Config = Config
 module Native_sandbox = Sandbox
 module Docker_sandbox = Docker_sandbox
+module Qemu_sandbox = Qemu_sandbox
 
-(** {2 Builders} *)
+(** {3 Builders} *)
 
 module type BUILDER = S.BUILDER with type context := Build.Context.t
 module Builder = Build.Make

lib/os.ml

@@ -66,13 +66,13 @@ let default_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp argv =
 
 (* Similar to default_exec except using open_process_none in order to get the
    pid of the forked process. On macOS this allows for cleaner job cancellations *)
-let open_process ?cwd ?stdin ?stdout ?stderr ?pp:_ argv =
+let open_process ?cwd ?env ?stdin ?stdout ?stderr ?pp:_ argv =
   Logs.info (fun f -> f "Fork exec %a" pp_cmd ("", argv));
   let proc =
     let stdin  = Option.map redirection stdin in
     let stdout = Option.map redirection stdout in
     let stderr = Option.map redirection stderr in
-    let process = Lwt_process.open_process_none ?cwd ?stdin ?stdout ?stderr ("", (Array.of_list argv)) in
+    let process = Lwt_process.open_process_none ?cwd ?env ?stdin ?stdout ?stderr ("", (Array.of_list argv)) in
   (process#pid, process#status)
   in
     Option.iter close_redirection stdin;
@@ -213,6 +213,12 @@ let check_dir x =
   | _ -> Fmt.failwith "Exists, but is not a directory: %S" x
   | exception Unix.Unix_error(Unix.ENOENT, _, _) -> `Missing
 
+let check_file x =
+  match Unix.lstat x with
+  | Unix.{ st_kind = S_REG; _ } -> `Present
+  | _ -> Fmt.failwith "Exists, but is not a regular file: %S" x
+  | exception Unix.Unix_error(Unix.ENOENT, _, _) -> `Missing
+
 let ensure_dir ?(mode=0o777) path =
   match check_dir path with
   | `Present -> ()
@@ -232,6 +238,24 @@ let rm ~directory =
     Log.warn (fun f -> f "Failed to remove %s because %s" directory m);
     Lwt.return_unit
 
+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
+
+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
+
 let normalise_path root_dir =
   if Sys.win32 then
     let vol, _ = Fpath.(v root_dir |> split_volume) in