[Mirage 3.x] Port to new Mirage/Xen platform stack

.travis.yml

@@ -10,7 +10,7 @@ env:
    - PACKAGE=mirage
    - TESTS=false
  jobs:
-   - DISTRO=alpine OCAML_VERSION=4.09 EXTRA_ENV="MODE=unix" TESTS=true
+   - DISTRO=alpine OCAML_VERSION=4.09 EXTRA_ENV="MODE=unix"
    - DISTRO=alpine OCAML_VERSION=4.09 EXTRA_ENV="MODE=virtio"
    - DISTRO=alpine OCAML_VERSION=4.10 EXTRA_ENV="MODE=spt"
    - DISTRO=ubuntu OCAML_VERSION=4.08 EXTRA_ENV="MODE=xen"

lib/mirage.ml

@@ -234,9 +234,13 @@ module Project = struct
         | #Mirage_key.mode_unix ->
           package ~min:"4.0.0" ~max:"5.0.0" "mirage-unix" :: common
         | #Mirage_key.mode_xen ->
-          package ~min:"5.0.0" ~max:"6.0.0" "mirage-xen" :: common
+          (* The Mirage/Xen PVH platform package has different version numbers
+           * than Mirage/Solo5, so needs its own case here. *)
+          package ~min:"0.6.0" ~max:"0.7.0" ~ocamlfind:[] "solo5-bindings-xen" ::
+          package ~min:"6.0.0" ~max:"7.0.0" "mirage-xen" ::
+          common
         | #Mirage_key.mode_solo5 as tgt ->
-          package ~min:"0.6.0" ~max:"0.7.0" ~ocamlfind:[] (fst (Mirage_configure_solo5.solo5_pkg tgt)) ::
+          package ~min:"0.6.0" ~max:"0.7.0" ~ocamlfind:[] (Mirage_configure_solo5.solo5_bindings_pkg tgt) ::
           package ~min:"0.6.1" ~max:"0.7.0" "mirage-solo5" ::
           common
 

lib/mirage_build.ml

@@ -65,7 +65,7 @@ let build i =
   let target_debug = Key.(get ctx target_debug) in
   compile ignore_dirs libs warn_error target >>= fun () ->
   (match target with
-    | #Mirage_key.mode_solo5 ->
+    | #Mirage_key.mode_solo5 | #Mirage_key.mode_xen ->
         Mirage_configure_solo5.generate_manifest_c () >>= fun () ->
         Mirage_configure_solo5.compile_manifest target
     | _ -> R.ok ()) >>= fun () ->

lib/mirage_configure.ml

@@ -32,20 +32,17 @@ let clean_myocamlbuild () =
 let opam_path ~name = Fpath.(v name + "opam")
 
 let artifact ~name = function
-  | #Mirage_key.mode_solo5 as tgt ->
-    let ext = snd (Mirage_configure_solo5.solo5_pkg tgt) in
+  | #Mirage_key.mode_solo5 | #Mirage_key.mode_xen as tgt ->
+    let ext = Mirage_configure_solo5.bin_extension tgt in
     let file = Fpath.v (name ^ ext) in
     file, file
   | #Mirage_key.mode_unix ->
     Fpath.(v "_build" / "main" + "native"), Fpath.v name
-  | #Mirage_key.mode_xen ->
-    let file = Fpath.(v name + "xen") in
-    file, file
 
 let additional_artifacts ~name =
   let libvirt = Mirage_configure_libvirt.filename ~name in
   function
