Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

ocaml: update following Task changes

Signed-off-by: David Scott <dave.scott@eu.citrix.com>
  • Loading branch information...
commit 4ad3657d2f291bd6d29e82c6b9db7da8ee24eeb1 1 parent 6277288
Dave Scott authored
16 dbus/vm/ocaml/build.sh
View
@@ -7,8 +7,11 @@ set -x
obus-gen-interface -o vm ../org.xenserver.Vm.xml
obus-gen-interface -o resource ../org.xenserver.Resource.xml
obus-gen-interface -o controller ../org.xenserver.Controller.xml
+obus-gen-interface -o task_interfaces ../org.xenserver.Task.xml
+obus-gen-client -o task ../org.xenserver.Task.xml
+obus-gen-interface -o taskOwner ../org.xenserver.TaskOwner.xml
-PACKS=obus,lwt.syntax
+PACKS=obus,lwt.syntax,uri,re.str
ocamlfind ocamlc -syntax camlp4o -package $PACKS -c vm.mli
ocamlfind ocamlc -syntax camlp4o -package $PACKS -c vm.ml
@@ -19,7 +22,16 @@ ocamlfind ocamlc -syntax camlp4o -package $PACKS -c resource.ml
ocamlfind ocamlc -syntax camlp4o -package $PACKS -c controller.mli
ocamlfind ocamlc -syntax camlp4o -package $PACKS -c controller.ml
+ocamlfind ocamlc -syntax camlp4o -package $PACKS -c task_interfaces.mli
+ocamlfind ocamlc -syntax camlp4o -package $PACKS -c task_interfaces.ml
+
+ocamlfind ocamlc -syntax camlp4o -package $PACKS -c task.mli
+ocamlfind ocamlc -syntax camlp4o -package $PACKS -c task.ml
+
+ocamlfind ocamlc -syntax camlp4o -package $PACKS -c taskOwner.mli
+ocamlfind ocamlc -syntax camlp4o -package $PACKS -c taskOwner.ml
+
ocamlfind ocamlc -syntax camlp4o -package $PACKS -c simulator.ml
-ocamlfind ocamlc -syntax camlp4o -package $PACKS -o simulator -linkpkg vm.cmo resource.cmo controller.cmo simulator.cmo
+ocamlfind ocamlc -syntax camlp4o -package $PACKS -o simulator -linkpkg vm.cmo resource.cmo controller.cmo task_interfaces.cmo task.cmo taskOwner.cmo simulator.cmo
2  dbus/vm/ocaml/clean.sh
View
@@ -1,2 +1,2 @@
-rm -f simulator *.cmo *.cmi vm.ml* vm_interfaces.ml* vm_server.ml*
+rm -f simulator *.cmo *.cmi controller* resource* vm.ml* task* vm_interfaces.ml* vm_server.ml*
150 dbus/vm/ocaml/simulator.ml
View
@@ -1,8 +1,8 @@
open Lwt
open Lwt_io
-let volumes_per_vm = 6
-let networks_per_vm = 6
+let volumes_per_vm = 1
+let networks_per_vm = 1
let debug_logging = ref false
@@ -19,14 +19,53 @@ let log fmt =
then Printf.fprintf Pervasives.stderr "%s\n%!" s
) fmt
+let vm_bus_name = "org.xenserver.vm1"
+let volume_bus_name = "org.xenserver.volume.example"
+let network_bus_name = "org.xenserver.network1"
+let controller_bus_name = "org.xenserver.controller1"
+
+let vm_path = [ "org"; "xenserver"; "vm1" ]
+let volume_path = [ "org"; "xenserver"; "volume"; "example" ]
+let network_path = [ "org"; "xenserver"; "network1" ]
+let controller_path = [ "org"; "xenserver"; "controller1" ]
+let owner_path = [ "org"; "xenserver"; "owner1" ]
+
+let slash = Re_str.regexp_string "/"
+
+let parse_uri uri =
+ let x = Uri.of_string uri in
+ match Uri.scheme x, Uri.path x with
+ | Some bus_name, path ->
+ let elements = List.tl (Re_str.split_delim slash path) in
+ bus_name, elements
+ | _, _ -> failwith (Printf.sprintf "Failed to parse object URI: %s" uri)
+
+let owner_uri () =
+ lwt bus = OBus_bus.session () in
+ match OBus_connection.name bus with
+ | "" -> failwith "Failed to query our unique connection name"
+ | name ->
+ (* remove the initial : *)
+ let scheme =
+ if name.[0] = ':'
+ then String.sub name 1 (String.length name - 1)
+ else name in
+ let path = String.concat "/" ([""] @ owner_path) in
+ let uri = Uri.make ~scheme ~path () in
+ return (Uri.to_string uri)
+
+let owner_ping uris =
+ log "ping %d uris" (List.length uris);
+ return (List.map (fun x -> true) uris)
+
let controller_start_multiple how_many =
log "controller_start_multiple %ld" how_many;
lwt bus = OBus_bus.session () in
- let vm = OBus_proxy.make (OBus_peer.make bus "org.xenserver.vm") ["org"; "xenserver"; "vm"] in
+ let vm = OBus_proxy.make (OBus_peer.make bus vm_bus_name) vm_path in
let start = Unix.gettimeofday () in
lwt () = repeat
(fun i ->
- OBus_method.call Vm.Org_xenserver_api_vm.m_start vm (string_of_int i)
+ OBus_method.call Vm.Org_xenserver_Vm1.m_start vm (string_of_int i)
) (Int32.to_int how_many) in
let time = Unix.gettimeofday () -. start in
return (string_of_float time)
@@ -34,22 +73,41 @@ let controller_start_multiple how_many =
let controller_stop_multiple which =
return "unknown"
+let wait_for_task bus task =
+ let bus_name, path = parse_uri task in
+ log "task is at %s (bus name = %s; path = [ %s ])" task bus_name (String.concat "; " path);
+ let task_proxy = OBus_proxy.make (OBus_peer.make bus bus_name) path in
+ let completed = Task.Org_xenserver_Task1.completed task_proxy in
+ lwt event = OBus_signal.connect completed in
+ let wait_for_signal = Lwt_react.E.next event in
+ lwt result =
+ try_lwt
+ Task.Org_xenserver_Task1.get_result task_proxy
+ with _ ->
+ lwt () = wait_for_signal in
+ Task.Org_xenserver_Task1.get_result task_proxy in
+ lwt () = Task.Org_xenserver_Task1.destroy task_proxy in
+ return result
+
let vm_start config =
log "vm_start %s" config;
(* Create a proxy for the remote object *)
lwt bus = OBus_bus.session () in
- let volume = OBus_proxy.make (OBus_peer.make bus "org.xenserver.volume.example") ["org"; "xenserver"; "volume"; "example"] in
- let network = OBus_proxy.make (OBus_peer.make bus "org.xenserver.network") ["org"; "xenserver"; "network"] in
+ let volume = OBus_proxy.make (OBus_peer.make bus volume_bus_name) volume_path in
+ let network = OBus_proxy.make (OBus_peer.make bus network_bus_name) network_path in
+ lwt owner = owner_uri () in
lwt () = repeat
(fun _ ->
- lwt (local_uri, id) = OBus_method.call Resource.Org_xenserver_api_resource.m_attach volume "iscsi://target/lun" in
- log " got local_uri %s id %s" local_uri id;
+ lwt task = OBus_method.call Resource.Org_xenserver_Resource1.m_attach volume ("iscsi://target/lun", owner, "token") in
+ lwt result = wait_for_task bus task in
+ log "result = %s" (String.escaped result);
return ()
) volumes_per_vm in
lwt () = repeat
(fun _ ->
- lwt (local_uri, id) = OBus_method.call Resource.Org_xenserver_api_resource.m_attach network "sdn://magic/" in
- log " got local_uri %s id %s" local_uri id;
+ lwt task = OBus_method.call Resource.Org_xenserver_Resource1.m_attach network ("sdn://magic/", owner, "token") in
+ lwt result = wait_for_task bus task in
+ log "result = %s" (String.escaped result);
return ()
) networks_per_vm in
return ()
@@ -60,56 +118,30 @@ let vm_stop id =
let vm_interface =
- Vm.Org_xenserver_api_vm.(make {
+ Vm.Org_xenserver_Vm1.(make {
m_start = (fun obj config -> vm_start config);
m_stop = (fun obj id -> vm_stop id);
})
-let volume_attach global_uri =
- log "volume_attach %s" global_uri;
- return ("file://block/device", "some id")
-
-let volume_detach id =
- log "volume_detach %s" id;
- return ()
-
-let volume_interface =
- Resource.Org_xenserver_api_resource.(make {
- m_attach = (fun obj global_uri -> volume_attach global_uri);
- m_detach = (fun obj id -> volume_detach id);
- })
-
-let network_attach global_uri =
- log "network_attach %s" global_uri;
- return ("vlan://eth0/100", "some id")
-
-let network_detach id =
- log "network_detach %s" id;
- return ()
-
-let network_interface =
- Resource.Org_xenserver_api_resource.(make {
- m_attach = (fun obj global_uri -> network_attach global_uri);
- m_detach = (fun obj id -> network_detach id);
- })
-
let controller_interface =
- Controller.Org_xenserver_api_controller.(make {
+ Controller.Org_xenserver_Controller1.(make {
m_start_multiple = (fun obj which -> controller_start_multiple which);
m_stop_multiple = (fun obj which -> controller_stop_multiple which);
})
-lwt () =
+let taskOwner_interface =
+ TaskOwner.Org_xenserver_TaskOwner1.(make {
+ m_ping = (fun obj uris -> owner_ping uris);
+ p_tasks = (fun obj -> Lwt_react.S.return []);
+ })
+
+ lwt () =
let implement_vm = ref false in
- let implement_volume = ref false in
- let implement_network = ref false in
let implement_control = ref false in
let implement_all = ref false in
Arg.parse [
"-debug", Arg.Set debug_logging, "Print debug logging";
"-vm", Arg.Set implement_vm, "Implement VM";
- "-volume",Arg.Set implement_volume, "Implement Volume";
- "-network", Arg.Set implement_network, "Implement Network";
"-control", Arg.Set implement_control, "Implement Control";
"-all", Arg.Set implement_all, "Implement everything";
] (fun x -> Printf.fprintf Pervasives.stderr "Ignoring argument: %s\n" x)
@@ -118,36 +150,24 @@ lwt () =
lwt bus = OBus_bus.session () in
lwt () = if !implement_vm || !implement_all then begin
- lwt _ = OBus_bus.request_name bus "org.xenserver.vm" in
- let obj = OBus_object.make ~interfaces:[vm_interface] ["org"; "xenserver"; "vm"] in
- OBus_object.attach obj ();
- OBus_object.export bus obj;
- return ()
- end else return () in
-
- lwt () = if !implement_volume || !implement_all then begin
- lwt _ = OBus_bus.request_name bus "org.xenserver.volume" in
- let obj = OBus_object.make ~interfaces:[volume_interface] ["org"; "xenserver"; "volume"] in
- OBus_object.attach obj ();
- OBus_object.export bus obj;
- return ()
- end else return () in
-
- lwt () = if !implement_network || !implement_all then begin
- lwt _ = OBus_bus.request_name bus "org.xenserver.network" in
- let obj = OBus_object.make ~interfaces:[network_interface] ["org"; "xenserver"; "network"] in
+ lwt _ = OBus_bus.request_name bus vm_bus_name in
+ let obj = OBus_object.make ~interfaces:[vm_interface] vm_path in
OBus_object.attach obj ();
OBus_object.export bus obj;
return ()
end else return () in
lwt () = if !implement_control || !implement_all then begin
- lwt _ = OBus_bus.request_name bus "org.xenserver.controller" in
- let obj = OBus_object.make ~interfaces:[controller_interface] ["org"; "xenserver"; "controller"] in
+ lwt _ = OBus_bus.request_name bus controller_bus_name in
+ let obj = OBus_object.make ~interfaces:[controller_interface] controller_path in
OBus_object.attach obj ();
OBus_object.export bus obj;
return ()
end else return () in
+ let obj = OBus_object.make ~interfaces:[taskOwner_interface] owner_path in
+ OBus_object.attach obj ();
+ OBus_object.export bus obj;
+
(* Wait forever *)
fst (wait ())
Please sign in to comment.
Something went wrong with that request. Please try again.