Add s3suspend command

diff --git a/xenvm/tasks.ml b/xenvm/tasks.ml
index 1373404a17b741bcbb00a4e9b5333d502e2e86e4..5a7fab517f18023bedacf57898776b4be899f77b 100644 (file)
--- a/xenvm/tasks.ml
+++ b/xenvm/tasks.ml
@@ -24,6 +24,7 @@ type action =
        | Unpause
        | Suspend
        | Restore
+       | S3Suspend    
        | Checkpoint
        | GetDomid
        | GetStatus
@@ -89,6 +90,7 @@ let actions_table = [
        (Suspend,    mk_desc_args "suspend" [ ("live", D (ValBool false), ArgBool);
                                              ("file", R, ArgString); ] );
        (Restore,    mk_desc_args "restore" [ "file", R, ArgString ] );
+       (S3Suspend,  mk_desc_args "s3suspend" [ "timeout", O, ArgInt ]);
        (GetDomid,   mk_desc_nb "get-domid");
        (GetStatus,  mk_desc_nb "get-status");
        (GetVNC,     mk_desc_nb "get-vnc");

diff --git a/xenvm/vmact.ml b/xenvm/vmact.ml
index 5c9acc55d8f1bc29ddc830564014816ddcd1dfb9..caa66f102ef6a312990e66c17e10e07ea64bab5a 100644 (file)
--- a/xenvm/vmact.ml
+++ b/xenvm/vmact.ml
@@ -575,6 +575,27 @@ let restore xc xs state delete file =
        | _ ->
                assert false
 
+let s3_suspend xc xs state timeout =
+       let domid = string_of_int state.vm_domid in
+       let path = "/local/domain/" ^ domid ^ "/control/shutdown" in
+       xs.Xs.write path "s3";
+       (* wait until domain gets into s3 by polling acpi state *)
+       let start_time = Unix.time () in
+       let rec wait () =
+               Unix.sleep 1;
+               let t = Unix.time () in
+               let diff = int_of_float (t -. start_time) in
+               if diff >= timeout
+               then false (* timed out, failed to put domain to sleep *)
+               else match Xc.domain_get_acpi_s_state xc state.vm_domid with
+                    | 3 -> true    (* acpi state is S3 *)
+                    | _ -> wait () (* acpi state is something else, continue wait *)
+       in
+       info "waiting for domain %s to go into s3" domid;
+       match wait () with
+       | true  -> info "succeeded to put domain %s into s3" domid; true
+       | false -> warn "failed to put domain %s into s3" domid; false
+  
 let device_cmd xc xs state ty subcmd args =
        let cfg = state.vm_cfg in
        (* specific handler *)

diff --git a/xenvm/xenvm.ml b/xenvm/xenvm.ml
index 58c69c4e39077ebc7468d1ed729abbdd1fb07d66..715f1a7c343eb2c47b5c749076dd70b5cf938d83 100644 (file)
--- a/xenvm/xenvm.ml
+++ b/xenvm/xenvm.ml
@@ -443,6 +443,12 @@ let do_task state (task, args) =
                Vmact.change_vmstate state VmRestoring;
                with_xcs (fun xc xs -> Vmact.restore xc xs state delete (with_datadir state.vm_cfg file));
                Xenvmlib.Ok
+       | Tasks.S3Suspend ->
+               let timeout = optional_arg (Int64.of_int 30) Tasks.args_get_int args "timeout" in
+               let timeout = Int64.to_int timeout in
+               (match with_xcs (fun xc xs -> Vmact.s3_suspend xc xs state timeout) with
+               | true  -> Xenvmlib.Ok
+               | false -> Xenvmlib.Error "failed to put domain into s3")
        | Tasks.Checkpoint ->
                let file = Tasks.args_get_string args "file" in
                state.vm_on_suspend_action <- ActionResume;

diff --git a/xenvm/xenvm_cmd.ml b/xenvm/xenvm_cmd.ml
index e097e10b8cb1e7b4bd94081d78ae3b54487eca61..6b4a078a941846e85ab3a04bd65a9ff4911d4f11 100644 (file)
--- a/xenvm/xenvm_cmd.ml
+++ b/xenvm/xenvm_cmd.ml
@@ -26,10 +26,12 @@ let valid_kvpairs args =
 
 let _ =
        let using_socket = ref false in
-       let usage_msg = sprintf "usage: %s [--use-socket] <uuid> <cmd> [cmd args]\n" Sys.argv.(0) in
+       let timeout = ref 60 in
+       let usage_msg = sprintf "usage: %s [--use-socket] [--reply-timeout <secs>] <uuid> <cmd> [cmd args]\n" Sys.argv.(0) in
        let args = ref [] in
        Arg.parse [
                ("--use-socket", Arg.Set using_socket, "use socket instead of dbus");
+               ("--reply-timeout", Arg.Int (fun t -> timeout := t), "set the timeout (in seconds), defaults to 60");
        ] (fun s -> args := s :: !args) usage_msg;
        let args = List.rev !args in
 
@@ -42,7 +44,7 @@ let _ =
                in
 
        try
-               match Xenvmlib.request ~using_socket ~timeout:60.0 uuid query with
+               match Xenvmlib.request ~using_socket ~timeout:(float_of_int !timeout) uuid query with
                | Xenvmlib.Ok          -> ()
                | Xenvmlib.Timeout     -> eprintf "timeout\n"; exit 1
                | Xenvmlib.Error error -> eprintf "error: %s\n" error; exit 1