-  | `Xen -> Fpath.[ v name + "xl" ; v name + "xl.in" ; v name + "xe" ; libvirt ]
+  | `Xen -> Fpath.[ v name + "xl" ; v name + "xl.in" ; libvirt ]
   | `Virtio -> [ libvirt ]
   | _ -> []
 
@@ -84,6 +81,7 @@ let configure_opam ~name info =
       append fmt {|authors: "dummy"|};
       append fmt {|homepage: "dummy"|};
       append fmt {|bug-reports: "dummy"|};
+      append fmt {|dev-repo: "git+https://example.com/nonexistent"|};
       Format.fprintf fmt {|build: [ "sh" "-exc" "|};
       (match subdir with
        | None -> ()
@@ -178,13 +176,16 @@ let configure i =
   let no_depext = Key.(get ctx no_depext) in
   configure_makefile ~no_depext ~opam_name >>= fun () ->
   (match target with
-    | #Mirage_key.mode_solo5 -> generate_manifest_json ()
+    | #Mirage_key.mode_solo5 -> generate_manifest_json true ()
+    (* On Xen, a Solo5 manifest must be present to keep the build system and
+     * Solo5 happy, but we intentionally do not generate any devices[] as
+     * their naming does not follow the Solo5 rules. *)
+    | #Mirage_key.mode_xen -> generate_manifest_json false ()
     | _ -> R.ok ()) >>= fun () ->
   match target with
   | `Xen ->
     configure_main_xl ~ext:"xl" i >>= fun () ->
     configure_main_xl ~substitutions:[] ~ext:"xl.in" i >>= fun () ->
-    configure_main_xe ~root ~name >>= fun () ->
     Mirage_configure_libvirt.configure_main ~root ~name
   | `Virtio ->
     Mirage_configure_libvirt.configure_virtio ~root ~name

lib/mirage_configure_solo5.ml

@@ -10,7 +10,7 @@ let solo5_manifest_path = Fpath.v "_build/manifest.json"
 let clean_manifest () =
   Bos.OS.File.delete solo5_manifest_path
 
-let generate_manifest_json () =
+let generate_manifest_json with_devices () =
   Log.info (fun m -> m "generating manifest");
   let networks = List.map (fun n -> (n, `Network))
     !Mirage_impl_network.all_networks in
@@ -20,7 +20,9 @@ let generate_manifest_json () =
     Fmt.strf {json|{ "name": %S, "type": %S }|json}
       name
       (match typ with `Network -> "NET_BASIC" | `Block -> "BLOCK_BASIC") in
-  let devices = List.map to_string (networks @ blocks) in
+  let devices = if with_devices then
+    (List.map to_string (networks @ blocks))
+  else [] in
   let s = String.concat ~sep:", " devices in
   let open Codegen in
   let file = solo5_manifest_path in
@@ -45,22 +47,39 @@ let generate_manifest_c () =
   Log.info (fun m -> m "executing %a" Bos.Cmd.pp cmd);
   Bos.OS.Cmd.run cmd
 
-let solo5_pkg = function
-  | `Virtio -> "solo5-bindings-virtio", ".virtio"
-  | `Muen -> "solo5-bindings-muen", ".muen"
-  | `Hvt -> "solo5-bindings-hvt", ".hvt"
-  | `Genode -> "solo5-bindings-genode", ".genode"
-  | `Spt -> "solo5-bindings-spt", ".spt"
+let bin_extension = function
+  | `Virtio -> ".virtio"
+  | `Muen -> ".muen"
+  | `Hvt -> ".hvt"
+  | `Genode -> ".genode"
+  | `Spt -> ".spt"
+  | `Xen | `Qubes -> ".xen"
   | _ ->
