* Speed improvements on Windows platform

* Added RISCV64 support
* Added OpenBSD support

doc/qemu.md

@@ -6,48 +6,55 @@ 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:
+`qemu` directory which builds several base images:
 
-- ubuntu-noble-x86_64-ocaml-4.14.img
-- windows-server-2022-x86_64-ocaml-4.14.img
+- ubuntu-noble-amd64-ocaml-4.14.2.qcow2
+- ubuntu-noble-amd64-ocaml-5.2.0.qcow2
+- ubuntu-noble-riscv64-ocaml-4.14.2.qcow2
+- ubuntu-noble-riscv64-ocaml-5.2.0.qcow2
+- openbsd-67-amd64-ocaml-4.14.2.qcow2
+- openbsd-67-amd64-ocaml-5.2.0.qcow2
+- windows-server-2022-amd64-ocaml-4.14.2.qcow2
+- windows-server-2022-amd64-ocaml-5.2.0.qcow2
 
-The base images build automatically using Cloud Init on Ubuntu and
-`autounattend.xml` on Windows.
+The base images build automatically using Cloud Init on Ubuntu,
+`autounattend.xml` on Windows and `autoinstall` on OpenBSD.
 
-# Operation
+Use `make ubuntu`, `make windows` or `make openbsd`.
 
