v2v: test-harness: Allow test boot at fixed dates in the past.

Turns out that some of the Windows guests in the test suite try to
reactivate if the date is more than some time delta (maybe 1 year?)
after the previous activation.  Just disabling the network wasn't
enough to prevent this.

qemu allows us to boot guests with the clock set to a particular date
in the past, and libvirt exposes this (albeit very clumsily):

https://docs.fedoraproject.org/en-US/Fedora/18/html/Virtualization_Administration_Guide/sect-Virtualization-Tips_and_tricks-Libvirt_Managed_Timers.html

Allow guests to be booted with the date set to a particular past date,
by setting the test_plan.guest_clock field.

This required adding some more libxml2 bindings.

v2v/test-harness/v2v_test_harness.ml

@@ -26,6 +26,7 @@ open Printf
 open Common_utils
 
 type test_plan = {
+  guest_clock : float option;
   post_conversion_test : (Guestfs.guestfs -> string -> Xml.doc -> unit) option;
   boot_plan : boot_plan;
 
@@ -42,7 +43,15 @@ and boot_plan =
 | Boot_to_idle
 | Boot_to_screenshot of string
 
+let new_year's_day year =
+  let tm = { tm_sec = 0; tm_min = 0; tm_hour = 0;
+             tm_mday = 1; tm_mon = 0; tm_year = year - 1900;
+             tm_wday = 0; tm_yday = 0; tm_isdst = false } in
+  let t, _ = mktime tm in
+  Some t
+
 let default_plan = {
+  guest_clock = None;
   post_conversion_test = None;
   boot_plan = Boot_to_idle;
   boot_wait_to_write = 120;
@@ -119,6 +128,32 @@ let run ~test ?input_disk ?input_xml ?(test_plan = default_plan) () =
           Xml.node_set_content node "2097152"
     ) nodes;
 
+    (* Adjust the <clock/> if requested. *)
+    (match test_plan.guest_clock with
+     | None -> ()
+     | Some t ->
+        let adjustment = t -. time () in
+        assert (adjustment <= 0.);
+        let adjustment = int_of_float adjustment in
+        let xpath = Xml.xpath_eval_expression xpathctx "/domain/clock" in
+        let nodes = nodes_of_xpathobj boot_xml_doc xpath in
+        let clock_node =
+          match nodes with
+          | [] ->
+             (* No <clock> element, so insert one. *)
+             let root (* the <domain> element *) =
+               match Xml.doc_get_root_element boot_xml_doc with
+               | None -> assert false
+               | Some root -> root in
+             Xml.new_text_child root "clock" ""
+          | [clock_node] -> clock_node
+          | _ ->
+             failwith "multiple <clock> elements found" in
+        Xml.set_prop clock_node "offset" "variable";
+        Xml.set_prop clock_node "basis" "localtime";
+        Xml.set_prop clock_node "adjustment" (string_of_int adjustment)
+    );
+
     (* Remove all devices except for a whitelist. *)
     let xpath = Xml.xpath_eval_expression xpathctx "/domain/devices/*" in
     let nodes = nodes_of_xpathobj boot_xml_doc xpath in

v2v/test-harness/v2v_test_harness.mli

@@ -23,6 +23,10 @@
 *)
 
 type test_plan = {
+  guest_clock : float option;
+  (** If not [None], set the guest clock to the specific time.
+      See below for a list of convenient times. *)
+
   post_conversion_test : (Guestfs.guestfs -> string -> Xml.doc -> unit) option;
   (** Arbitrary test that can be run after conversion. *)
 
@@ -58,6 +62,10 @@ and boot_plan =
 | Boot_to_idle                 (** Boot until VM is idle. *)
 | Boot_to_screenshot of string (** Boot until screenshot (subimage) is displayed. *)
 
+val new_year's_day : int -> float option
+(** Set [test_plan.guest_clock = new_year's_day YYYY] to boot the guest with
+    its clock set to midnight on YYYY-01-01. *)
+
 val default_plan : test_plan
 
 val run : test:string -> ?input_disk:string -> ?input_xml:string -> ?test_plan:test_plan -> unit -> unit

v2v/xml-c.c

@@ -320,6 +320,25 @@ v2v_xml_node_ptr_set_content (value nodev, value contentv)
   CAMLreturn (Val_unit);
 }
 
+value
+v2v_xml_node_ptr_new_text_child (value nodev, value namev, value contentv)
+{
+  CAMLparam3 (nodev, namev, contentv);
+  xmlNodePtr node = (xmlNodePtr) nodev;
+  xmlNodePtr new_node;
+
+  new_node = xmlNewTextChild (node, NULL,
+                              BAD_CAST String_val (namev),
+                              BAD_CAST String_val (contentv));
+  if (new_node == NULL)
+    caml_invalid_argument ("node_ptr_new_text_child: failed to create new node");
+
+  /* See comment in v2v_xml_xpathobj_ptr_get_node_ptr about returning
+   * named xmlNodePtr here.
+   */
+  CAMLreturn ((value) new_node);
+}
+
 value
 v2v_xml_node_ptr_set_prop (value nodev, value namev, value valv)
 {
@@ -345,6 +364,24 @@ v2v_xml_node_ptr_unlink_node (value nodev)
   CAMLreturn (Val_unit);
 }
 
+value
+v2v_xml_doc_get_root_element (value docv)
+{
+  CAMLparam1 (docv);
+  CAMLlocal1 (v);
+  xmlDocPtr doc = Doc_val (docv);
+  xmlNodePtr root;
+
+  root = xmlDocGetRootElement (doc);
+  if (root == NULL)
+    CAMLreturn (Val_int (0));   /* None */
+  else {
+    v = caml_alloc (1, 0);
+    Store_field (v, 0, (value) root);
+    CAMLreturn (v);             /* Some node_ptr */
+  }
+}
+
 value
 v2v_xml_parse_uri (value strv)
 {

v2v/xml.ml

@@ -88,12 +88,22 @@ let node_as_string (doc_ptr, node_ptr) = node_ptr_as_string doc_ptr node_ptr
 external node_ptr_set_content : node_ptr -> string -> unit = "v2v_xml_node_ptr_set_content"
 let node_set_content (doc_ptr, node_ptr) = node_ptr_set_content node_ptr
 
+external node_ptr_new_text_child : node_ptr -> string -> string -> node_ptr = "v2v_xml_node_ptr_new_text_child"
+let new_text_child (doc_ptr, node_ptr) name content =
+  doc_ptr, node_ptr_new_text_child node_ptr name content
+
 external node_ptr_set_prop : node_ptr -> string -> string -> unit = "v2v_xml_node_ptr_set_prop"
 let set_prop (doc_ptr, node_ptr) = node_ptr_set_prop node_ptr
 
 external node_ptr_unlink_node : node_ptr -> unit = "v2v_xml_node_ptr_unlink_node"
 let unlink_node (doc_ptr, node_ptr) = node_ptr_unlink_node node_ptr
 
+external _doc_get_root_element : doc_ptr -> node_ptr option = "v2v_xml_doc_get_root_element"
+let doc_get_root_element doc_ptr =
+  match _doc_get_root_element doc_ptr with
+  | None -> None
+  | Some node_ptr -> Some (doc_ptr, node_ptr)
+
 type uri = {
   uri_scheme : string option;
   uri_opaque : string option;

v2v/xml.mli

@@ -67,6 +67,9 @@ val node_as_string : node -> string
 val node_set_content : node -> string -> unit
 (** xmlNodeSetContent *)
 
+val new_text_child : node -> string -> string -> node
+(** xmlNewTextChild *)
+
 val set_prop : node -> string -> string -> unit
 (** xmlSetProp *)
 
@@ -74,6 +77,9 @@ val unlink_node : node -> unit
 (** xmlUnlinkNode
     {b NB:} This frees the [node], do not use it afterwards. *)
 
+val doc_get_root_element : doc -> node option
+(** xmlDocGetRootElement *)
+
 type uri = {
   uri_scheme : string option;
   uri_opaque : string option;