-    invalid_arg "solo5 bindings only defined for solo5 targets"
+    invalid_arg "extension only defined for solo5 targets"
+
+let solo5_bindings_pkg = function
+  | `Virtio -> "solo5-bindings-virtio"
+  | `Muen -> "solo5-bindings-muen"
+  | `Hvt -> "solo5-bindings-hvt"
+  | `Genode -> "solo5-bindings-genode"
+  | `Spt -> "solo5-bindings-spt"
+  | `Xen | `Qubes -> "solo5-bindings-xen"
+  | _ ->
+    invalid_arg "solo5 bindings package only defined for solo5 targets"
+
+let solo5_platform_pkg = function
+  | #Mirage_key.mode_solo5 -> "mirage-solo5"
+  | #Mirage_key.mode_xen -> "mirage-xen"
+  | _ ->
+    invalid_arg "solo5 platform package only defined for solo5 targets"
 
 let cflags pkg = pkg_config pkg ["--cflags"]
 
 let compile_manifest target =
-  let pkg, _post = solo5_pkg target in
+  let bindings = solo5_bindings_pkg target in
   let c = "_build/manifest.c" in
   let obj = "_build/manifest.o" in
-  cflags pkg >>= fun cflags ->
+  cflags bindings >>= fun cflags ->
   let cmd = Bos.Cmd.(v "cc" %% of_list cflags % "-c" % c % "-o" % obj)
   in
   Log.info (fun m -> m "executing %a" Bos.Cmd.pp cmd);

lib/mirage_configure_solo5.mli

@@ -3,8 +3,11 @@ open Rresult
 val solo5_manifest_path : Fpath.t
 val clean_manifest : unit -> (unit, [> R.msg ]) result
 
-val solo5_pkg : [> Mirage_key.mode_solo5 ] -> string * string
+val bin_extension : [> Mirage_key.mode_solo5 | Mirage_key.mode_xen ] -> string
 
-val generate_manifest_json : unit -> (unit, [> R.msg ]) result
+val solo5_bindings_pkg : [> Mirage_key.mode_solo5 | Mirage_key.mode_xen ] -> string
+val solo5_platform_pkg : [> Mirage_key.mode_solo5 | Mirage_key.mode_xen ] -> string
+
+val generate_manifest_json : bool -> unit -> (unit, [> R.msg ]) result
 val generate_manifest_c : unit -> (unit, [> R.msg ]) result
-val compile_manifest : [> Mirage_key.mode_solo5 ] -> (unit, [> R.msg ]) result
+val compile_manifest : [> Mirage_key.mode_solo5 | Mirage_key.mode_xen ] -> (unit, [> R.msg ]) result

lib/mirage_configure_xen.ml

@@ -85,7 +85,7 @@ let configure_main_xl ?substitutions ~ext i =
       newline fmt;
       append fmt "name = '%s'" (lookup substitutions Name);
       append fmt "kernel = '%s'" (lookup substitutions Kernel);
-      append fmt "type = 'pv'";
+      append fmt "type = 'pvh'";
       append fmt "memory = %s" (lookup substitutions Memory);
       append fmt "on_crash = 'preserve'";
       newline fmt;
@@ -125,64 +125,4 @@ let configure_main_xl ?substitutions ~ext i =
 
 let clean_main_xl ~name ~ext = Bos.OS.File.delete Fpath.(v name + ext)
 
-let configure_main_xe ~root ~name =
-  let open Codegen in
-  let file = Fpath.(v name + "xe") in
-  with_output ~mode:0o755 file (fun oc () ->
-      let fmt = Format.formatter_of_out_channel oc in
-      let open Mirage_impl_block in
-      append fmt "#!/bin/sh";
-      append fmt "# %s" (generated_header ());
-      newline fmt;
-      append fmt "set -e";
-      newline fmt;
-      append fmt "# Dependency: xe";
-      append fmt "command -v xe >/dev/null 2>&1 || { echo >&2 \"I require xe but \
-                  it's not installed.  Aborting.\"; exit 1; }";
-      append fmt "# Dependency: xe-unikernel-upload";
-      append fmt "command -v xe-unikernel-upload >/dev/null 2>&1 || { echo >&2 \"I \
-                  require xe-unikernel-upload but it's not installed.  Aborting.\"\
-                  ; exit 1; }";
-      append fmt "# Dependency: a $HOME/.xe";
-      append fmt "if [ ! -e $HOME/.xe ]; then";
-      append fmt "  echo Please create a config file for xe in $HOME/.xe which \
-                  contains:";
-      append fmt "  echo server='<IP or DNS name of the host running xapi>'";
-      append fmt "  echo username=root";
-      append fmt "  echo password=password";
-      append fmt "  exit 1";
-      append fmt "fi";
-      newline fmt;
-      append fmt "echo Uploading VDI containing unikernel";
-      append fmt "VDI=$(xe-unikernel-upload --path %s/%s.xen)" root name;
-      append fmt "echo VDI=$VDI";
-      append fmt "echo Creating VM metadata";
-      append fmt "VM=$(xe vm-create name-label=%s)" name;
-      append fmt "echo VM=$VM";
-      append fmt "xe vm-param-set uuid=$VM PV-bootloader=pygrub";
-      append fmt "echo Adding network interface connected to xenbr0";
-      append fmt "ETH0=$(xe network-list bridge=xenbr0 params=uuid --minimal)";
-      append fmt "VIF=$(xe vif-create vm-uuid=$VM network-uuid=$ETH0 device=0)";
-      append fmt "echo Atting block device and making it bootable";
-      append fmt "VBD=$(xe vbd-create vm-uuid=$VM vdi-uuid=$VDI device=0)";
-      append fmt "xe vbd-param-set uuid=$VBD bootable=true";
-      append fmt "xe vbd-param-set uuid=$VBD other-config:owner=true";
-      List.iter (fun b ->
-          append fmt "echo Uploading data VDI %s" b.filename;
-          append fmt "echo VDI=$VDI";
-          append fmt "SIZE=$(stat --format '%%s' %s/%s)" root b.filename;
-          append fmt "POOL=$(xe pool-list params=uuid --minimal)";
-          append fmt "SR=$(xe pool-list uuid=$POOL params=default-SR --minimal)";
-          append fmt "VDI=$(xe vdi-create type=user name-label='%s' \
-                      virtual-size=$SIZE sr-uuid=$SR)" b.filename;
-          append fmt "xe vdi-import uuid=$VDI filename=%s/%s" root b.filename;
-          append fmt "VBD=$(xe vbd-create vm-uuid=$VM vdi-uuid=$VDI device=%d)"
-            b.number;
-          append fmt "xe vbd-param-set uuid=$VBD other-config:owner=true")
-        (Hashtbl.fold (fun _ v acc -> v :: acc) all_blocks []);
-      append fmt "echo Starting VM";
-      append fmt "xe vm-start uuid=$VM";
-      R.ok ())
-    "xe file"
-
 let clean_main_xe ~name = Bos.OS.File.delete Fpath.(v name + "xe")

lib/mirage_configure_xen.mli

@@ -17,5 +17,4 @@ end
 val configure_main_xl : ?substitutions:Substitutions.t -> ext:string -> Functoria.Info.t -> (unit, [> R.msg ]) result
 val clean_main_xl : name:string -> ext:string -> (unit, [> R.msg ]) result
 
-val configure_main_xe : root:string -> name:string -> (unit, [> R.msg ]) result
 val clean_main_xe : name:string -> (unit, [> R.msg ]) result

lib/mirage_impl_argv.ml

@@ -35,13 +35,8 @@ let argv_xen = impl @@ object
     method name = "argv_xen"
     method module_name = "Bootvar"
     method! packages =
-      Key.pure [ package ~min:"0.7.0" ~max:"0.8.0" "mirage-bootvar-xen" ]
-    method! connect _ _ _ = Fmt.strf
-      (* Some hypervisor configurations try to pass some extra arguments.
-       * They means well, but we can't do much with them,
-       * and they cause Functoria to abort. *)
-      "let filter (key, _) = List.mem key (List.map snd Key_gen.runtime_keys) in@ \
-       Bootvar.argv ~filter ()"
+      Key.pure [ package ~min:"0.8.0" ~max:"0.9.0" "mirage-bootvar-xen" ]
+    method! connect _ _ _ = "Bootvar.argv ()"
   end
 
 let default_argv =

lib/mirage_impl_block.ml

@@ -26,7 +26,7 @@ let make_block_t =
     b
 
 let xen_block_packages =
-  [ package ~min:"1.7.0" ~max:"2.0.0" ~sublibs:["front"] "mirage-block-xen" ]
+  [ package ~min:"2.0.0" ~max:"3.0.0" ~sublibs:["front"] "mirage-block-xen" ]
 
 (* this class takes a string rather than an int as `id` to allow the user to
    pass stuff like "/dev/xvdi1", which mirage-block-xen also understands *)

lib/mirage_impl_console.ml

@@ -12,7 +12,7 @@ let console_unix str = impl @@ object
     method name = name
     method module_name = "Console_unix"
     method! packages =
-      Key.pure [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-console-unix" ]
+      Key.pure [ package ~min:"4.0.0" ~max:"5.0.0" "mirage-console-unix" ]
     method! connect _ modname _args = Fmt.strf "%s.connect %S" modname str
   end
 
@@ -23,7 +23,7 @@ let console_xen str = impl @@ object
     method name = name
     method module_name = "Console_xen"
     method! packages =
-      Key.pure [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-console-xen" ]
+      Key.pure [ package ~min:"4.0.0" ~max:"5.0.0" "mirage-console-xen" ]
     method! connect _ modname _args = Fmt.strf "%s.connect %S" modname str
   end
 

lib/mirage_impl_ip.ml

@@ -32,15 +32,13 @@ let opt_map f = function Some x -> Some (f x) | None -> None
 let (@?) x l = match x with Some s -> s :: l | None -> l
 let (@??) x y = opt_map Key.abstract x @? y
 
-(* convenience function for linking tcpip.unix or .xen for checksums *)
+(* convenience function for linking tcpip.unix for checksums *)
 let right_tcpip_library ?ocamlfind ~sublibs pkg =
   let min = "5.0.0" and max = "6.0.0" in
   Key.match_ Key.(value target) @@ function
   | #Mirage_key.mode_unix ->
     [ package ~min ~max ?ocamlfind ~sublibs:("unix"::sublibs) pkg ]
-  | #Mirage_key.mode_xen ->
-    [ package ~min ~max ?ocamlfind ~sublibs:("xen"::sublibs) pkg ]
-  | #Mirage_key.mode_solo5 ->
+  | #Mirage_key.mode_xen | #Mirage_key.mode_solo5 ->
     [ package ~min ~max ?ocamlfind ~sublibs pkg ]
 
 let ipv4_keyed_conf ~ip ?gateway () = impl @@ object
@@ -123,7 +121,7 @@ let ipv4_qubes_conf = impl @@ object
     method name = Name.create "qubes_ipv4" ~prefix:"qubes_ipv4"
     method module_name = "Qubesdb_ipv4.Make"
     method! packages =
-      Key.pure [ package ~min:"0.8.0" ~max:"0.9.0" "mirage-qubes-ipv4" ]
+      Key.pure [ package ~min:"0.9.0" ~max:"0.10.0" "mirage-qubes-ipv4" ]
     method! connect _ modname = function
       | [  db ; _random ; _mclock ;etif; arp ] ->
         Fmt.strf "%s.connect@[@ %s@ %s@ %s@]" modname db etif arp

lib/mirage_impl_network.ml

@@ -19,9 +19,9 @@ let network_conf (intf : string Key.key) =
       Key.match_ Key.(value target) @@ function
       | `Unix -> [ package ~min:"2.7.0" ~max:"3.0.0" "mirage-net-unix" ]
       | `MacOSX -> [ package ~min:"1.8.0" ~max:"2.0.0" "mirage-net-macosx" ]
-      | `Xen -> [ package ~min:"1.13.0" ~max:"2.0.0" "mirage-net-xen"]
+      | `Xen -> [ package ~min:"2.0.0" ~max:"3.0.0" "mirage-net-xen"]
       | `Qubes ->