+# 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)
+ (from windows-server-2022-amd64-ocaml-4.14.2)
  (run
-  (cache (opam-archives (target /Users/opam/AppData/Local/opam/download-cache)))
+  (run (cache (opam-archives (target "c:\\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`.
+in this example, the base images would be in `/var/cache/obuilder/base-image/*.qcow2`.
 
 ```
-./_build/install/default/bin/obuilder build --store=qemu:/data -v -f test.spec --qemu-memory 16 --qemu-cpus 8 .
+obuilder build --store=qemu:/var/cache/obuilder -v -f test.spec --qemu-memory 16 --qemu-cpus 8 --qemu-guest-os windows .
 ```
 
 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"…
+(from windows-server-2022-amd64-ocaml-4.14)
+obuilder: [INFO] Base image not present; importing "windows-server-2022-amd64-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 "qemu-img" "create" "-f" "qcow2" "-b" "/var/lib/docker/test/base-image/windows-server-2022-amd64-ocaml-4.14.qcow2" "-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-amd64-ocaml-4.14.qcow2 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”
 ```
@@ -110,13 +117,35 @@ obuilder: [INFO] Exec "mv" "/var/cache/obuilder/test/result-tmp/8a897f21e54db877
 Got: "8a897f21e54db877fc971c757ef7ffc2e1293e191dc60c3a18f24f0d3f0926f3"
 ```
 
-# Note
+# Machine architectures
+
+QEMU support a variety of machine architectures.  The target architecture
+can be selected using `--qemu-guest-arch` parameter.  At the moment only
+AMD64 and RISCV64 are implemented in obuilder.
+
+```
+obuilder build --store=qemu:/var/cache/obuilder -v -f test.spec --qemu-memory 16 --qemu-cpus 8 --qemu-guest-os linux --qemu-guest-arch riscv64 .
+```
+
+By default, guests are given 30 seconds to boot and respond to SSH.
+If you have slower hardware, you can add `--qemu-boot-time` to allow more
+time of the machine to boot.
+
+# Cache
+
+Caching is implemented using additional hard disks which are added
+to the machine and mounted on the cache location.  Different guest
+operating systems will require different filesystems to be available.
+The `Makefile` builds suitable empty disks to be used as cache disks.
 
-While this initial version only runs on x86_64 targetting x86_64
-processors it would be entirely possibly to extend this to other
-architectures.
+The `spec` file could account for the different cache disks by using
+`opam-archives-XXX` rather than just `opam-archives`.  e.g.
+
+```
+run (cache (opam-archives-ntfs (target "C:\\Users\\opam\\AppData\\Local\\opam\\download-cache")))
+```
 
-# Project source
+# Importing the project source
 
 Obuilder uses `tar` to copy the project source into the sandbox.
 Attempts to use `tar -xf - . | ssh opam@localhost -p 60022 tar -xf -`

lib/build.ml

@@ -148,7 +148,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
       (* Fmt.pr "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details); *)
       let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in
       Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log result_tmp ->
-          let argv = Option.value ~default:(["tar"; "-xf"; "-"]) Sandbox.tar in
+          let argv = Option.value ~default:(["tar"; "-xf"; "-"]) (Sandbox.tar t.sandbox) in
           let config = Config.v
               ~cwd:"/"
               ~argv
@@ -279,8 +279,8 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st
   let df t =
     Store.df t.store
 
-  let shell =
-    Sandbox.shell
+  let shell t =
+    Sandbox.shell t.sandbox
 
   let root t =
     Store.root t.store
@@ -544,8 +544,7 @@ module Make_Docker (Raw_store : S.STORE) = struct
   let df t =
     Store.df t.store
 
-  let shell =
-    Sandbox.shell
+  let shell _ = None
 
   let root t =
     Store.root t.store

lib/docker_sandbox.ml

@@ -462,9 +462,9 @@ let create (c : config) =
 let finished () =
   Lwt.return ()
 
-let shell = None
+let shell _ = None
 
-let tar = None
+let tar _ = None
 
 open Cmdliner
 

lib/qemu_sandbox.ml

@@ -12,16 +12,31 @@ let copy_to_log ~src ~dst =
   in
   aux ()
 
+type guest_os =
+  | Linux
+  | OpenBSD
+  | Windows
+[@@deriving sexp]
+
+type guest_arch =
+  | Amd64
+  | Riscv64
+[@@deriving sexp]
+
 type t = {
   qemu_cpus : int;
   qemu_memory : int;
-  qemu_network : string;   (* Default network, overridden by network stanza *)
+  qemu_guest_os : guest_os;
+  qemu_guest_arch : guest_arch;
+  qemu_boot_time : int;
 }
 
 type config = {
   cpus : int;
   memory : int;
-  network : string;
+  guest_os : guest_os;
+  guest_arch : guest_arch;
+  boot_time : int;
 } [@@deriving sexp]
 
 let get_free_port () =
@@ -37,22 +52,27 @@ let run ~cancelled ?stdin ~log t config result_tmp =
   let pp f = Os.pp_cmd f ("", config.Config.argv) in
 
   let extra_mounts = List.map (fun { Config.Mount.src; _ } ->
-    ["-drive"; "file=" ^ src / "rootfs" / "image.qcow2" ^ ",format=qcow2"]
+    ["-drive"; "file=" ^ src / "rootfs" / "image.qcow2" ^ ",if=virtio"]
   ) config.Config.mounts |> List.flatten in
 
   Os.with_pipe_to_child @@ fun ~r:qemu_r ~w:qemu_w ->
   let qemu_stdin = `FD_move_safely qemu_r in
   let qemu_monitor = Lwt_io.(of_fd ~mode:output) qemu_w in
   let port = get_free_port () in
-  let cmd = [ "qemu-system-x86_64";
+  let qemu_binary = match t.qemu_guest_arch with
+    | Amd64 -> [ "qemu-system-x86_64"; "-machine"; "accel=kvm,type=pc"; "-cpu"; "host"; "-display"; "none";
+                 "-device"; "virtio-net,netdev=net0" ]
+    | Riscv64 -> [ "qemu-system-riscv64"; "-machine"; "type=virt"; "-nographic";
+                   "-bios"; "/usr/lib/riscv64-linux-gnu/opensbi/generic/fw_jump.bin";
+                   "-kernel"; "/usr/lib/u-boot/qemu-riscv64_smode/uboot.elf";
+                   "-device"; "virtio-net-device,netdev=net0";
+                   "-serial"; "none"] in
+  let cmd = qemu_binary @ [
+              "-monitor"; "stdio";
               "-m"; (string_of_int t.qemu_memory) ^ "G";
               "-smp"; string_of_int t.qemu_cpus;
-              "-machine"; "accel=kvm,type=q35";
-              "-cpu"; "host";
-              "-nic"; "user,hostfwd=tcp::" ^ port ^ "-:22";
-              "-display"; "none";
-              "-monitor"; "stdio";
-              "-drive"; "file=" ^ result_tmp / "rootfs" / "image.qcow2" ^ ",format=qcow2" ]
+              "-netdev"; "user,id=net0,hostfwd=tcp::" ^ port ^ "-:22";
+              "-drive"; "file=" ^ result_tmp / "rootfs" / "image.qcow2" ^ ",if=virtio" ]
               @ extra_mounts in
   let _, proc = Os.open_process ~stdin:qemu_stdin ~stdout:`Dev_null ~pp cmd in
 
@@ -65,12 +85,22 @@ let run ~cancelled ?stdin ~log t config result_tmp =
       | Ok _ -> Lwt_result.ok (Lwt.return ())
       | _ -> Lwt_unix.sleep 1. >>= fun _ -> loop (n - 1) in
   Lwt_unix.sleep 5. >>= fun _ ->
-  loop 30 >>= fun _ ->
+  loop t.qemu_boot_time >>= fun _ ->
 
   Lwt_list.iteri_s (fun i { Config.Mount.dst; _ } ->
-    Os.exec (ssh @ ["cmd"; "/c"; "rmdir /s /q '" ^ dst ^ "'"]) >>= fun () ->
-    let drive_letter = String.init 1 (fun _ -> Char.chr (Char.code 'd' + i)) in
-    Os.exec (ssh @ ["cmd"; "/c"; "mklink /j '" ^ dst ^ "' '" ^ drive_letter ^ ":\\'"])) config.Config.mounts >>= fun () ->
+    match t.qemu_guest_os with
+    | Linux ->
+      let dev = Printf.sprintf "/dev/vd%c1" (Char.chr (Char.code 'b' + i)) in
+      Os.exec (ssh @ ["sudo"; "mount"; dev; dst])
+    | OpenBSD ->
+      let dev = Printf.sprintf "/dev/sd%ca" (Char.chr (Char.code '1' + i)) in
+      Os.exec (ssh @ ["doas"; "fsck"; "-y"; dev]) >>= fun () ->
+      Os.exec (ssh @ ["doas"; "mount"; dev; dst])
+    | Windows ->
+      Os.exec (ssh @ ["cmd"; "/c"; "rmdir /s /q '" ^ dst ^ "'"]) >>= fun () ->
+      let drive_letter = String.init 1 (fun _ -> Char.chr (Char.code 'd' + i)) in
+      Os.exec (ssh @ ["cmd"; "/c"; "mklink /j '" ^ dst ^ "' '" ^ drive_letter ^ ":\\'"])
+  ) config.Config.mounts >>= fun () ->
 
   Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w ->
   let stdin = Option.map (fun x -> `FD_move_safely x) stdin in
@@ -91,8 +121,14 @@ let run ~cancelled ?stdin ~log t config result_tmp =
   Os.process_result ~pp proc2 >>= fun res ->
   copy_log >>= fun () ->
 
-  Log.info (fun f -> f "Sending QEMU an ACPI shutdown event");
-  Lwt_io.write qemu_monitor "system_powerdown\n" >>= fun () ->
+  (match t.qemu_guest_arch with
+    | Amd64 ->
+      Log.info (fun f -> f "Sending QEMU an ACPI shutdown event");
+      Lwt_io.write qemu_monitor "system_powerdown\n"
+    | Riscv64 ->
+      (* QEMU RISCV does not support ACPI until >= v9 *)
+      Log.info (fun f -> f "Shutting down the VM");
+      Os.exec (ssh @ ["sudo"; "poweroff"])) >>= fun () ->
   let rec loop = function
   | 0 ->
     Log.warn (fun f -> f "Powering off QEMU");
@@ -102,23 +138,27 @@ let run ~cancelled ?stdin ~log t config result_tmp =
       Lwt_unix.sleep 1. >>= fun () ->
       loop (n - 1)
     else Lwt.return () in
-  loop 30 >>= fun _ ->
+  loop t.qemu_boot_time >>= fun _ ->
 
   Os.process_result ~pp proc >>= fun _ ->
 
   if Lwt.is_sleeping cancelled then Lwt.return (res :> (unit, [`Msg of string | `Cancelled]) result)
   else Lwt_result.fail `Cancelled
 
 let create (c : config) =
-  let t = { qemu_cpus = c.cpus; qemu_memory = c.memory; qemu_network = c.network } in
+  let t = { qemu_cpus = c.cpus; qemu_memory = c.memory; qemu_guest_os = c.guest_os; qemu_guest_arch = c.guest_arch; qemu_boot_time = c.boot_time } in
   Lwt.return t
 
 let finished () =
   Lwt.return ()
 
-let shell = Some []
+let shell _ = Some []
 
-let tar = Some ["/cygdrive/c/Windows/System32/tar.exe"; "-xf"; "-"; "-C"; "/"]
+let tar t =
+  match t.qemu_guest_os with
+  | Linux -> None
+  | OpenBSD -> Some ["gtar"; "-xf"; "-"]
+  | Windows -> Some ["/cygdrive/c/Windows/System32/tar.exe"; "-xf"; "-"; "-C"; "/"]
 
 open Cmdliner
 
@@ -140,16 +180,39 @@ let memory =
     ~docv:"MEMORY"
     ["qemu-memory"]
 
-let network =
+let guest_os =
+  let options =
+    [("linux", Linux);
+     ("openbsd", OpenBSD);
+     ("windows", Windows)] in
+  Arg.value @@
+  Arg.opt Arg.(enum options) Linux @@
+  Arg.info ~docs
+    ~doc:(Printf.sprintf "Set OS used by QEMU guest. $(docv) must be %s." (Arg.doc_alts_enum options))
+    ~docv:"GUEST_OS"
+    ["qemu-guest-os"]
+
+let guest_arch =
+  let options =
+    [("amd64", Amd64);
+     ("riscv64", Riscv64)] in
+  Arg.value @@
+  Arg.opt Arg.(enum options) Amd64 @@
+  Arg.info ~docs
+    ~doc:(Printf.sprintf "Set system architecture used by QEMU guest. $(docv) must be %s." (Arg.doc_alts_enum options))
+    ~docv:"GUEST_OS"
+    ["qemu-guest-arch"]
+
+let boot_time =
   Arg.value @@
-  Arg.opt Arg.string (if Sys.unix then "host" else "nat") @@
+  Arg.opt Arg.int 30 @@
   Arg.info ~docs
-    ~doc:"Docker network used for the Docker backend setup."
-    ~docv:"NETWORK"
-    ["qemu-network"]
+    ~doc:"The maximum time in seconds to wait for the machine to boot/power off."
+    ~docv:"BOOT_TIME"
+    ["qemu-boot-time"]
 
 let cmdliner : config Term.t =
-  let make cpus memory network =
-    { cpus; memory; network; }
+  let make cpus memory guest_os guest_arch boot_time =
+    { cpus; memory; guest_os; guest_arch; boot_time }
   in
-  Term.(const make $ cpus $ memory $ network)
+  Term.(const make $ cpus $ memory $ guest_os $ guest_arch $ boot_time)

lib/qemu_snapshot.ml

@@ -4,9 +4,8 @@ let ( / ) = Filename.concat
 
 let fetch ~log:_ ~root ~rootfs base =
     let base_image = match base with
-    | "busybox" -> root / "base-image" / "ubuntu-noble-x86_64-ocaml-4.14.img"
-    | x -> root / "base-image" / (x ^ ".img") in
+    | "busybox" -> root / "base-image" / "ubuntu-noble-amd64-ocaml-4.14.qcow2"
+    | x -> root / "base-image" / (x ^ ".qcow2") in
     Os.sudo [ "qemu-img"; "create"; "-f"; "qcow2"; "-b"; base_image; "-F"; "qcow2"; rootfs / "image.qcow2" ] >>= fun () ->
   Lwt.return []
 
-

lib/s.ml

@@ -89,10 +89,10 @@ module type SANDBOX = sig
       @param log Used for child's stdout and stderr.
   *)
 
-  val shell : string list option
+  val shell : t -> string list option
   (** [shell] optional value to be used as the default shell. *)
 
-  val tar : string list option
+  val tar : t -> string list option
   (** [tar] tar command for this sandbox. *)
 
   val finished : unit -> unit Lwt.t
@@ -134,7 +134,7 @@ module type BUILDER = sig
   val df : t -> float Lwt.t
   (** [df t] returns the percentage of free space in the store. *)
 
-  val shell : string list option
+  val shell : t -> string list option
   (** [shell] optional value to be used as the default shell. *)
 
   val cache_stats : t -> int * int

lib/sandbox.jail.ml

@@ -168,9 +168,9 @@ let create ~state_dir:_ _c =
 let finished () =
   Lwt.return ()
 
-let shell = None
+let shell _ = None
 
-let tar = None
+let tar _ = None
 
 open Cmdliner