-        [ package ~min:"1.13.0" ~max:"2.0.0" "mirage-net-xen" ;
+        [ package ~min:"2.0.0" ~max:"3.0.0" "mirage-net-xen" ;
           Mirage_impl_qubesdb.pkg ]
       | #Mirage_key.mode_solo5 ->
         [ package ~min:"0.6.1" ~max:"0.7.0" "mirage-net-solo5" ]

lib/mirage_impl_qubesdb.ml

@@ -6,7 +6,7 @@ open Rresult
 type qubesdb = QUBES_DB
 let qubesdb = Type QUBES_DB
 
-let pkg = package ~min:"0.8.0" ~max:"0.9.0" "mirage-qubes"
+let pkg = package ~min:"0.9.0" ~max:"0.10.0" "mirage-qubes"
 
 let qubesdb_conf = object
   inherit base_configurable

lib/mirage_link.ml

@@ -33,47 +33,17 @@ let link info name target _target_debug =
     let link = Bos.Cmd.(v "ln" % "-nfs" % "_build/main.native" % name) in
     Bos.OS.Cmd.run link >>= fun () ->
     Ok name
-  | #Mirage_key.mode_xen ->
-    extra_c_artifacts "xen" libs >>= fun c_artifacts ->
-    static_libs "mirage-xen" >>= fun static_libs ->
-    let linker =
-      Bos.Cmd.(v "ld" % "-d" % "-static" % "-nostdlib" %
-               "_build/main.native.o" %%
-               of_list c_artifacts %%
-               of_list static_libs)
-    in
-    let out = name ^ ".xen" in
-    let uname_cmd = Bos.Cmd.(v "uname" % "-m") in
-    Bos.OS.Cmd.(run_out uname_cmd |> out_string |> success) >>= fun machine ->
-    if String.is_prefix ~affix:"arm" machine then begin
-      (* On ARM:
-         - we must convert the ELF image to an ARM boot executable zImage,
-           while on x86 we leave it as it is.
-         - we need to link libgcc.a (otherwise we get undefined references to:
-           __aeabi_dcmpge, __aeabi_dadd, ...) *)
-      let libgcc_cmd = Bos.Cmd.(v "gcc" % "-print-libgcc-file-name") in
-      Bos.OS.Cmd.(run_out libgcc_cmd |> out_string |> success) >>= fun libgcc ->
-      let elf = name ^ ".elf" in
-      let link = Bos.Cmd.(linker % libgcc % "-o" % elf) in
-      Log.info (fun m -> m "linking with %a" Bos.Cmd.pp link);
-      Bos.OS.Cmd.run link >>= fun () ->
-      let objcopy_cmd = Bos.Cmd.(v "objcopy" % "-O" % "binary" % elf % out) in
-      Bos.OS.Cmd.run objcopy_cmd  >>= fun () ->
-      Ok out
-    end else begin
-      let link = Bos.Cmd.(linker % "-o" % out) in
-      Log.info (fun m -> m "linking with %a" Bos.Cmd.pp link);
-      Bos.OS.Cmd.run link >>= fun () ->
-      Ok out
-    end
-  | #Mirage_key.mode_solo5 ->
-    let pkg, post = Mirage_configure_solo5.solo5_pkg target in
+  | #Mirage_key.mode_solo5 | #Mirage_key.mode_xen ->
+    let bindings = Mirage_configure_solo5.solo5_bindings_pkg target in
+    let platform = Mirage_configure_solo5.solo5_platform_pkg target in
     extra_c_artifacts "freestanding" libs >>= fun c_artifacts ->
-    static_libs "mirage-solo5" >>= fun static_libs ->
-    ldflags pkg >>= fun ldflags ->
-    ldpostflags pkg >>= fun ldpostflags ->
-    let out = name ^ post in
-    let ld = find_ld pkg in
+    static_libs platform
+    >>= fun static_libs ->
+    ldflags bindings >>= fun ldflags ->
+    ldpostflags bindings >>= fun ldpostflags ->
+    let extension = Mirage_configure_solo5.bin_extension target in
+    let out = name ^ extension in
+    let ld = find_ld bindings in
     let linker =
       Bos.Cmd.(v ld %% of_list ldflags % "_build/main.native.o" %
                "_build/manifest.o" %%