CA-387885 and templatization of the C SDK #5555
Merged
Conversation
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Signed-off-by: Konstantina Chremmou <Konstantina.Chremmou@cloud.com>
…ernal headers from the public ones). Signed-off-by: Konstantina Chremmou <Konstantina.Chremmou@cloud.com>
Signed-off-by: Konstantina Chremmou <Konstantina.Chremmou@cloud.com>
kc284
force-pushed
the
private/konstantin1/sdk-c
branch
from
a87c49a
to
e0d8c48
Compare
kc284
force-pushed
the
private/konstantin1/sdk-c
branch
from
e0d8c48
to
f6384ed
Compare
kc284
dismissed
danilo-delbusso’s stale review
The last commit has been modified and needs re-review.
Signed-off-by: Konstantina Chremmou <Konstantina.Chremmou@cloud.com>
kc284
force-pushed
the
private/konstantin1/sdk-c
branch
from
f6384ed
to
6681b7d
Compare
CitrixChris
approved these changes
Apr 19, 2024
|
I have diffed the results. There are some changes like indentation, brackets and comments, the major difference though comes from the fix of CA-387885, namely:
As shown by the github action, the SDK compiles ok. I have also compiled on a local machine the samples (the pipeline to "officially" test this is still in progress). It would be nice if a C guru could double check the auto-generated output in case they see any problems with the header rearrangement that I couldn't see. Unless I missed anything in the 600 files I trawled through, the rest of the changes should be inconsequential. |
|
The artifact from the github job is here https://github.com/xapi-project/xen-api/actions/runs/8739177224/artifacts/1426502553 |
pytype_reporter extracted 50 problem reports from pytype outputpytype_reporter: Only "Revert" commits on this PR.Checking the revert diff: gh pr checkout https://github.com/xapi-project/xen-api/pull/<PR-number>
REF=$(git rev-list -n 1 --before='4 weeks ago' HEAD)
git diff $REF diff: diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs
index 4c2762b52..d8259ca9c 100644
--- a/.git-blame-ignore-revs
+++ b/.git-blame-ignore-revs
@@ -29,6 +29,7 @@ b020cf35a1f2c274f95a4118d4596043cba6113f
ff39018fd6d91985f9c893a56928771dfe9fa48d
cbb9edb17dfd122c591beb14d1275acc39492335
d6ab15362548b8fe270bd14d5153b8d94e1b15c0
+b12cf444edea15da6274975e1b2ca6a7fce2a090
# ocp-indent
d018d26d6acd4707a23288b327b49e44f732725e
diff --git a/.github/workflows/generate-and-build-sdks.yml b/.github/workflows/generate-and-build-sdks.yml
index 80b32b5c8..db2843806 100644
--- a/.github/workflows/generate-and-build-sdks.yml
+++ b/.github/workflows/generate-and-build-sdks.yml
@@ -24,6 +24,12 @@ jobs:
shell: bash
run: opam exec -- make sdk
+ - name: Store C SDK source
+ uses: actions/upload-artifact@v4
+ with:
+ name: SDK_Source_C
+ path: _build/install/default/xapi/sdk/c/*
+
- name: Store C# SDK source
uses: actions/upload-artifact@v4
with:
@@ -39,6 +45,30 @@ jobs:
- name: Cleanup XenAPI environment
uses: ./.github/workflows/cleanup-xapi-environment
+ build-c-sdk:
+ name: Build C SDK
+ runs-on: ubuntu-latest
+ needs: generate-sdk-sources
+ steps:
+ - name: Install dependencies
+ run: sudo apt-get install libxml2-dev
+
+ - name: Retrieve C SDK source
+ uses: actions/download-artifact@v4
+ with:
+ name: SDK_Source_C
+ path: source/
+
+ - name: Build C SDK
+ shell: bash
+ run: make -C source
+
+ - name: Store C SDK
+ uses: actions/upload-artifact@v4
+ with:
+ name: SDK_Artifacts_C
+ path: source/*
+
build-csharp-sdk:
name: Build C# SDK
runs-on: windows-2022
diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml
index 87d5cc872..c4d133d2f 100644
--- a/.github/workflows/release.yml
+++ b/.github/workflows/release.yml
@@ -52,6 +52,12 @@ jobs:
name: XenAPI
path: dist/
+ - name: Retrieve C SDK distribution binaries
+ uses: actions/download-artifact@v4
+ with:
+ name: SDK_Artifacts_C
+ path: libxenserver/usr/local/
+
- name: Retrieve C# SDK distribution artifacts
uses: actions/download-artifact@v4
with:
@@ -70,6 +76,15 @@ jobs:
name: SDK_Binaries_XenServerPowerShell_NET6
path: sdk_powershell_7x/
+ - name: Package C SDK artifacts for deployment
+ shell: bash
+ run: |
+ mkdir -p libxenserver/usr/local/lib
+ mv libxenserver/usr/local/libxenserver.* libxenserver/usr/local/lib/
+ tar -zcvf libxenserver-prerelease.tar.gz -C ./libxenserver usr/local/lib/ usr/local/include/xen/api
+ rm -rf libxenserver/usr/local/lib/
+ tar -zcvf libxenserver-prerelease.src.tar.gz -C ./libxenserver/usr/local .
+
- name: Zip PowerShell 5.x SDK artifacts for deployment
shell: bash
run: zip PowerShell-SDK-5.x-prerelease-unsigned.zip ./sdk_powershell_5x -r
@@ -83,7 +98,8 @@ jobs:
run: |
gh release create ${{ github.ref_name }} --repo ${{ github.repository }} --generate-notes dist/* \
PowerShell-SDK-5.x-prerelease-unsigned.zip \
- PowerShell-SDK-7.x-prerelease-unsigned.zip
+ PowerShell-SDK-7.x-prerelease-unsigned.zip \
+ libxenserver-prerelease.tar.gz libxenserver-prerelease.src.tar.gz
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
diff --git a/Makefile b/Makefile
index 991ce87c8..43ebc394d 100644
--- a/Makefile
+++ b/Makefile
@@ -117,6 +117,11 @@ sdk:
sh ocaml/sdk-gen/windows-line-endings.sh $(XAPISDK)/csharp
sh ocaml/sdk-gen/windows-line-endings.sh $(XAPISDK)/powershell
+.PHONY: sdk-build-c
+
+sdk-build-c: sdk
+ cd _build/install/default/xapi/sdk/c && make clean && make -j $(JOBS)
+
.PHONY: sdk-build-java
sdk-build-java: sdk
diff --git a/message-switch-core.opam b/message-switch-core.opam
index 960934bea..44e2983cc 100644
--- a/message-switch-core.opam
+++ b/message-switch-core.opam
@@ -22,6 +22,7 @@ depends: [
"ppx_sexp_conv"
"rpclib"
"sexplib"
+ "xapi-log"
]
synopsis: "A simple store-and-forward message switch"
description: """
diff --git a/message-switch-core.opam.template b/message-switch-core.opam.template
index 7ec11e91d..7f65fa075 100644
--- a/message-switch-core.opam.template
+++ b/message-switch-core.opam.template
@@ -20,6 +20,7 @@ depends: [
"ppx_sexp_conv"
"rpclib"
"sexplib"
+ "xapi-log"
]
synopsis: "A simple store-and-forward message switch"
description: """
diff --git a/ocaml/forkexecd/lib/fe.ml b/ocaml/forkexecd/lib/fe.ml
index 1a176a62b..c928cd3fc 100644
--- a/ocaml/forkexecd/lib/fe.ml
+++ b/ocaml/forkexecd/lib/fe.ml
@@ -1,13 +1,13 @@
(* Disable "Warning 39: unused rec flag." caused by rpc *)
[@@@warning "-39"]
-type syslog_stdout_t = {enabled: bool; key: string option} [@@deriving rpc]
+type syslog_stdout = {enabled: bool; key: string option} [@@deriving rpc]
type setup_cmd = {
cmdargs: string list
; env: string list
; id_to_fd_map: (string * int option) list
- ; syslog_stdout: syslog_stdout_t
+ ; syslog_stdout: syslog_stdout
; redirect_stderr_to_stdout: bool
}
[@@deriving rpc]
diff --git a/ocaml/forkexecd/lib/forkhelpers.ml b/ocaml/forkexecd/lib/forkhelpers.ml
index d55901c3c..f212ae7f0 100644
--- a/ocaml/forkexecd/lib/forkhelpers.ml
+++ b/ocaml/forkexecd/lib/forkhelpers.ml
@@ -21,6 +21,8 @@
(* XXX: this is a work in progress *)
+module D = Debug.Make (struct let name = __MODULE__ end)
+
let default_path = ["/sbin"; "/usr/sbin"; "/bin"; "/usr/bin"]
let default_path_env_pair = [|"PATH=" ^ String.concat ":" default_path|]
@@ -72,14 +74,47 @@ let waitpid (sock, pid) =
in
failwith msg
-let waitpid_nohang ((sock, _) as x) =
+(* [waitpid_nohang] reports the status of a socket to a process. The
+ intention is to make this non-blocking. If the process is finished,
+ the socket is closed and not otherwise. *)
+let waitpid_nohang (sock, pid) =
+ let verbose = false in
+ if verbose then D.debug "%s pid=%d" __FUNCTION__ pid ;
+ let fail fmt = Printf.kprintf failwith fmt in
Unix.set_nonblock sock ;
- let r =
- try waitpid x
- with Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) ->
- (0, Unix.WEXITED 0)
- in
- Unix.clear_nonblock sock ; r
+ match Fecomms.read_raw_rpc sock with
+ | Ok Fe.(Finished (WEXITED n)) ->
+ if verbose then D.debug "%s pid=%d WEXITED" __FUNCTION__ pid ;
+ Unix.close sock ;
+ (pid, Unix.WEXITED n)
+ | Ok Fe.(Finished (WSIGNALED n)) ->
+ if verbose then D.debug "%s pid=%d WSIGNALED" __FUNCTION__ pid ;
+ Unix.close sock ;
+ (pid, Unix.WSIGNALED n)
+ | Ok Fe.(Finished (WSTOPPED n)) ->
+ if verbose then D.debug "%s pid=%d WSTOPPED" __FUNCTION__ pid ;
+ Unix.close sock ;
+ (pid, Unix.WSTOPPED n)
+ | Ok status ->
+ Unix.clear_nonblock sock ;
+ fail "%s: unexpected status received (%s)" __FUNCTION__
+ (Fe.ferpc_to_string status)
+ | Error msg ->
+ D.debug "%s pid=%d %s" __FUNCTION__ pid msg ;
+ Unix.clear_nonblock sock ;
+ fail "%s: error happened when trying to read the status. %s" __FUNCTION__
+ msg
+ (* it's a bit crazy that we have Result.t and exceptions from
+ read_raw_rpc *)
+ | exception Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) ->
+ if verbose then D.debug "%s pid=%d EAGAIN EWOULDBLOCK" __FUNCTION__ pid ;
+ Unix.clear_nonblock sock ;
+ (0, Unix.WEXITED 0) (* this a convention, see MLI *)
+ | exception exn ->
+ D.debug "%s pid=%d %s" __FUNCTION__ pid (Printexc.to_string exn) ;
+ Unix.clear_nonblock sock ;
+ fail "%s: error happened when trying to read the status. %s" __FUNCTION__
+ (Printexc.to_string exn)
let dontwaitpid (sock, _pid) =
( try
@@ -136,7 +171,7 @@ let with_logfile_fd ?(delete = true) prefix f =
exception Spawn_internal_error of string * string * Unix.process_status
-type syslog_stdout_t =
+type syslog_stdout =
| NoSyslogging
| Syslog_DefaultKey
| Syslog_WithKey of string
diff --git a/ocaml/forkexecd/lib/forkhelpers.mli b/ocaml/forkexecd/lib/forkhelpers.mli
index 6252f0e75..186cbe518 100644
--- a/ocaml/forkexecd/lib/forkhelpers.mli
+++ b/ocaml/forkexecd/lib/forkhelpers.mli
@@ -34,7 +34,7 @@
(** {2 High-level interface } *)
-type syslog_stdout_t =
+type syslog_stdout =
| NoSyslogging
| Syslog_DefaultKey
| Syslog_WithKey of string
@@ -45,7 +45,7 @@ val default_path_env_pair : string array
val execute_command_get_output :
?env:string array
- -> ?syslog_stdout:syslog_stdout_t
+ -> ?syslog_stdout:syslog_stdout
-> ?redirect_stderr_to_stdout:bool
-> ?timeout:float
-> string
@@ -57,7 +57,7 @@ val execute_command_get_output :
val execute_command_get_output_send_stdin :
?env:string array
- -> ?syslog_stdout:syslog_stdout_t
+ -> ?syslog_stdout:syslog_stdout
-> ?redirect_stderr_to_stdout:bool
-> ?timeout:float
-> string
@@ -97,7 +97,7 @@ val safe_close_and_exec :
-> Unix.file_descr option
-> Unix.file_descr option
-> (string * Unix.file_descr) list
- -> ?syslog_stdout:syslog_stdout_t
+ -> ?syslog_stdout:syslog_stdout
-> ?redirect_stderr_to_stdout:bool
-> string
-> string list
@@ -111,8 +111,10 @@ val waitpid : pidty -> int * Unix.process_status
(** [waitpid p] returns the (pid, Unix.process_status) *)
val waitpid_nohang : pidty -> int * Unix.process_status
-(** [waitpid_nohang p] returns the (pid, Unix.process_status) if the process has already
- quit or (0, Unix.WEXITTED 0) if the process is still running. *)
+(** [waitpid_nohang p] returns the (pid, Unix.process_status) if the
+ process has already quit or (0, Unix.WEXITTED 0) if the process is
+ still running. If the process is finished, the socket is closed
+ and not otherwise. *)
val dontwaitpid : pidty -> unit
(** [dontwaitpid p]: signals the caller's desire to never call waitpid. Note that the final
diff --git a/ocaml/forkexecd/src/child.ml b/ocaml/forkexecd/src/child.ml
index 197f3b91f..0bdb5fc1d 100644
--- a/ocaml/forkexecd/src/child.ml
+++ b/ocaml/forkexecd/src/child.ml
@@ -3,13 +3,13 @@ let debug (fmt : ('a, unit, string, unit) format4) =
exception Cancelled
-type syslog_stdout_t = {enabled: bool; key: string option}
+type syslog_stdout = {enabled: bool; key: string option}
type state_t = {
cmdargs: string list
; env: string list
; id_to_fd_map: (string * int option) list
- ; syslog_stdout: syslog_stdout_t
+ ; syslog_stdout: syslog_stdout
; redirect_stderr_to_stdout: bool
; ids_received: (string * Unix.file_descr) list
; fd_sock2: Unix.file_descr option
diff --git a/ocaml/forkexecd/test/fe_test.ml b/ocaml/forkexecd/test/fe_test.ml
index bb740d94d..42991d5f1 100644
--- a/ocaml/forkexecd/test/fe_test.ml
+++ b/ocaml/forkexecd/test/fe_test.ml
@@ -109,14 +109,23 @@ let test_delay () =
let start = Unix.gettimeofday () in
let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in
let args = ["sleep"] in
+ (* Need to have fractional part because some internal usage split integer
+ and fractional and do computation.
+ Better to have a high fractional part (> 0.5) to more probably exceed
+ the unit.
+ *)
+ let timeout = 1.7 in
try
- Forkhelpers.execute_command_get_output ~timeout:4.0 exe args |> ignore ;
+ Forkhelpers.execute_command_get_output ~timeout exe args |> ignore ;
failwith "Failed to timeout"
with
| Forkhelpers.Subprocess_timeout ->
- Printf.printf "Caught timeout exception after %f seconds\n%!"
- (Unix.gettimeofday () -. start) ;
- ()
+ let elapsed = Unix.gettimeofday () -. start in
+ Printf.printf "Caught timeout exception after %f seconds\n%!" elapsed ;
+ if elapsed < timeout then
+ failwith "Process exited too soon" ;
+ if elapsed > timeout +. 0.2 then
+ failwith "Excessive time elapsed"
| e ->
failwith
(Printf.sprintf "Failed with unexpected exception: %s"
@@ -140,6 +149,10 @@ let fail x =
Printf.fprintf stderr "%s\n" x ;
assert false
+let expect expected s =
+ if s <> expected ^ "\n" then
+ fail (Printf.sprintf "output %s expected %s" s expected)
+
let test_exitcode () =
let run_expect cmd expected =
try Forkhelpers.execute_command_get_output cmd [] |> ignore
@@ -150,15 +163,39 @@ let test_exitcode () =
in
run_expect "/bin/false" 1 ;
run_expect "/bin/xe-fe-test-no-command" 127 ;
+ run_expect "/bin/xe-fe-no-path/xe-fe-test-no-command" 127 ;
run_expect "/etc/hosts" 126 ;
Printf.printf "\nCompleted exitcode tests\n"
+let test_output () =
+ let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in
+ let expected_out = "output string" in
+ let expected_err = "error string" in
+ let args = ["echo"; expected_out; expected_err] in
+ let out, err = Forkhelpers.execute_command_get_output exe args in
+ expect expected_out out ;
+ expect expected_err err ;
+ print_endline "Completed output tests"
+
+let test_input () =
+ let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in
+ let input = "input string" in
+ let args = ["replay"] in
+ let out, _ =
+ Forkhelpers.execute_command_get_output_send_stdin exe args input
+ in
+ expect input out ;
+ print_endline "Completed input tests"
+
let master fds =
Printf.printf "\nPerforming timeout tests\n%!" ;
test_delay () ;
test_notimeout () ;
Printf.printf "\nCompleted timeout test\n%!" ;
test_exitcode () ;
+ Printf.printf "\nPerforming input/output tests\n%!" ;
+ test_output () ;
+ test_input () ;
let combinations = shuffle (all_combinations fds) in
Printf.printf "Starting %d tests\n%!" (List.length combinations) ;
let i = ref 0 in
@@ -233,7 +270,15 @@ let slave = function
pid (List.length filtered) ls
)
-let sleep () = Unix.sleep 5 ; Printf.printf "Ok\n"
+let sleep () = Unix.sleep 3 ; Printf.printf "Ok\n"
+
+let echo out err =
+ if out <> "" then print_endline out ;
+ if err <> "" then prerr_endline err
+
+let replay () =
+ let line = read_line () in
+ print_endline line
let usage () =
Printf.printf "Usage:\n" ;
@@ -253,6 +298,10 @@ let _ =
sleep ()
| _ :: "slave" :: rest ->
slave rest
+ | _ :: "echo" :: out :: err :: _ ->
+ echo out err
+ | _ :: "replay" :: _ ->
+ replay ()
| [_] ->
master max_fds
| [_; fds] -> (
diff --git a/ocaml/forkexecd/test/fe_test.sh b/ocaml/forkexecd/test/fe_test.sh
index fa5ffc514..aa0b9899e 100755
--- a/ocaml/forkexecd/test/fe_test.sh
+++ b/ocaml/forkexecd/test/fe_test.sh
@@ -6,13 +6,14 @@ export XDG_RUNTIME_DIR=${XDG_RUNTIME_DIR:-$TMPDIR}
export FE_TEST=1
SOCKET=${XDG_RUNTIME_DIR}/xapi/forker/main
+rm -f "$SOCKET"
../src/fe_main.exe &
MAIN=$!
cleanup () {
kill $MAIN
}
-trap cleanup EXIT
+trap cleanup EXIT INT
for _ in $(seq 1 10); do
test -S ${SOCKET} || sleep 1
done
diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml
index c8fa26141..11442e249 100644
--- a/ocaml/idl/datamodel.ml
+++ b/ocaml/idl/datamodel.ml
@@ -6070,7 +6070,7 @@ module Event = struct
~doc:
"Blocking call which returns a (possibly empty) batch of events. This \
method is only recommended for legacy use. New development should use \
- event.from which supercedes this method."
+ event.from which supersedes this method."
~custom_marshaller:true ~flags:[`Session]
~result:(Set (Record _event), "A set of events")
~errs:[Api_errors.session_not_registered; Api_errors.events_lost]
@@ -8177,6 +8177,7 @@ let http_actions =
; Bool_query_arg "include_dom0"
; Bool_query_arg "include_vhd_parents"
; Bool_query_arg "export_snapshots"
+ ; String_query_arg "excluded_device_types"
]
, _R_VM_ADMIN
, []
diff --git a/ocaml/idl/datamodel_observer.ml b/ocaml/idl/datamodel_observer.ml
index bbda90218..1d80d030a 100644
--- a/ocaml/idl/datamodel_observer.ml
+++ b/ocaml/idl/datamodel_observer.ml
@@ -95,7 +95,7 @@ let set_components =
call ~name:"set_components" ~in_oss_since:None ~lifecycle:[]
~doc:
"Set the components on which the observer will broadcast to. i.e. xapi, \
- xenopsd, networkd, etc"
+ xenopsd, networkd, etc."
~params:
[
(Ref _observer, "self", "The observer")
@@ -106,7 +106,7 @@ let set_components =
let t =
create_obj ~name:_observer
~descr:
- "Describes a observer which will control observability activity in the \
+ "Describes an observer which will control observability activity in the \
Toolstack"
~doccomments:[] ~gen_constructor_destructor:true ~gen_events:true
~in_db:true ~lifecycle:[] ~persist:PersistEverything ~in_oss_since:None
diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml
index c1a6b9a7d..aa45d93de 100644
--- a/ocaml/idl/datamodel_vm.ml
+++ b/ocaml/idl/datamodel_vm.ml
@@ -1899,7 +1899,7 @@ let t =
; field ~qualifier:DynamicRO ~ty:(Set (Ref _vbd)) "VBDs"
"virtual block devices"
; field ~qualifier:DynamicRO ~ty:(Set (Ref _vusb)) "VUSBs"
- "vitual usb devices"
+ "virtual usb devices"
; field ~writer_roles:_R_POOL_ADMIN ~qualifier:DynamicRO
~ty:(Set (Ref _crashdump)) "crash_dumps"
"crash dumps associated with this VM"
diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml
index 01c49bdbe..734e78d6b 100644
--- a/ocaml/idl/ocaml_backend/gen_api.ml
+++ b/ocaml/idl/ocaml_backend/gen_api.ml
@@ -72,6 +72,23 @@ let overrides =
)
]
+(** Generate enum__all and enum_to_string bindings for all enums *)
+let gen_enum_helpers tys =
+ let gen_string_and_all = function
+ | DT.Set (DT.Enum (_, elist) as e) ->
+ let nlist = List.map fst elist in
+ [
+ Printf.sprintf "let %s__all = %s" (OU.alias_of_ty e)
+ (OU.ocaml_list_of_enum nlist)
+ ; (Printf.sprintf "let %s_to_string = %s")
+ (OU.alias_of_ty e)
+ (OU.ocaml_to_string_of_enum nlist)
+ ]
+ | _ ->
+ []
+ in
+ List.concat_map gen_string_and_all tys
+
(** Generate a single type declaration for simple types (eg not containing references to record objects) *)
let gen_non_record_type tys =
let rec aux accu = function
@@ -382,6 +399,7 @@ let gen_client_types highapi =
; gen_non_record_type all_types
; gen_record_type ~with_module:true highapi
(toposort_types highapi all_types)
+ ; gen_enum_helpers all_types
; O.Signature.strings_of (Gen_client.gen_signature highapi)
]
)
diff --git a/ocaml/idl/ocaml_backend/ocaml_utils.ml b/ocaml/idl/ocaml_backend/ocaml_utils.ml
index e3ab8ac19..a01ae9555 100644
--- a/ocaml/idl/ocaml_backend/ocaml_utils.ml
+++ b/ocaml/idl/ocaml_backend/ocaml_utils.ml
@@ -58,9 +58,15 @@ let ocaml_of_record_field = function
let ocaml_of_module_name x = String.capitalize_ascii x
+let ocaml_map_enum_ sep f list = String.concat sep (List.map f list)
+
(** Convert an IDL enum into a polymorhic variant. *)
let ocaml_of_enum list =
- "[ " ^ String.concat " | " (List.map constructor_of list) ^ " ]"
+ Printf.sprintf "[%s]" (ocaml_map_enum_ " | " constructor_of list)
+
+(* Create a to_string function for a polymorphic variant. *)
+let ocaml_list_of_enum list =
+ Printf.sprintf "[%s]" (ocaml_map_enum_ "; " constructor_of list)
(** Convert an IDL type to a function name; we need to generate functions to
marshal/unmarshal from XML for each unique IDL type *)
@@ -90,6 +96,11 @@ let rec alias_of_ty = function
| Option x ->
sprintf "%s_option" (alias_of_ty x)
+(** Create the body of a to_string function for an enum *)
+let ocaml_to_string_of_enum list =
+ let single name = Printf.sprintf {|%s -> "%s"|} (constructor_of name) name in
+ Printf.sprintf "function %s" (ocaml_map_enum_ " | " single list)
+
(** Convert an IDL type into a string containing OCaml code representing the
type. *)
let rec ocaml_of_ty = function
diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml
index c8e5972c9..82619e839 100644
--- a/ocaml/idl/schematest.ml
+++ b/ocaml/idl/schematest.ml
@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
(* BEWARE: if this changes, check that schema has been bumped accordingly in
ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
-let last_known_schema_hash = "186131ad48f40dff30246e8e0c0dbf0a"
+let last_known_schema_hash = "a55d5dc70920dcf4ab72ed321497b482"
let current_schema_hash : string =
let open Datamodel_types in
diff --git a/ocaml/libs/uuid/uuidx.ml b/ocaml/libs/uuid/uuidx.ml
index de471da0e..01dbda468 100644
--- a/ocaml/libs/uuid/uuidx.ml
+++ b/ocaml/libs/uuid/uuidx.ml
@@ -83,3 +83,15 @@ let string_of_uuid = to_string
let uuid_of_int_array = of_int_array
let int_array_of_uuid = to_int_array
+
+module Hash = struct
+ (** Derive a deterministic UUID from a string: the same
+ string maps to the same UUID. We are using our own namespace; the
+ namespace is not a secret *)
+
+ let namespace =
+ let ns = "e93e0639-2bdb-4a59-8b46-352b3f408c19" in
+ Uuidm.(of_string ns |> Option.get)
+
+ let string str = Uuidm.v5 namespace str
+end
diff --git a/ocaml/libs/uuid/uuidx.mli b/ocaml/libs/uuid/uuidx.mli
index 57b4058b8..618235b4a 100644
--- a/ocaml/libs/uuid/uuidx.mli
+++ b/ocaml/libs/uuid/uuidx.mli
@@ -81,3 +81,11 @@ val make_cookie : unit -> cookie
val cookie_of_string : string -> cookie
val string_of_cookie : cookie -> string
+
+module Hash : sig
+ (** hash a string (deterministically) into a UUID. This uses
+ namespace UUID e93e0639-2bdb-4a59-8b46-352b3f408c19. *)
+
+ (* UUID Version 5 derived from argument string and namespace UUID *)
+ val string : string -> 'a t
+end
diff --git a/ocaml/message-switch/async/protocol_async.ml b/ocaml/message-switch/async/protocol_async.ml
index 9ec9cc42b..5898d22f7 100644
--- a/ocaml/message-switch/async/protocol_async.ml
+++ b/ocaml/message-switch/async/protocol_async.ml
@@ -30,9 +30,16 @@ module M = struct
let iter f t = Deferred.List.iter t ~f
+ let iter_dontwait f t =
+ Deferred.don't_wait_for @@ Deferred.List.iter ~how:`Parallel t ~f
+
let any = Deferred.any
+ let all = Deferred.all
+
let is_determined = Deferred.is_determined
+
+ let return_unit = Deferred.unit
end
let connect path =
@@ -95,6 +102,20 @@ module M = struct
)
end
+ module Condition = struct
+ open Async_kernel
+
+ type 'a t = 'a Condition.t
+
+ let create = Condition.create
+
+ let wait = Condition.wait
+
+ let broadcast = Condition.broadcast
+
+ let signal = Condition.signal
+ end
+
module Clock = struct
type timer = {cancel: unit Ivar.t}
@@ -117,3 +138,4 @@ end
module Client = Message_switch_core.Make.Client (M)
module Server = Message_switch_core.Make.Server (M)
+module Mtest = Message_switch_core.Mtest.Make (M)
diff --git a/ocaml/message-switch/async/protocol_async.mli b/ocaml/message-switch/async/protocol_async.mli
index f691c24c9..d18b37b74 100644
--- a/ocaml/message-switch/async/protocol_async.mli
+++ b/ocaml/message-switch/async/protocol_async.mli
@@ -19,3 +19,5 @@ open Message_switch_core
module Client : S.CLIENT with type 'a io = 'a Deferred.t
module Server : S.SERVER with type 'a io = 'a Deferred.t
+
+module Mtest : Mtest.MTEST with type 'a io = 'a Deferred.t
diff --git a/ocaml/message-switch/cli/dune b/ocaml/message-switch/cli/dune
index beb3741dc..c0741e713 100644
--- a/ocaml/message-switch/cli/dune
+++ b/ocaml/message-switch/cli/dune
@@ -5,6 +5,7 @@
cmdliner
message-switch-core
message-switch-unix
+ mtime
rpclib.core
rpclib.json
threads.posix
diff --git a/ocaml/message-switch/cli/main.ml b/ocaml/message-switch/cli/main.ml
index 197061a17..19324a5a2 100644
--- a/ocaml/message-switch/cli/main.ml
+++ b/ocaml/message-switch/cli/main.ml
@@ -76,23 +76,36 @@ let help =
; `P (Printf.sprintf "Check bug reports at %s" project_url)
]
+(* Durations, in nanoseconds *)
+let second = 1_000_000_000L
+
+let minute = 60_000_000_000L
+
+let hour = 3600_000_000_000L
+
+let day = 86400_000_000_000L
+
(* Commands *)
let diagnostics common_opts =
Client.connect ~switch:common_opts.Common.path () >>|= fun t ->
Client.diagnostics ~t () >>|= fun d ->
let open Message_switch_core.Protocol in
- let in_the_past = Int64.sub d.Diagnostics.current_time in
+ let in_the_past ts =
+ if d.Diagnostics.current_time < ts then
+ 0L
+ else
+ Int64.sub d.Diagnostics.current_time ts
+ in
let time f x =
- let open Int64 in
- let secs = div (f x) 1_000_000_000L in
- let secs' = rem secs 60L in
- let mins = div secs 60L in
- let mins' = rem mins 60L in
- let hours = div mins 60L in
- let hours' = rem hours 24L in
- let days = div hours 24L in
- let fragment name = function
+ let timespan = f x in
+ let ( // ) = Int64.div in
+ let ( %% ) = Int64.rem in
+ let secs = timespan %% minute // second in
+ let mins = timespan %% hour // minute in
+ let hours = timespan %% day // hour in
+ let days = timespan // day in
+ let format name = function
| 0L ->
[]
| 1L ->
@@ -101,11 +114,10 @@ let diagnostics common_opts =
[Printf.sprintf "%Ld %ss" n name]
in
let bits =
- fragment "day" days
- @ fragment "hour" hours'
- @ fragment "min" mins'
- @ fragment "second" secs'
- @ []
+ format "day" days
+ @ format "hour" hours
+ @ format "min" mins
+ @ format "second" secs
in
let length = List.length bits in
let _, rev_bits =
@@ -122,7 +134,16 @@ let diagnostics common_opts =
)
(0, []) bits
in
- String.concat "" (List.rev rev_bits) ^ "ago"
+ let format_secs ts =
+ Mtime.Span.(Format.asprintf "%a " pp (of_uint64_ns ts))
+ in
+ let timestrings =
+ if rev_bits = [] then
+ [format_secs (timespan %% minute)]
+ else
+ List.rev rev_bits
+ in
+ String.concat "" timestrings ^ "ago"
in
let origin = function
| Anonymous id ->
diff --git a/ocaml/message-switch/core/dune b/ocaml/message-switch/core/dune
index 676fa3f20..6debbc895 100644
--- a/ocaml/message-switch/core/dune
+++ b/ocaml/message-switch/core/dune
@@ -9,6 +9,8 @@
sexplib
sexplib0
uri
+ xapi-log
+ xapi-stdext-threads
)
(preprocess (pps ppx_deriving_rpc ppx_sexp_conv))
)
diff --git a/ocaml/message-switch/core/make.ml b/ocaml/message-switch/core/make.ml
index 54e8904e1..224012909 100644
--- a/ocaml/message-switch/core/make.ml
+++ b/ocaml/message-switch/core/make.ml
@@ -16,6 +16,10 @@
open Sexplib.Std
open Protocol
+module D = Debug.Make (struct let name = "Message_switch.make" end)
+
+open D
+
module Connection =
functor
(IO : Cohttp.S.IO)
@@ -406,4 +410,92 @@ functor
in
let _ = loop c None in
return (Ok t)
+
+ let listen_p ~process ~switch:port ~queue:name () =
+ let token = Printf.sprintf "%d" (Unix.getpid ()) in
+ let protect_connect path f =
+ M.connect path >>= fun conn ->
+ f conn >>= function
+ | Ok _ as ok ->
+ return ok
+ | Error _ as err ->
+ M.disconnect conn >>= fun () -> return err
+ in
+ let reconnect () =
+ protect_connect port @@ fun request_conn ->
+ Connection.rpc request_conn (In.Login token) >>|= fun (_ : string) ->
+ protect_connect port @@ fun reply_conn ->
+ Connection.rpc reply_conn (In.Login token) >>|= fun (_ : string) ->
+ return (Ok (request_conn, reply_conn))
+ in
+ reconnect () >>|= fun ((request_conn, reply_conn) as c) ->
+ let request_shutdown = M.Ivar.create () in
+ let on_shutdown = M.Ivar.create () in
+ let mutex = M.Mutex.create () in
+ Connection.rpc request_conn (In.CreatePersistent name) >>|= fun _ ->
+ let t = {request_shutdown; on_shutdown} in
+ let reconnect () =
+ M.disconnect request_conn >>= fun () ->
+ M.disconnect reply_conn >>= reconnect
+ in
+ let rec loop c from =
+ let transfer = {In.from; timeout; queues= [name]} in
+ let frame = In.Transfer transfer in
+ let message = Connection.rpc request_conn frame in
+ any [map (fun _ -> ()) message; M.Ivar.read request_shutdown]
+ >>= fun () ->
+ if is_determined (M.Ivar.read request_shutdown) then (
+ M.Ivar.fill on_shutdown () ; return (Ok ())
+ ) else
+ message >>= function
+ | Error _e ->
+ M.Mutex.with_lock mutex reconnect >>|= fun c -> loop c from
+ | Ok raw -> (
+ let transfer = Out.transfer_of_rpc (Jsonrpc.of_string raw) in
+ let print_error = function
+ | Ok (_ : string) ->
+ return ()
+ | Error _ as err ->
+ error "message switch reply received error" ;
+ ignore @@ error_to_msg err ;
+ return ()
+ in
+ match transfer.Out.messages with
+ | [] ->
+ loop c from
+ | _ :: _ ->
+ iter_dontwait
+ (fun (i, m) ->
+ process m.Message.payload >>= fun response ->
+ ( match m.Message.kind with
+ | Message.Response _ ->
+ return () (* configuration error *)
+ | Message.Request reply_to ->
+ let request =
+ In.Send
+ ( reply_to
+ , {
+ Message.kind= Message.Response i
+ ; payload= response
+ }
+ )
+ in
+ M.Mutex.with_lock mutex (fun () ->
+ Connection.rpc reply_conn request
+ )
+ >>= print_error
+ )
+ >>= fun () ->
+ let request = In.Ack i in
+ M.Mutex.with_lock mutex (fun () ->
+ Connection.rpc reply_conn request
+ )
+ >>= print_error
+ )
+ transfer.Out.messages ;
+ loop c (Some transfer.Out.next)
+ )
+ in
+ let _ = loop c None in
+ return (Ok t)
end
diff --git a/ocaml/message-switch/core/mtest.ml b/ocaml/message-switch/core/mtest.ml
new file mode 100644
index 000000000..3b8da9803
--- /dev/null
+++ b/ocaml/message-switch/core/mtest.ml
@@ -0,0 +1,42 @@
+module type MTEST = sig
+ type +'a io
+
+ val mutex_provides_mutal_exclusion : unit -> unit io
+end
+
+module Make =
+functor
+ (M : S.BACKEND)
+ ->
+ struct
+ open M.IO
+
+ type 'a io = 'a M.IO.t
+
+ let ocaml_lock = Mutex.create ()
+
+ let mu = M.Mutex.create ()
+
+ let cond = M.Condition.create ()
+
+ let broadcast () = M.Condition.broadcast cond ()
+
+ let mutex_provides_mutal_exclusion () : unit io =
+ let promises =
+ List.init 100 (fun _ ->
+ M.Condition.wait cond >>= fun () ->
+ M.Mutex.with_lock mu (fun () ->
+ M.IO.return_unit >>= fun () ->
+ (* the with_lock implementation should ensure that only one
+ monad can try to acquire this lock *)
+ assert (Mutex.try_lock ocaml_lock) ;
+ M.IO.return_unit >>= fun () ->
+ Mutex.unlock ocaml_lock ; M.IO.return_unit
+ )
+ )
+ in
+ broadcast () ;
+ ignore @@ all promises ;
+ Printf.printf "%s test.\n" (M.whoami ()) ;
+ M.IO.return_unit
+ end
diff --git a/ocaml/message-switch/core/s.ml b/ocaml/message-switch/core/s.ml
index f99e05826..423304d1b 100644
--- a/ocaml/message-switch/core/s.ml
+++ b/ocaml/message-switch/core/s.ml
@@ -29,9 +29,15 @@ module type BACKEND = sig
val iter : ('a -> unit t) -> 'a list -> unit t
+ val iter_dontwait : ('a -> unit t) -> 'a list -> unit
+
val any : 'a t list -> 'a t
+ val all : 'a t list -> 'a list t
+
val is_determined : 'a t -> bool
+
+ val return_unit : unit t
end
val connect : string -> (IO.ic * IO.oc) IO.t
@@ -56,6 +62,18 @@ module type BACKEND = sig
val with_lock : t -> (unit -> 'a IO.t) -> 'a IO.t
end
+ module Condition : sig
+ type 'a t
+
+ val create : unit -> 'a t
+
+ val wait : 'a t -> 'a IO.t
+
+ val broadcast : 'a t -> 'a -> unit
+
+ val signal : 'a t -> 'a -> unit
+ end
+
module Clock : sig
type timer
@@ -89,6 +107,14 @@ module type SERVER = sig
(** Connect to [switch] and start processing messages on [queue] via function
[process] *)
+ val listen_p :
+ process:(string -> string io)
+ -> switch:string
+ -> queue:string
+ -> unit
+ -> t result io
+ (** same as above, but processes requests concurrently *)
+
val shutdown : t:t -> unit -> unit io
(** [shutdown t] shutdown a server *)
end
diff --git a/ocaml/message-switch/core_test/async/server_async_main.ml b/ocaml/message-switch/core_test/async/server_async_main.ml
index 2372cb34c..cd7984bec 100644
--- a/ocaml/message-switch/core_test/async/server_async_main.ml
+++ b/ocaml/message-switch/core_test/async/server_async_main.ml
@@ -23,6 +23,8 @@ let path = ref "/var/run/message-switch/sock"
let name = ref "server"
+let concurrent = ref false
+
let shutdown = Ivar.create ()
let process = function
@@ -33,6 +35,9 @@ let process = function
let main () =
let (_ : 'a Deferred.t) =
+ if !concurrent then
+ Server.listen_p ~process ~switch:!path ~queue:!name ()
+ else
Server.listen ~process ~switch:!path ~queue:!name ()
in
Ivar.read shutdown >>= fun () ->
@@ -49,6 +54,11 @@ let _ =
, Arg.Set_string name
, Printf.sprintf "name to send message to (default %s)" !name
)
+ ; ( "-concurrent"
+ , Arg.Set concurrent
+ , Printf.sprintf "set concurrent processing of messages (default %b)"
+ !concurrent
+ )
]
(fun x -> P.fprintf stderr "Ignoring unexpected argument: %s" x)
"Respond to RPCs on a name" ;
diff --git a/ocaml/message-switch/core_test/basic-rpc-test.sh b/ocaml/message-switch/core_test/basic-rpc-test.sh
index e73c3a873..877790370 100755
--- a/ocaml/message-switch/core_test/basic-rpc-test.sh
+++ b/ocaml/message-switch/core_test/basic-rpc-test.sh
@@ -1,12 +1,14 @@
#!/bin/bash
set -e
-SPATH=${TMPDIR:-/tmp}/sock
-SWITCHPATH=${TMPDIR:-/tmp}/switch
+SPATH=${TMPDIR:-/tmp}/sock_s
+SWITCHPATH=${TMPDIR:-/tmp}/switch_s
rm -rf ${SWITCHPATH} && mkdir -p ${SWITCHPATH}
+echo Test message switch serial processing
+
echo Checking the switch can start late
./server_unix_main.exe -path $SPATH &
sleep 1
diff --git a/ocaml/message-switch/core_test/concur-rpc-test.sh b/ocaml/message-switch/core_test/concur-rpc-test.sh
new file mode 100755
index 000000000..a91768972
--- /dev/null
+++ b/ocaml/message-switch/core_test/concur-rpc-test.sh
@@ -0,0 +1,45 @@
+#!/bin/bash
+set -e
+
+SPATH="${TMPDIR:-/tmp}/sock_p-$$"
+SWITCHPATH="${TMPDIR:-/tmp}/switch_p-$$"
+
+trap "cleanup" TERM INT
+
+function cleanup {
+ rm -rf "${SWITCHPATH}"
+}
+
+rm -rf "${SWITCHPATH}" && mkdir -p "${SWITCHPATH}"
+
+echo Test message switch concurrent processing
+
+echo Checking the switch can start late
+test -x ./server_unix_main.exe || exit 1
+./server_unix_main.exe -path "$SPATH" &
+sleep 1
+test -x ../switch/switch_main.exe && test -x ./client_unix_main.exe || exit 1
+../switch/switch_main.exe --path "$SPATH" --statedir "${SWITCHPATH}" &
+./client_unix_main.exe -path "$SPATH" -secs 5
+sleep 2
+
+echo Performance test of Lwt to Lwt
+test -x lwt/server_main.exe && test -x lwt/client_main.exe || exit 1
+lwt/server_main.exe -path "$SPATH" -concurrent &
+lwt/client_main.exe -path "$SPATH" -secs 5
+sleep 2
+
+echo Performance test of Async to Lwt
+test -x lwt/server_main.exe && test -x async/client_async_main.exe || exit 1
+lwt/server_main.exe -path "$SPATH" -concurrent &
+async/client_async_main.exe -path "$SPATH" -secs 5
+sleep 2
+
+echo Performance test of Async to Async
+test -x async/server_async_main.exe && test -x async/client_async_main.exe || exit 1
+async/server_async_main.exe -path "$SPATH" -concurrent &
+async/client_async_main.exe -path "$SPATH" -secs 5
+sleep 2
+
+../cli/main.exe shutdown --path "$SPATH"
+sleep 2
diff --git a/ocaml/message-switch/core_test/dune b/ocaml/message-switch/core_test/dune
index d500c1013..449f2fae5 100644
--- a/ocaml/message-switch/core_test/dune
+++ b/ocaml/message-switch/core_test/dune
@@ -3,13 +3,43 @@
(names
client_unix_main
server_unix_main
+ lock_test_async
+ lock_test_lwt
+ )
+ (modules
+ client_unix_main
+ server_unix_main
+ lock_test_async
+ lock_test_lwt
)
(libraries
message-switch-unix
+ message-switch-core
+ message-switch-async
+ message-switch-lwt
threads.posix
)
)
+(rule
+ (alias runtest)
+ (deps
+ lock_test_async.exe
+ )
+ (action (run ./lock_test_async.exe))
+ (package message-switch)
+)
+
+(rule
+ (alias runtest)
+ (deps
+ lock_test_lwt.exe
+ )
+ (action (run ./lock_test_lwt.exe))
+ (package message-switch)
+)
+
+
(rule
(alias runtest)
(deps
@@ -27,3 +57,20 @@
(package message-switch)
)
+(rule
+ (alias runtest)
+ (deps
+ client_unix_main.exe
+ server_unix_main.exe
+ async/client_async_main.exe
+ async/server_async_main.exe
+ lwt/client_main.exe
+ lwt/server_main.exe
+ lwt/link_test_main.exe
+ ../switch/switch_main.exe
+ ../cli/main.exe
+ )
+ (action (run ./concur-rpc-test.sh))
+ (package message-switch)
+)
+
diff --git a/ocaml/message-switch/core_test/lock_test_async.ml b/ocaml/message-switch/core_test/lock_test_async.ml
new file mode 100644
index 000000000..85cde8eae
--- /dev/null
+++ b/ocaml/message-switch/core_test/lock_test_async.ml
@@ -0,0 +1,13 @@
+open Core
+open Async
+open Message_switch_async
+
+let ( >>= ) = Deferred.( >>= )
+
+let test_async_lock () = Protocol_async.Mtest.mutex_provides_mutal_exclusion ()
+
+let () =
+ don't_wait_for
+ (test_async_lock () >>= fun () -> shutdown 0 ; Deferred.return ())
+
+let () = never_returns (Scheduler.go ())
diff --git a/ocaml/message-switch/core_test/lock_test_lwt.ml b/ocaml/message-switch/core_test/lock_test_lwt.ml
new file mode 100644
index 000000000..784599daf
--- /dev/null
+++ b/ocaml/message-switch/core_test/lock_test_lwt.ml
@@ -0,0 +1,5 @@
+open Message_switch_lwt
+
+let test_lwt_lock = Protocol_lwt.Mtest.mutex_provides_mutal_exclusion ()
+
+let () = Lwt_main.run test_lwt_lock
diff --git a/ocaml/message-switch/core_test/lwt/server_main.ml b/ocaml/message-switch/core_test/lwt/server_main.ml
index c30021ff3..ece423dcb 100644
--- a/ocaml/message-switch/core_test/lwt/server_main.ml
+++ b/ocaml/message-switch/core_test/lwt/server_main.ml
@@ -20,6 +20,8 @@ let path = ref "/var/run/message-switch/sock"
let name = ref "server"
+let concurrent = ref false
+
let t, u = Lwt.task ()
let process = function
@@ -29,8 +31,13 @@ let process = function
return x
let main () =
+ ( if !concurrent then
+ Message_switch_lwt.Protocol_lwt.Server.listen_p ~process ~switch:!path
+ ~queue:!name ()
+ else
Message_switch_lwt.Protocol_lwt.Server.listen ~process ~switch:!path
~queue:!name ()
+ )
>>= fun _ ->
t >>= fun () -> Lwt_unix.sleep 1.
@@ -45,6 +52,11 @@ let _ =
, Arg.Set_string name
, Printf.sprintf "name to send message to (default %s)" !name
)
+ ; ( "-concurrent"
+ , Arg.Set concurrent
+ , Printf.sprintf "set concurrent processing of messages (default %b)"
+ !concurrent
+ )
]
(fun x -> Printf.fprintf stderr "Ignoring unexpected argument: %s" x)
"Respond to RPCs on a name" ;
diff --git a/ocaml/message-switch/lwt/protocol_lwt.ml b/ocaml/message-switch/lwt/protocol_lwt.ml
index 6da59eb32..26c9c874d 100644
--- a/ocaml/message-switch/lwt/protocol_lwt.ml
+++ b/ocaml/message-switch/lwt/protocol_lwt.ml
@@ -27,9 +27,15 @@ module M = struct
let iter = Lwt_list.iter_s
+ let iter_dontwait f lst = Lwt.async (fun () -> Lwt_list.iter_p f lst)
+
let any = Lwt.choose
+ let all = Lwt.all
+
let is_determined t = Lwt.state t <> Lwt.Sleep
+
+ let return_unit = Lwt.return_unit
end
let connect path =
@@ -75,6 +81,18 @@ module M = struct
let with_lock = Lwt_mutex.with_lock
end
+ module Condition = struct
+ type 'a t = 'a Lwt_condition.t
+
+ let create = Lwt_condition.create
+
+ let signal = Lwt_condition.signal
+
+ let wait c = Lwt_condition.wait c
+
+ let broadcast = Lwt_condition.broadcast
+ end
+
module Clock = struct
type timer = unit Lwt.t
@@ -90,3 +108,4 @@ end
module Client = Message_switch_core.Make.Client (M)
module Server = Message_switch_core.Make.Server (M)
+module Mtest = Message_switch_core.Mtest.Make (M)
diff --git a/ocaml/message-switch/lwt/protocol_lwt.mli b/ocaml/message-switch/lwt/protocol_lwt.mli
index c9bd22015..64ca15c0e 100644
--- a/ocaml/message-switch/lwt/protocol_lwt.mli
+++ b/ocaml/message-switch/lwt/protocol_lwt.mli
@@ -19,3 +19,5 @@ open Message_switch_core
module Client : S.CLIENT with type 'a io = 'a Lwt.t
module Server : S.SERVER with type 'a io = 'a Lwt.t
+
+module Mtest : Mtest.MTEST with type 'a io = 'a Lwt.t
diff --git a/ocaml/message-switch/switch/switch_main.ml b/ocaml/message-switch/switch/switch_main.ml
index 9bf78973a..583baf6e5 100644
--- a/ocaml/message-switch/switch/switch_main.ml
+++ b/ocaml/message-switch/switch/switch_main.ml
@@ -75,6 +75,13 @@ module Lwt_result = struct
let ( >>= ) m f = m >>= fun x -> f (Stdlib.Result.get_ok x)
end
+let exn_hook e =
+ let bt = Printexc.get_raw_backtrace () in
+ error "Caught exception in Lwt.async: %s" (Printexc.to_string e) ;
+ error "backtrace: %s" (Printexc.raw_backtrace_to_string bt)
+
+let () = Lwt.async_exception_hook := exn_hook
+
let make_server config trace_config =
let open Config in
info "Started server on %s" config.path ;
diff --git a/ocaml/message-switch/unix/protocol_unix.ml b/ocaml/message-switch/unix/protocol_unix.ml
index 678b302ab..485964a40 100644
--- a/ocaml/message-switch/unix/protocol_unix.ml
+++ b/ocaml/message-switch/unix/protocol_unix.ml
@@ -546,5 +546,7 @@ module Server = struct
let (_ : Thread.t) = thread_forever (loop connections) None in
Ok ()
+ let listen_p = listen
+
let shutdown ~t:_ () = failwith "Shutdown is unimplemented"
end
diff --git a/ocaml/quicktest/qt.ml b/ocaml/quicktest/qt.ml
index 1764f12ce..d390f0dfc 100644
--- a/ocaml/quicktest/qt.ml
+++ b/ocaml/quicktest/qt.ml
@@ -132,26 +132,32 @@ module VM = struct
Some x
end
- let install rpc session_id ~template ~name =
+ let install rpc session_id ~template ~name ?sr () =
let template_uuid =
Client.Client.VM.get_uuid ~rpc ~session_id ~self:template
in
- let newvm_uuid =
- cli_cmd
- [
- "vm-install"
- ; "template-uuid=" ^ template_uuid
- ; "new-name-label=" ^ name
- ]
+ let cmd =
+ ["vm-install"; "template-uuid=" ^ template_uuid; "new-name-label=" ^ name]
+ in
+ let sr_uuid =
+ Option.map
+ (fun sr -> Client.Client.SR.get_uuid ~rpc ~session_id ~self:sr)
+ sr
in
+ let cmd =
+ cmd @ Option.fold ~none:[] ~some:(fun x -> ["sr-uuid=" ^ x]) sr_uuid
+ in
+ let newvm_uuid = cli_cmd cmd in
Client.Client.VM.get_by_uuid ~rpc ~session_id ~uuid:newvm_uuid
let uninstall rpc session_id vm =
let uuid = Client.Client.VM.get_uuid ~rpc ~session_id ~self:vm in
cli_cmd ["vm-uninstall"; "uuid=" ^ uuid; "--force"] |> ignore
- let with_new rpc session_id ~template f =
- let vm = install rpc session_id ~template ~name:"temp_quicktest_vm" in
+ let with_new rpc session_id ~template ?sr f =
+ let vm =
+ install rpc session_id ~template ~name:"temp_quicktest_vm" ?sr ()
+ in
Xapi_stdext_pervasives.Pervasiveext.finally
(fun () -> f vm)
(fun () -> uninstall rpc session_id vm)
diff --git a/ocaml/quicktest/qt.mli b/ocaml/quicktest/qt.mli
index f0edde13a..15dbb785f 100644
--- a/ocaml/quicktest/qt.mli
+++ b/ocaml/quicktest/qt.mli
@@ -50,7 +50,12 @@ module VM : sig
end
val with_new :
- rpc -> API.ref_session -> template:API.ref_VM -> (API.ref_VM -> 'a) -> 'a
+ rpc
+ -> API.ref_session
+ -> template:API.ref_VM
+ -> ?sr:API.ref_SR
+ -> (API.ref_VM -> 'a)
+ -> 'a
val dom0_of_host : rpc -> API.ref_session -> API.ref_host -> API.ref_VM
(** Return a host's domain zero *)
diff --git a/ocaml/quicktest/quicktest_vm_lifecycle.ml b/ocaml/quicktest/quicktest_vm_lifecycle.ml
index 88fd9b8d6..b3de6b5b3 100644
--- a/ocaml/quicktest/quicktest_vm_lifecycle.ml
+++ b/ocaml/quicktest/quicktest_vm_lifecycle.ml
@@ -91,12 +91,18 @@ let one rpc session_id vm test =
| Halted ->
wait_for_domid (fun domid' -> domid' = -1L)
-let test rpc session_id vm_template () =
- Qt.VM.with_new rpc session_id ~template:vm_template (fun vm ->
+let test rpc session_id sr_info vm_template () =
+ let sr = sr_info.Qt.sr in
+ Qt.VM.with_new rpc session_id ~template:vm_template ~sr (fun vm ->
List.iter (one rpc session_id vm) all_possible_tests
)
let tests () =
let open Qt_filter in
- [[("VM lifecycle tests", `Slow, test)] |> conn |> vm_template "CoreOS"]
+ [
+ [("VM lifecycle tests", `Slow, test)]
+ |> conn
+ |> sr SR.(all |> allowed_operations [`vdi_create])
+ |> vm_template "CoreOS"
+ ]
|> List.concat
diff --git a/ocaml/sdk-gen/README.md b/ocaml/sdk-gen/README.md
index 7473d141f..fb4d71650 100644
--- a/ocaml/sdk-gen/README.md
+++ b/ocaml/sdk-gen/README.md
@@ -12,9 +12,7 @@ The Python module is not auto-generated, it can be found at
[XenAPI.py](../../scripts/examples/python/XenAPI/XenAPI.py).
To compile the generated source code, follow the instructions in the corresponding
-README files. The (patched) third party libraries required for the compilation
-of the C# and PowerShell source code can be obtained from
-[xenserver/dotnet-packages](https://github.com/xenserver/dotnet-packages)
+`README` files.
The repository [xenserver/xenserver-samples](https://github.com/xenserver/xenserver-samples)
contains a number of examples for each of the five programming languages to help
diff --git a/ocaml/sdk-gen/c/README.dist b/ocaml/sdk-gen/c/README.dist
index dfe923902..e5fb86220 100644
--- a/ocaml/sdk-gen/c/README.dist
+++ b/ocaml/sdk-gen/c/README.dist
@@ -58,4 +58,3 @@ Compiling from source
---------------------
To build, simply type "make" in the libxenserver/src directory.
-To build on Windows with cygwin type "make CYGWIN=1".
diff --git a/ocaml/sdk-gen/c/autogen/src/xen_common.c b/ocaml/sdk-gen/c/autogen/src/xen_common.c
index 9081f9bd7..9178d3fd4 100644
--- a/ocaml/sdk-gen/c/autogen/src/xen_common.c
+++ b/ocaml/sdk-gen/c/autogen/src/xen_common.c
@@ -292,10 +292,7 @@ set_api_version(xen_session *session)
void
xen_session_logout(xen_session *session)
{
- abstract_value params[] =
- {
- };
- xen_call_(session, "session.logout", params, 0, NULL, NULL);
+ xen_call_(session, "session.logout", NULL, 0, NULL, NULL);
if (session->error_description != NULL)
{
@@ -314,10 +311,7 @@ xen_session_logout(xen_session *session)
void
xen_session_local_logout(xen_session *session)
{
- abstract_value params[] =
- {
- };
- xen_call_(session, "session.local_logout", params, 0, NULL, NULL);
+ xen_call_(session, "session.local_logout", NULL, 0, NULL, NULL);
if (session->error_description != NULL)
{
@@ -336,14 +330,11 @@ xen_session_local_logout(xen_session *session)
bool
xen_session_get_all_subject_identifiers(xen_session *session, struct xen_string_set **result)
{
- abstract_value params[] =
- {
- };
abstract_type result_type = abstract_type_string_set;
*result = NULL;
- xen_call_(session, "session.get_all_subject_identifiers", params, 0, &result_type, result);
+ xen_call_(session, "session.get_all_subject_identifiers", NULL, 0, &result_type, result);
return session->ok;
}
@@ -351,14 +342,10 @@ bool
bool
xen_session_get_all_subject_identifiers_async(xen_session *session, xen_task *result)
{
- abstract_value params[] =
- {
- };
-
abstract_type result_type = abstract_type_string;
*result = NULL;
- xen_call_(session, "Async.session.get_all_subject_identifiers", params, 0, &result_type, result);
+ xen_call_(session, "Async.session.get_all_subject_identifiers", NULL, 0, &result_type, result);
return session->ok;
}
diff --git a/ocaml/sdk-gen/c/gen_c_binding.ml b/ocaml/sdk-gen/c/gen_c_binding.ml
index e9035a88c..757046ac3 100644
--- a/ocaml/sdk-gen/c/gen_c_binding.ml
+++ b/ocaml/sdk-gen/c/gen_c_binding.ml
@@ -2,7 +2,7 @@
* Copyright (c) Cloud Software Group, Inc.
*)
-(* Generator of C bindings from the datamodel *)
+(* Generator of the C SDK from the datamodel *)
open Printf
open Datamodel_types
@@ -55,31 +55,23 @@ let enum_maps = ref TypeSet.empty
let all_headers = ref []
-let joined sep f l =
- let r = List.map f l in
- String.concat sep (List.filter (fun x -> String.compare x "" != 0) r)
+let rec is_last x list =
+ match list with
+ | [] ->
+ false
+ | hd :: [] ->
+ if hd = x then true else false
+ | hd :: tl ->
+ if hd = x then false else is_last x tl
let rec main () =
- let include_dir = Filename.concat destdir "include" in
- let src_dir = Filename.concat destdir "src" in
-
- gen_failure_h () ;
- gen_failure_c () ;
-
let filtered_classes =
List.filter
(fun x -> not (List.mem x.name ["session"; "debug"; "data_source"]))
classes
in
- List.iter
- (fun x ->
- ( gen_class write_predecl predecl_filename x include_dir ;
- gen_class write_decl decl_filename x include_dir ;
- gen_class write_impl impl_filename x
- )
- src_dir
- )
- filtered_classes ;
+ List.iter gen_decl filtered_classes ;
+ List.iter gen_impl filtered_classes ;
all_headers := List.map (fun x -> x.name) filtered_classes ;
@@ -89,11 +81,12 @@ let rec main () =
maps := TypeSet.add (Map (Int, Int)) !maps ;
maps := TypeSet.add (Map (String, Set String)) !maps ;
maps := TypeSet.add (Map (String, Map (String, String))) !maps ;
- TypeSet.iter (gen_map write_map_decl decl_filename include_dir) !maps ;
- TypeSet.iter (gen_map write_map_impl impl_filename src_dir) !maps ;
+
+ TypeSet.iter (function Map (l, r) -> render_map_decl l r | _ -> ()) !maps ;
+ TypeSet.iter (function Map (l, r) -> render_map_impl l r | _ -> ()) !maps ;
TypeSet.iter
- (gen_map write_enum_map_internal_decl internal_decl_filename include_dir)
+ (function Map (l, r) -> render_enum_map l r | _ -> ())
!enum_maps ;
let class_records =
@@ -118,7 +111,10 @@ let rec main () =
json1 templates_dir destdir ;
let sorted_headers =
- List.sort String.compare (List.map decl_filename !all_headers)
+ !all_headers
+ |> List.filter (fun x -> not (Astring.String.is_suffix ~affix:"internal" x))
+ |> List.map String.lowercase_ascii
+ |> List.sort String.compare
in
let json2 =
`O
@@ -132,293 +128,305 @@ let rec main () =
("xen_all.h.mustache", "include/xen/api/xen_all.h")
json2 templates_dir destdir
-and gen_class f g clas targetdir =
- let out_chan = open_out (Filename.concat targetdir (g clas.name)) in
- Fun.protect (fun () -> f clas out_chan) ~finally:(fun () -> close_out out_chan)
-
-and gen_map f g targetdir = function
- | Map (l, r) ->
- let name = mapname l r in
- if not (List.mem name !all_headers) then
- all_headers := name :: !all_headers ;
- let out_chan = open_out (Filename.concat targetdir (g name)) in
- Fun.protect
- (fun () -> f name l r out_chan)
- ~finally:(fun () -> close_out out_chan)
- | _ ->
- assert false
-
-and write_predecl {name= classname; _} out_chan =
- let print format = fprintf out_chan format in
- let protect = protector (classname ^ "_decl") in
- let tn = typename classname in
- let record_tn = record_typename classname in
- let record_opt_tn = record_opt_typename classname in
-
- print_h_header out_chan protect ;
-
- if classname <> "event" then (
- print "typedef void *%s;\n\n" tn ;
- print "%s\n" (predecl_set tn)
- ) ;
- print "%s\n" (predecl record_tn) ;
- print "%s\n" (predecl_set record_tn) ;
- if classname <> "event" then (
- print "%s\n" (predecl record_opt_tn) ;
- print "%s\n" (predecl_set record_opt_tn)
- ) ;
- print_h_footer out_chan
-
-and write_decl {name= classname; contents; description; messages; _} out_chan =
- let print format = fprintf out_chan format in
- let protect = protector classname in
- let tn = typename classname in
- let record_tn = record_typename classname in
- let record_opt_tn = record_opt_typename classname in
- let class_has_refs = true (* !!! *) in
- let needed = ref (StringSet.add (classname ^ "_decl") StringSet.empty) in
- let record = decl_record needed tn record_tn contents in
- let record_opt = decl_record_opt tn record_tn record_opt_tn in
- let message_decls =
- decl_messages needed classname
- (List.filter
- (fun x -> not (classname = "event" && x.msg_name = "from"))
- messages
- )
- in
- let full_stop =
- if Astring.String.is_suffix ~affix:"." description then "" else "."
- in
-
- let rec get_needed x =
- match x with
+and gen_decl cls =
+ let headers = ref (StringSet.add (cls.name ^ "_decl") StringSet.empty) in
+ let rec get_needed = function
| Field fr ->
- find_needed'' needed fr.ty
+ find_needed headers fr.ty
| Namespace (_, cs) ->
List.iter get_needed cs
in
- List.iter get_needed contents ;
-
- print_h_header out_chan protect ;
- print "%s\n" (hash_includes !needed) ;
-
- print "\n\n%s\n\n\n"
- (Helper.comment false
- (sprintf "The %s class.\n\n%s%s" classname description full_stop)
- ) ;
-
- if classname <> "event" then (
- print "%s\n\n"
- (decl_free tn (String.lowercase_ascii classname) false "handle") ;
- print "%s\n" (decl_set tn false)
- ) ;
- print "%s\n" record ;
- if classname <> "event" then
- print "%s\n" record_opt ;
- print "%s\n\n" (decl_set record_tn class_has_refs) ;
- if classname <> "event" then
- print "%s\n\n" (decl_set record_opt_tn true) ;
- print "%s\n" message_decls ;
- print_h_footer out_chan
-
-and predecl_set tn = predecl (tn ^ "_set")
-
-and predecl tn = sprintf "struct %s;" tn
+ List.iter get_needed cls.contents ;
-and decl_set tn referenced =
- let alloc_com =
- Helper.comment true (sprintf "Allocate a %s_set of the given size." tn)
+ let asyncParams x =
+ if x.msg_async then
+ {
+ param_type= Ref "task"
+ ; param_name= "*result"
+ ; param_doc= ""
+ ; param_release= x.msg_release
+ ; param_default= None
+ }
+ :: x.msg_params
+ else
+ x.msg_params
in
-
- sprintf
- "\n\
- typedef struct %s_set\n\
- {\n\
- \ size_t size;\n\
- \ %s *contents[];\n\
- } %s_set;\n\n\
- %s\n\
- extern %s_set *\n\
- %s_set_alloc(size_t size);\n\n\
- %s\n"
- tn tn tn alloc_com tn tn
- (decl_free (sprintf "%s_set" tn) "*set" referenced "set")
-
-and decl_free tn cn referenced thing =
- let com =
- Helper.comment true
- (sprintf
- "Free the given %s%s. The given %s must have been allocated by this \
- library."
- tn
- (if referenced then ", and all referenced values" else "")
- thing
+ let syncParams x =
+ match x.msg_result with
+ | Some res ->
+ {
+ param_type= fst res
+ ; param_name= "*result"
+ ; param_doc= ""
+ ; param_release= x.msg_release
+ ; param_default= None
+ }
+ :: x.msg_params
+ | None ->
+ x.msg_params
+ in
+ let paramJson x =
+ `O
+ [
+ ("param_name", `String (paramname x.param_name))
+ ; ("param_type", `String (c_type_of_ty headers false x.param_type))
+ ]
+ in
+ let json =
+ `O
+ [
+ ("class_upper", `String (String.uppercase_ascii cls.name))
+ ; ("class_lower", `String (String.lowercase_ascii cls.name))
+ ; ("class_doc", `String (Helper.comment false (full_class_doc cls)))
+ ; ("is_event", `Bool (cls.name = "event"))
+ ; ( "headers"
+ , `A
+ (List.map
+ (fun x -> `O [("header", `String x)])
+ ("common" :: StringSet.elements !headers
+ |> List.map String.lowercase_ascii
+ |> List.sort String.compare
+ |> List.filter (fun x ->
+ not (Astring.String.is_suffix ~affix:"internal" x)
+ )
+ )
+ )
+ )
+ ; ( "fields"
+ , `A
+ (cls
+ |> Datamodel_utils.fields_of_obj
+ |> List.map (fun field ->
+ `O
+ [
+ ( "field_name_lower"
+ , `String (fieldname (String.concat "_" field.full_name))
+ )
+ ; ( "field_type"
+ , `String (c_type_of_ty headers true field.ty)
+ )
+ ]
+ )
+ )
+ )
+ ; ( "messages"
+ , `A
+ (cls.messages
+ |> List.filter (fun x ->
+ not (cls.name = "event" && x.msg_name = "from")
+ )
+ |> List.map (fun x ->
+ `O
+ [
+ ( "msg_name_lower"
+ , `String (String.lowercase_ascii x.msg_name)
+ )
+ ; ( "msg_doc"
+ , `String (Helper.comment true (full_msg_doc x))
+ )
+ ; ("is_async", `Bool x.msg_async)
+ ; ("sync_params", `A (List.map paramJson (syncParams x)))
+ ; ("async_params", `A (List.map paramJson (asyncParams x)))
+ ]
+ )
)
+ )
+ ]
in
+ render_file
+ ( "class_decl.h.mustache"
+ , sprintf "include/xen/api/xen_%s_decl.h" (String.lowercase_ascii cls.name)
+ )
+ json templates_dir destdir ;
+ render_file
+ ( "class.h.mustache"
+ , sprintf "include/xen/api/xen_%s.h" (String.lowercase_ascii cls.name)
+ )
+ json templates_dir destdir
- sprintf "%s\nextern void\n%s_free(%s %s);" com tn tn cn
-
-and decl_record needed tn record_tn contents =
- sprintf
- "\n\
- typedef struct %s\n\
- {\n\
- %s %s\n\
- } %s;\n\n\
- %s\n\
- extern %s *\n\
- %s_alloc(void);\n\n\
- %s\n"
- record_tn
- (if tn <> "xen_event" then sprintf " %s handle;\n" tn else "")
- (record_fields contents needed)
- record_tn
- (Helper.comment true (sprintf "Allocate a %s." record_tn))
- record_tn record_tn
- (decl_free record_tn "*record" true "record")
-
-and decl_record_opt tn record_tn record_opt_tn =
- sprintf
- "\n\
- typedef struct %s\n\
- {\n\
- \ bool is_record;\n\
- \ union\n\
- \ {\n\
- \ %s handle;\n\
- \ %s *record;\n\
- \ } u;\n\
- } %s;\n\n\
- %s\n\
- extern %s *\n\
- %s_alloc(void);\n\n\
- %s\n"
- record_opt_tn tn record_tn record_opt_tn
- (Helper.comment true (sprintf "Allocate a %s." record_opt_tn))
- record_opt_tn record_opt_tn
- (decl_free record_opt_tn "*record_opt" true "record_opt")
-
-and record_fields contents needed =
- joined "\n " (record_field needed "") contents
-
-and record_field needed prefix content =
- match content with
+and gen_impl cls =
+ let headers = ref StringSet.empty in
+ let rec get_needed = function
| Field fr ->
- sprintf "%s%s%s;"
- (c_type_of_ty needed true fr.ty)
- prefix (fieldname fr.field_name)
- | Namespace (p, c) ->
- joined "\n " (record_field needed (prefix ^ fieldname p ^ "_")) c
-
-and decl_messages needed classname messages =
- joined "\n\n" (decl_message needed classname) messages
+ find_needed headers fr.ty
+ | Namespace (_, cs) ->
+ List.iter get_needed cs
+ in
+ List.iter get_needed cls.contents ;
-and decl_message needed classname message =
- let message_sig = message_signature needed classname message in
- let messageAsyncVersion = decl_message_async needed classname message in
- sprintf "%s\n%sextern %s;\n%s"
- (get_message_comment message)
- (get_deprecated_message message)
- message_sig messageAsyncVersion
+ List.iter
+ (fun x ->
+ List.iter (fun p -> find_needed headers p.param_type) x.msg_params ;
+ match x.msg_result with
+ | Some res ->
+ find_needed headers (fst res)
+ | None ->
+ ()
+ )
+ cls.messages ;
-and decl_message_async needed classname message =
- if message.msg_async then (
- let messageSigAsync = message_signature_async needed classname message in
- needed := StringSet.add "task_decl" !needed ;
- sprintf "\n%s\n%sextern %s;\n"
- (get_message_comment message)
- (get_deprecated_message message)
- messageSigAsync
- ) else
+ let allFields = cls |> Datamodel_utils.fields_of_obj in
+ let result_type message =
+ match message.msg_result with
+ | Some res ->
+ abstract_type false (fst res)
+ | None ->
""
-
-and get_message_comment message =
- let full_stop =
- if Astring.String.is_suffix ~affix:"." message.msg_doc then "" else "."
in
- let minimum_allowed_role = get_minimum_allowed_role message in
- let content =
- sprintf "%s%s\nMinimum allowed role: %s." message.msg_doc full_stop
- minimum_allowed_role
- in
- Helper.comment true content
-
-and impl_messages needed classname messages =
- joined "\n\n" (impl_message needed classname) messages
-
-and impl_message needed classname message =
- let message_sig = message_signature needed classname message in
- let param_count = List.length message.msg_params in
-
- let param_decl, param_call =
- if param_count = 0 then
- ("", "NULL")
- else
- let param_pieces = abstract_params message.msg_params in
-
- ( sprintf
- " abstract_value param_values[] =\n\
- \ {\n\
- \ %s\n\
- \ };\n"
- param_pieces
- , "param_values"
+ let init_result message =
+ match message.msg_result with
+ | Some res -> (
+ match fst res with
+ | SecretString | String | Ref _ | Set _ | Map _ | Record _ ->
+ true
+ | _ ->
+ false
)
+ | None ->
+ false
in
-
- let result_bits =
+ let is_result_record message =
match message.msg_result with
- | Some res ->
- abstract_result_handling classname message.msg_name param_count res
+ | Some res -> (
+ match fst res with Record _ -> true | _ -> false
+ )
| None ->
- sprintf
- " xen_call_(session, \"%s.%s\", %s, %d, NULL, NULL);\n\
- \ return session->ok;\n"
- classname message.msg_name param_call param_count
+ false
in
-
- let messageAsyncImpl = impl_message_async needed classname message in
- sprintf "%s%s\n{\n%s\n%s}\n%s"
- (get_deprecated_message message)
- message_sig param_decl result_bits messageAsyncImpl
-
-and impl_message_async needed classname message =
- if message.msg_async then
- let messageSigAsync = message_signature_async needed classname message in
- let param_count = List.length message.msg_params in
-
- let param_decl, _ =
- if param_count = 0 then
- ("", "NULL")
+ let asyncParams x =
+ if x.msg_async then
+ {
+ param_type= Ref "task"
+ ; param_name= "*result"
+ ; param_doc= ""
+ ; param_release= x.msg_release
+ ; param_default= None
+ }
+ :: x.msg_params
else
- let param_pieces = abstract_params message.msg_params in
-
- ( sprintf
- " abstract_value param_values[] =\n\
- \ {\n\
- \ %s\n\
- \ };\n"
- param_pieces
- , "param_values"
+ x.msg_params
+ in
+ let syncParams x =
+ match x.msg_result with
+ | Some res ->
+ {
+ param_type= fst res
+ ; param_name= "*result"
+ ; param_doc= ""
+ ; param_release= x.msg_release
+ ; param_default= None
+ }
+ :: x.msg_params
+ | None ->
+ x.msg_params
+ in
+ let messageJson msg =
+ let paramJson p =
+ `O
+ [
+ ("param_name", `String (paramname p.param_name))
+ ; ("param_type", `String (c_type_of_ty headers false p.param_type))
+ ; ("abstract_param_type", `String (abstract_type false p.param_type))
+ ; ("abstract_member", `String (abstract_member p.param_type))
+ ; ( "abstract_member_conv"
+ , `String (abstract_param_conv p.param_name p.param_type)
)
+ ; ("is_last", `Bool (is_last p msg.msg_params))
+ ]
in
-
- let result_bits =
- abstract_result_handling_async classname message.msg_name param_count
+ `O
+ [
+ ("msg_name_lower", `String (String.lowercase_ascii msg.msg_name))
+ ; ("msg_name", `String msg.msg_name)
+ ; ("msg_doc", `String (Helper.comment true (full_msg_doc msg)))
+ ; ("is_async", `Bool msg.msg_async)
+ ; ("sync_params", `A (List.map paramJson (syncParams msg)))
+ ; ("async_params", `A (List.map paramJson (asyncParams msg)))
+ ; ("msg_params", `A (List.map paramJson msg.msg_params))
+ ; ("abstract_result_type", `String (result_type msg))
+ ; ("has_params", `Bool (List.length msg.msg_params <> 0))
+ ; ("param_count", `String (string_of_int (List.length msg.msg_params)))
+ ; ("has_result", `Bool (String.compare (result_type msg) "" <> 0))
+ ; ("init_result", `Bool (init_result msg))
+ ; ("is_result_record", `Bool (is_result_record msg))
+ ]
in
- sprintf "\n%s%s\n{\n%s\n%s}"
- (get_deprecated_message message)
- messageSigAsync param_decl result_bits
- else
- ""
+ let fieldJson field =
+ let fullName = String.concat "_" field.full_name in
+ let freeing = free_impl ("record->" ^ fieldname fullName) true field.ty in
+ `O
+ [
+ ("field_name_lower", `String (fieldname fullName))
+ ; ("field_name", `String fullName)
+ ; ("abstract_field_type", `String (abstract_type true field.ty))
+ ; ("can_free", `Bool (freeing <> ""))
+ ; ("free_record_field", `String freeing)
+ ; ("is_last", `Bool (is_last field allFields))
+ ]
+ in
+ let json =
+ `O
+ [
+ ("class_name", `String cls.name)
+ ; ("class_lower", `String (String.lowercase_ascii cls.name))
+ ; ("is_event", `Bool (cls.name = "event"))
+ ; ( "has_all_records"
+ , `Bool
+ (List.exists (fun x -> x.msg_name = "get_all_records") cls.messages)
+ )
+ ; ( "headers"
+ , `A
+ (List.map
+ (fun x -> `O [("header", `String x)])
+ (["common"; String.lowercase_ascii cls.name]
+ |> List.sort String.compare
+ )
+ )
+ )
+ ; ( "internal_headers"
+ , `A
+ (List.map
+ (fun x -> `O [("header", `String x)])
+ ("internal" :: StringSet.elements !headers
+ |> List.map String.lowercase_ascii
+ |> List.sort String.compare
+ |> List.filter (fun x ->
+ Astring.String.is_suffix ~affix:"internal" x
+ )
+ )
+ )
+ )
+ ; ("fields", `A (allFields |> List.map fieldJson))
+ ; ( "messages"
+ , `A
+ (cls.messages
+ |> List.filter (fun x ->
+ not (cls.name = "event" && x.msg_name = "from")
+ )
+ |> List.map messageJson
+ )
+ )
+ ]
+ in
+ render_file
+ ( "class.c.mustache"
+ , sprintf "src/xen_%s.c" (String.lowercase_ascii cls.name)
+ )
+ json templates_dir destdir
-and abstract_params params = joined ",\n " abstract_param params
+and full_stop x = if Astring.String.is_suffix ~affix:"." x then "" else "."
-and abstract_param p =
- let ab_typ = abstract_type false p.param_type in
- sprintf "{ .type = &%s,\n .u.%s_val = %s }" ab_typ
- (abstract_member p.param_type)
- (abstract_param_conv p.param_name p.param_type)
+and full_class_doc cls =
+ let intro = sprintf "The %s class.\n\n" cls.name in
+ intro ^ cls.description ^ full_stop cls.description
+
+and full_msg_doc message =
+ let role =
+ sprintf "\nMinimum allowed role: %s." (get_minimum_allowed_role message)
+ in
+ let deprecated = get_deprecated_info_message message in
+ let deprecated = if deprecated = "" then "" else "\n" ^ deprecated in
+ message.msg_doc ^ full_stop message.msg_doc ^ role ^ deprecated
and abstract_param_conv name = function
| Set _ | Map _ ->
@@ -441,9 +449,7 @@ and abstract_member = function
"bool"
| DateTime ->
"datetime"
- | Set _ ->
- "set"
- | Map _ ->
+ | Set _ | Map _ ->
"set"
| Record _ ->
"struct"
@@ -451,81 +457,6 @@ and abstract_member = function
eprintf "%s" (Types.to_string x) ;
assert false
-and abstract_result_handling classname msg_name param_count = function
- | typ, _ -> (
- let call =
- if param_count = 0 then
- sprintf
- "xen_call_(session, \"%s.%s\", NULL, 0, &result_type, result);"
- classname msg_name
- else
- sprintf "XEN_CALL_(\"%s.%s\");" classname msg_name
- in
-
- match typ with
- | String | Ref _ | Int | Float | Bool | DateTime | Set _ | Map _ ->
- sprintf "%s\n\n%s %s\n return session->ok;\n"
- (abstract_result_type typ) (initialiser_of_ty typ) call
- | Record n ->
- let record_tn = record_typename n in
- sprintf
- " abstract_type result_type = %s_abstract_type_;\n\n\
- %s %s\n\n\
- \ if (session->ok)\n\
- \ {\n\
- \ (*result)->handle = xen_strdup_((*result)->uuid);\n\
- \ }\n\n\
- \ return session->ok;\n"
- record_tn
- (initialiser_of_ty (Record n))
- call
- | Enum (_, _) ->
- sprintf "%s\n %s\n return session->ok;\n"
- (abstract_result_type typ) call
- | x ->
- eprintf "%s" (Types.to_string x) ;
- assert false
- )
-
-and abstract_result_handling_async classname msg_name param_count =
- let call =
- if param_count = 0 then
- sprintf
- "xen_call_(session, \"Async.%s.%s\", NULL, 0, &result_type, result);"
- classname msg_name
- else
- sprintf "XEN_CALL_(\"Async.%s.%s\");" classname msg_name
- in
- sprintf
- " abstract_type result_type = abstract_type_string;\n\n\
- \ *result = NULL;\n\
- \ %s\n\
- \ return session->ok;\n"
- call
-
-and abstract_record_field classname prefix prefix_caps content =
- match content with
- | Field fr ->
- let fn = fieldname fr.field_name in
- sprintf
- "{ .key = \"%s%s\",\n\
- \ .type = &%s,\n\
- \ .offset = offsetof(%s, %s%s) }" prefix_caps fr.field_name
- (abstract_type true fr.ty)
- (record_typename classname)
- prefix fn
- | Namespace (p, c) ->
- joined ",\n "
- (abstract_record_field classname
- (prefix ^ fieldname p ^ "_")
- (prefix_caps ^ p ^ "_")
- )
- c
-
-and abstract_result_type typ =
- let ab_typ = abstract_type false typ in
- sprintf " abstract_type result_type = %s;" ab_typ
-
and abstract_type record = function
| SecretString | String ->
"abstract_type_string"
@@ -573,87 +504,6 @@ and abstract_type record = function
| Option n ->
abstract_type record n
-and get_deprecated_message message =
- let deprecatedMessage = get_deprecated_info_message message in
- if deprecatedMessage = "" then
- sprintf ""
- else
- sprintf "/* " ^ deprecatedMessage ^ " */\n"
-
-and message_signature needed classname message =
- let front =
- {
- param_type= Ref "session"
- ; param_name= "session"
- ; param_doc= ""
- ; param_release= message.msg_release
- ; param_default= None
- }
- ::
- ( match message.msg_result with
- | Some res ->
- [
- {
- param_type= fst res
- ; param_name= "*result"
- ; param_doc= ""
- ; param_release= message.msg_release
- ; param_default= None
- }
- ]
- | None ->
- []
- )
- in
- let params = joined ", " (param needed) (front @ message.msg_params) in
- sprintf "bool\n%s(%s)" (messagename classname message.msg_name) params
-
-and message_signature_async needed classname message =
- let sessionParam =
- {
- param_type= Ref "session"
- ; param_name= "session"
- ; param_doc= ""
- ; param_release= message.msg_release
- ; param_default= None
- }
- in
- let taskParam =
- {
- param_type= Ref "task"
- ; param_name= "*result"
- ; param_doc= ""
- ; param_release= message.msg_release
- ; param_default= None
- }
- in
- let params =
- joined ", " (param needed) (sessionParam :: taskParam :: message.msg_params)
- in
- sprintf "bool\n%s(%s)" (messagename_async classname message.msg_name) params
-
-and param needed p =
- let t = p.param_type in
- let n = p.param_name in
- sprintf "%s%s" (c_type_of_ty needed false t) (paramname n)
-
-and hash_includes needed =
- String.concat "\n"
- (List.sort String.compare
- (List.filter
- (function s -> s <> "")
- (List.map hash_include ("common" :: StringSet.elements needed))
- )
- )
-
-and hash_include n =
- if Astring.String.is_suffix ~affix:"internal" n then
- sprintf "#include \"%s\"" (decl_filename n)
- else if n = "session" then
- ""
- else
- sprintf "#include <%s>" (decl_filename n)
-
and replace_dashes x =
Astring.String.map (fun y -> match y with '-' -> '_' | _ -> y) x
@@ -675,7 +525,9 @@ and render_enum x =
`O
[
("enum_value", `String n)
- ; ("enum_value_doc", `String c)
+ ; ( "enum_value_doc"
+ , `String (Helper.comment true ~indent:4 c)
+ )
; ( "enum_value_upper"
, `String (replace_dashes (String.uppercase_ascii n))
)
@@ -700,371 +552,159 @@ and render_enum x =
| _ ->
()
-and write_map_decl name l r out_chan =
- let print format = fprintf out_chan format in
- let tn = typename name in
- let protect = protector name in
- let needed = ref StringSet.empty in
- let alloc_com =
- Helper.comment true (sprintf "Allocate a %s of the given size." tn)
+and render_enum_map l r =
+ let x = mapname l r in
+ let json =
+ `O
+ [
+ ("map_upper", `String (String.uppercase_ascii x))
+ ; ("map_lower", `String (String.lowercase_ascii x))
+ ]
in
+ render_file
+ ( "xen_enum_map_internal.h.mustache"
+ , sprintf "include/xen_%s_internal.h" (String.lowercase_ascii x)
+ )
+ json templates_dir destdir
- print_h_header out_chan protect ;
- print
- "\n\
- %s%s%s\n\n\n\
- typedef struct %s_contents\n\
- {\n\
- \ %skey;\n\
- \ %sval;\n\
- } %s_contents;\n\n\n\
- typedef struct %s\n\
- {\n\
- \ size_t size;\n\
- \ %s_contents contents[];\n\
- } %s;\n\n\
- %s\n\
- extern %s *\n\
- %s_alloc(size_t size);\n\n\
- %s\n\n"
- (hash_include "common") (hash_include_enum l) (hash_include_enum r) tn
- (c_type_of_ty needed false l)
- (c_type_of_ty needed true r)
- tn tn tn tn alloc_com tn tn
- (decl_free tn "*map" true "map") ;
- print_h_footer out_chan
-
-and write_map_impl name l r out_chan =
- let print format = fprintf out_chan format in
- let tn = typename name in
- let l_free_impl = free_impl "map->contents[i].key" false l in
- let r_free_impl = free_impl "map->contents[i].val" true r in
- let needed = ref StringSet.empty in
- find_needed'' needed l ;
- find_needed'' needed r ;
- needed := StringSet.add "internal" !needed ;
- needed := StringSet.add name !needed ;
- ( match r with
- | Set String ->
- needed := StringSet.add "string_set" !needed
- | _ ->
- ()
- ) ;
-
- print
- "%s\n\n\n\
- %s\n\n\n\
- %s *\n\
- %s_alloc(size_t size)\n\
- {\n\
- \ %s *result = calloc(1, sizeof(%s) +\n\
- \ %s size * sizeof(struct %s_contents));\n\
- \ result->size = size;\n\
- \ return result;\n\
- }\n\n\n\
- void\n\
- %s_free(%s *map)\n\
- {\n"
- Licence.bsd_two_clause (hash_includes !needed) tn tn tn tn
- (String.make (String.length tn) ' ')
- tn tn tn ;
-
- if String.compare l_free_impl "" != 0 || String.compare r_free_impl "" != 0
- then
- print
- " if (map == NULL)\n\
- \ {\n\
- \ return;\n\
- \ }\n\n\
- \ size_t n = map->size;\n\
- \ for (size_t i = 0; i < n; i++)\n\
- \ {\n\
- \ %s\n\
- \ %s\n\
- \ }\n\n"
- l_free_impl r_free_impl ;
-
- print " free(map);\n}\n" ;
-
- match (l, r) with
- | Enum (_, _), _ ->
- gen_enum_map_abstract_type print l r
- | _, Enum (_, _) ->
- gen_enum_map_abstract_type print l r
- | _ ->
- ()
-
-and gen_enum_map_abstract_type print l r =
- let tn = mapname l r in
- print
- "\n\n\
- static const struct_member %s_struct_members[] =\n\
- \ {\n\
- \ { .type = &%s,\n\
- \ .offset = offsetof(xen_%s_contents, key) },\n\
- \ { .type = &%s,\n\
- \ .offset = offsetof(xen_%s_contents, val) },\n\
- \ };\n\n\
- const abstract_type %s_abstract_type_ =\n\
- \ {\n\
- \ .XEN_API_TYPE = MAP,\n\
- \ .struct_size = sizeof(%s_struct_members),\n\
- \ .member_count =\n\
- \ sizeof(%s_struct_members) / sizeof(struct_member),\n\
- \ .members = %s_struct_members\n\
- \ };\n"
- tn (abstract_type false l) tn (abstract_type false r) tn tn tn tn tn
-
-and write_enum_map_internal_decl name l r out_chan =
- let print format = fprintf out_chan format in
- let protect = protector (sprintf "%s_internal" name) in
-
- print_h_header out_chan protect ;
- print "\nextern const abstract_type %s_abstract_type_;\n\n" (mapname l r) ;
- print_h_footer out_chan
-
-and hash_include_enum = function
+and render_map_decl l r =
+ let headers = ref StringSet.empty in
+ let add_enum_header = function
| Enum (x, _) ->
- "\n" ^ hash_include x
+ headers := StringSet.add x !headers
| _ ->
- ""
-
-and gen_failure_h () =
- let protect = protector "api_failure" in
- let out_chan =
- open_out (Filename.concat destdir "include/xen/api/xen_api_failure.h")
+ ()
+ in
+ add_enum_header l ;
+ add_enum_header r ;
+ let x = mapname l r in
+ let json =
+ `O
+ [
+ ("key_type_lower", `String (c_type_of_ty headers false l))
+ ; ("val_type_lower", `String (c_type_of_ty headers true r))
+ ; ("map_upper", `String (String.uppercase_ascii x))
+ ; ("map_lower", `String (String.lowercase_ascii x))
+ ; ( "headers"
+ , `A
+ (List.map
+ (fun x -> `O [("header", `String x)])
+ ("common" :: StringSet.elements !headers
+ |> List.map String.lowercase_ascii
+ |> List.sort String.compare
+ |> List.filter (fun x ->
+ not (Astring.String.is_suffix ~affix:"internal" x)
+ )
+ )
+ )
+ )
+ ]
in
- Fun.protect
- (fun () ->
- print_h_header out_chan protect ;
- gen_failure_enum out_chan ;
- gen_failure_funcs out_chan ;
- print_h_footer out_chan
+ if not (List.mem x !all_headers) then all_headers := x :: !all_headers ;
+ render_file
+ ( "map.h.mustache"
+ , sprintf "include/xen/api/xen_%s.h" (String.lowercase_ascii x)
)
- ~finally:(fun () -> close_out out_chan)
+ json templates_dir destdir
-and gen_failure_enum out_chan =
- let print format = fprintf out_chan format in
- print "\nenum xen_api_failure\n{\n%s\n};\n\n\n"
- (String.concat ",\n\n" (failure_enum_entries ()))
+and render_map_impl l r =
+ let x = mapname l r in
+ let headers = ref StringSet.empty in
+ headers := StringSet.add x !headers ;
+ find_needed headers l ;
+ find_needed headers r ;
-and failure_enum_entries () =
- let r = Hashtbl.fold failure_enum_entry Datamodel.errors [] in
- let r = List.sort (fun (x, _) (y, _) -> String.compare y x) r in
- let r =
- failure_enum_entry "UNDEFINED"
- {
- err_doc= "Unknown to this version of the bindings."
- ; err_params= []
- ; err_name= "UNDEFINED"
- }
- r
+ let l_free_impl = free_impl "map->contents[i].key" false l in
+ let r_free_impl = free_impl "map->contents[i].val" true r in
+ let is_enum_map =
+ match (l, r) with Enum (_, _), _ | _, Enum (_, _) -> true | _ -> false
in
- List.map (fun (_, y) -> y) (List.rev r)
-
-and failure_enum_entry name err acc =
- ( name
- , sprintf "%s\n %s"
- (Helper.comment true ~indent:4 err.Datamodel_types.err_doc)
- (failure_enum name)
+ let json =
+ `O
+ [
+ ("abstract_type_key", `String (abstract_type false l))
+ ; ("abstract_type_val", `String (abstract_type false r))
+ ; ("map_upper", `String (String.uppercase_ascii x))
+ ; ("map_lower", `String (String.lowercase_ascii x))
+ ; ( "headers"
+ , `A
+ (List.map
+ (fun x -> `O [("header", `String x)])
+ ("common" :: StringSet.elements !headers
+ |> List.map String.lowercase_ascii
+ |> List.sort String.compare
+ |> List.filter (fun x ->
+ not (Astring.String.is_suffix ~affix:"internal" x)
)
- :: acc
-
-and gen_failure_funcs out_chan =
- let print format = fprintf out_chan format in
- print
- "%s\n\
- extern const char *\n\
- xen_api_failure_to_string(enum xen_api_failure val);\n\n\n\
- %s\n\
- extern enum xen_api_failure\n\
- xen_api_failure_from_string(const char *str);\n\n"
- (Helper.comment true
- "Return the name corresponding to the given code. This string must not \
- be modified or freed."
)
- (Helper.comment true
- "Return the correct code for the given string, or UNDEFINED if the \
- given string does not match a known code."
)
-
-and gen_failure_c () =
- let out_chan = open_out (Filename.concat destdir "src/xen_api_failure.c") in
- let print format = fprintf out_chan format in
- Fun.protect
- (fun () ->
- print
- "%s\n\n\
- #include \"xen_internal.h\"\n\
- #include <xen/api/xen_api_failure.h>\n\n\n\
- /*\n\
- \ * Maintain this in the same order as the enum declaration!\n\
- \ */\n\
- static const char *lookup_table[] =\n\
- {\n\
- \ %s\n\
- };\n\n\n\
- const char *\n\
- xen_api_failure_to_string(enum xen_api_failure val)\n\
- {\n\
- \ return lookup_table[val];\n\
- }\n\n\n\
- extern enum xen_api_failure\n\
- xen_api_failure_from_string(const char *str)\n\
- {\n\
- \ return ENUM_LOOKUP(str, lookup_table);\n\
- }\n\n\n"
- Licence.bsd_two_clause
- (String.concat ",\n " (failure_lookup_entries ()))
)
- ~finally:(fun () -> close_out out_chan)
-
-and failure_lookup_entries () =
- List.sort String.compare
- (Hashtbl.fold failure_lookup_entry Datamodel.errors [])
-
-and failure_lookup_entry name _ acc = sprintf "\"%s\"" name :: acc
-
-and failure_enum name = "XEN_API_FAILURE_" ^ String.uppercase_ascii name
-
-and write_impl {name= classname; contents; messages; _} out_chan =
- let is_event = classname = "event" in
- let print format = fprintf out_chan format in
- let needed = ref StringSet.empty in
- let tn = typename classname in
- let record_tn = record_typename classname in
- let record_opt_tn = record_opt_typename classname in
- let msgs =
- impl_messages needed classname
- (List.filter
- (fun x -> not (classname = "event" && x.msg_name = "from"))
- messages
+ ; ( "internal_headers"
+ , `A
+ (List.map
+ (fun x -> `O [("header", `String x)])
+ ("internal" :: StringSet.elements !headers
+ |> List.map String.lowercase_ascii
+ |> List.sort String.compare
+ |> List.filter (fun x ->
+ Astring.String.is_suffix ~affix:"internal" x
)
+ )
+ )
+ )
+ ; ("can_free_key", `Bool (String.compare l_free_impl "" != 0))
+ ; ("can_free_val", `Bool (String.compare r_free_impl "" != 0))
+ ; ( "can_free"
+ , `Bool
+ (String.compare l_free_impl "" != 0
+ || String.compare r_free_impl "" != 0
+ )
+ )
+ ; ("free_key", `String l_free_impl)
+ ; ("free_val", `String r_free_impl)
+ ; ("enum_map", `Bool is_enum_map)
+ ]
in
- let record_free_handle =
- if classname = "event" then "" else " free(record->handle);\n"
- in
- let record_free_impls =
- joined "\n " (record_free_impl "record->") contents
- in
- let filtered_record_fields =
- let not_obj_uuid x =
- match x with Field r when r.field_name = "obj_uuid" -> false | _ -> true
- in
- if is_event then List.filter not_obj_uuid contents else contents
- in
- let record_fields =
- joined ",\n "
- (abstract_record_field classname "" "")
- filtered_record_fields
- in
- let needed = ref StringSet.empty in
- find_needed needed messages ;
- needed := StringSet.add "internal" !needed ;
- needed := StringSet.add classname !needed ;
-
- let getAllRecordsExists =
- List.exists (fun x -> x.msg_name = "get_all_records") messages
- in
- let mappingName = sprintf "%s_%s" tn record_tn in
+ if not (List.mem x !all_headers) then all_headers := x :: !all_headers ;
+ render_file
+ ("map.c.mustache", sprintf "src/xen_%s.c" (String.lowercase_ascii x))
+ json templates_dir destdir
- let free_block =
- String.concat "\n"
- (( if is_event then
- []
- else
- [sprintf "XEN_FREE(%s)" tn; sprintf "XEN_SET_ALLOC_FREE(%s)" tn]
+and gen_failure () =
+ let errors =
+ Hashtbl.fold
+ (fun _ x acc ->
+ (x.Datamodel_types.err_name, x.Datamodel_types.err_doc) :: acc
)
- @ [
- sprintf "XEN_ALLOC(%s)" record_tn
- ; sprintf "XEN_SET_ALLOC_FREE(%s)" record_tn
- ]
- @
- if is_event then
- []
- else
+ Datamodel.errors []
+ in
+ let errors = List.sort (fun (x, _) (y, _) -> String.compare x y) errors in
+ let json =
+ `O
+ [
+ ( "api_errors"
+ , `A
+ (List.map
+ (fun (x, y) ->
+ `O
[
- sprintf "XEN_ALLOC(%s)" record_opt_tn
- ; sprintf "XEN_RECORD_OPT_FREE(%s)" tn
- ; sprintf "XEN_SET_ALLOC_FREE(%s)" record_opt_tn
+ ("api_error", `String (String.uppercase_ascii x))
+ ; ("api_error_doc", `String (Helper.comment true ~indent:4 y))
]
)
+ errors
+ )
+ )
+ ]
in
+ render_file
+ ("xen_api_failure.h.mustache", "include/xen/api/xen_api_failure.h")
+ json templates_dir destdir ;
+ render_file
+ ("xen_api_failure.c.mustache", "src/xen_api_failure.c")
+ json templates_dir destdir
- print "%s\n\n\n#include <stddef.h>\n#include <stdlib.h>\n\n%s\n\n\n%s\n\n\n"
- Licence.bsd_two_clause (hash_includes !needed) free_block ;
-
- print
- "static const struct_member %s_struct_members[] =\n\
- \ {\n\
- \ %s\n\
- \ };\n\n\
- const abstract_type %s_abstract_type_ =\n\
- \ {\n\
- \ .XEN_API_TYPE = STRUCT,\n\
- \ .struct_size = sizeof(%s),\n\
- \ .member_count =\n\
- \ sizeof(%s_struct_members) / sizeof(struct_member),\n\
- \ .members = %s_struct_members\n\
- \ };\n\n\n"
- record_tn record_fields record_tn record_tn record_tn record_tn ;
-
- print
- "const abstract_type %s_set_abstract_type_ =\n\
- \ {\n\
- \ .XEN_API_TYPE = SET,\n\
- \ .child = &%s_abstract_type_\n\
- \ };\n\n\n"
- record_tn record_tn ;
-
- if getAllRecordsExists then
- print
- "static const struct struct_member %s_members[] =\n\
- {\n\
- \ {\n\
- \ .type = &abstract_type_string,\n\
- \ .offset = offsetof(%s_map_contents, key)\n\
- \ },\n\
- \ {\n\
- \ .type = &%s_abstract_type_,\n\
- \ .offset = offsetof(%s_map_contents, val)\n\
- \ }\n\
- };\n\n\
- const abstract_type abstract_type_string_%s_map =\n\
- {\n\
- \ .XEN_API_TYPE = MAP,\n\
- \ .struct_size = sizeof(%s_map_contents),\n\
- \ .members = %s_members\n\
- };\n\n\n"
- mappingName mappingName record_tn mappingName record_tn mappingName
- mappingName ;
-
- print
- "void\n\
- %s_free(%s *record)\n\
- {\n\
- \ if (record == NULL)\n\
- \ {\n\
- \ return;\n\
- \ }\n\
- %s %s\n\
- \ free(record);\n\
- }\n\n\n"
- record_tn record_tn record_free_handle record_free_impls ;
-
- print "%s\n" msgs
-
-and find_needed needed messages = List.iter (find_needed' needed) messages
-
-and find_needed' needed message =
- List.iter (fun p -> find_needed'' needed p.param_type) message.msg_params ;
- match message.msg_result with
- | Some (x, _) ->
- find_needed'' needed x
- | None ->
- ()
-
-and find_needed'' needed = function
+and find_needed needed = function
| SecretString | String | Int | Float | Bool | DateTime ->
()
| Enum (n, _) ->
@@ -1089,13 +729,7 @@ and find_needed'' needed = function
| Record n ->
needed := StringSet.add n !needed
| Option x ->
- find_needed'' needed x
-
-and record_free_impl prefix = function
- | Field fr ->
- free_impl (prefix ^ fieldname fr.field_name) true fr.ty
- | Namespace (p, c) ->
- joined "\n " (record_free_impl (prefix ^ fieldname p ^ "_")) c
+ find_needed needed x
and free_impl val_name record = function
| SecretString | String ->
@@ -1165,7 +799,7 @@ and c_type_of_ty needed record = function
| Enum (name, _) as x ->
needed := StringSet.add name !needed ;
enums := TypeSet.add x !enums ;
- c_type_of_enum name
+ sprintf "enum %s " (typename name)
| Set (Ref name) ->
needed := StringSet.add (name ^ "_decl") !needed ;
if record then
@@ -1218,23 +852,13 @@ and c_type_of_ty needed record = function
| Option (Enum (name, _) as x) ->
needed := StringSet.add name !needed ;
enums := TypeSet.add x !enums ;
- c_type_of_enum name ^ " *"
+ sprintf "enum %s *" (typename name)
| Option n ->
c_type_of_ty needed record n
| x ->
eprintf "%s" (Types.to_string x) ;
assert false
-and c_type_of_enum name = sprintf "enum %s " (typename name)
-
-and initialiser_of_ty = function
- | SecretString | String | Ref _ | Set _ | Map _ | Record _ ->
- " *result = NULL;\n"
- | _ ->
- ""
-
-and mapname l r = sprintf "%s_%s_map" (name_of_ty l) (name_of_ty r)
-
and name_of_ty = function
| SecretString | String ->
"string"
@@ -1260,21 +884,7 @@ and name_of_ty = function
eprintf "%s" (Types.to_string x) ;
assert false
-and decl_filename name =
- let dir =
- if Astring.String.is_suffix ~affix:"internal" name then "" else "xen/api/"
- in
- sprintf "%sxen_%s.h" dir (String.lowercase_ascii name)
-
-and predecl_filename name =
- sprintf "xen/api/xen_%s_decl.h" (String.lowercase_ascii name)
-
-and internal_decl_filename name =
- sprintf "xen_%s_internal.h" (String.lowercase_ascii name)
-
-and impl_filename name = sprintf "xen_%s.c" (String.lowercase_ascii name)
-
-and protector classname = sprintf "XEN_%s_H" (String.uppercase_ascii classname)
+and mapname l r = sprintf "%s_%s_map" (name_of_ty l) (name_of_ty r)
and typename classname = sprintf "xen_%s" (String.lowercase_ascii classname)
@@ -1282,16 +892,6 @@ and record_typename classname = sprintf "%s_record" (typename classname)
and record_opt_typename classname = sprintf "%s_record_opt" (typename classname)
-and messagename classname name =
- sprintf "xen_%s_%s"
- (String.lowercase_ascii classname)
- (String.lowercase_ascii name)
-
-and messagename_async classname name =
- sprintf "xen_%s_%s_async"
- (String.lowercase_ascii classname)
- (String.lowercase_ascii name)
-
and keyword_map name =
let keywords = [("class", "XEN_CLAZZ"); ("public", "pubblic")] in
if List.mem_assoc name keywords then List.assoc name keywords else name
@@ -1300,14 +900,6 @@ and paramname name = keyword_map (String.lowercase_ascii name)
and fieldname name = keyword_map (String.lowercase_ascii name)
-and print_h_header out_chan protect =
- let print format = fprintf out_chan format in
- print "%s\n\n" Licence.bsd_two_clause ;
- print "#ifndef %s\n" protect ;
- print "#define %s\n\n" protect
-
-and print_h_footer out_chan = fprintf out_chan "\n#endif\n"
-
and populate_version () =
List.iter
(fun x -> render_file x json_releases templates_dir destdir)
@@ -1317,4 +909,4 @@ and populate_version () =
; ("xen_api_version.c.mustache", "src/xen_api_version.c")
]
-let _ = main () ; populate_version ()
+let _ = main () ; gen_failure () ; populate_version ()
diff --git a/ocaml/sdk-gen/c/templates/Makefile.mustache b/ocaml/sdk-gen/c/templates/Makefile.mustache
index 384ffcb17..ac78e5ca1 100644
--- a/ocaml/sdk-gen/c/templates/Makefile.mustache
+++ b/ocaml/sdk-gen/c/templates/Makefile.mustache
@@ -29,7 +29,9 @@
DESTDIR=/usr/local
-ifeq ($(CYGWIN), 1)
+UNAME_S := $(shell uname -s)
+
+ifeq ($(findstring CYGWIN,$(UNAME_S)),CYGWIN)
CYGWIN_LIBXML = -L/bin -lxml2-2
POS_FLAG = -U__STRICT_ANSI__
else
@@ -80,7 +82,7 @@ install: build
$(INSTALL_DATA) libxenserver.so.{{API_VERSION_MAJOR}}.{{API_VERSION_MINOR}} $(DESTDIR)/lib
ln -sf libxenserver.so.{{API_VERSION_MAJOR}}.{{API_VERSION_MINOR}} $(DESTDIR)/lib/libxenserver.so.{{API_VERSION_MAJOR}}
ln -sf libxenserver.so.{{API_VERSION_MAJOR}} $(DESTDIR)/lib/libxenserver.so
-ifeq ($(CYGWIN), 1)
+ifeq ($(findstring CYGWIN,$(UNAME_S)),CYGWIN)
ln -sf libxenserver.so $(DESTDIR)/lib/libxenserver.dll
endif
$(INSTALL_DATA) libxenserver.a $(DESTDIR)/lib
@@ -95,3 +97,4 @@ clean:
.PHONY: clean build install
.DEFAULT_GOAL := build
+
diff --git a/ocaml/sdk-gen/c/templates/class.c.mustache b/ocaml/sdk-gen/c/templates/class.c.mustache
new file mode 100644
index 000000000..55f6da267
--- /dev/null
+++ b/ocaml/sdk-gen/c/templates/class.c.mustache
@@ -0,0 +1,192 @@
+/*
+ * Copyright (c) Cloud Software Group, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1) Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2) Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following
+ * disclaimer in the documentation and/or other materials
+ * provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+ * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+
+#include <stddef.h>
+#include <stdlib.h>
+
+{{#internal_headers}}
+#include "xen_{{header}}.h"
+{{/internal_headers}}
+{{#headers}}
+#include <xen/api/xen_{{{header}}}.h>
+{{/headers}}
+
+
+{{^is_event}}
+XEN_FREE(xen_{{{class_lower}}})
+XEN_SET_ALLOC_FREE(xen_{{{class_lower}}})
+{{/is_event}}
+XEN_ALLOC(xen_{{{class_lower}}}_record)
+XEN_SET_ALLOC_FREE(xen_{{{class_lower}}}_record)
+{{^is_event}}
+XEN_ALLOC(xen_{{{class_lower}}}_record_opt)
+XEN_RECORD_OPT_FREE(xen_{{{class_lower}}})
+XEN_SET_ALLOC_FREE(xen_{{{class_lower}}}_record_opt)
+{{/is_event}}
+
+
+static const struct_member xen_{{{class_lower}}}_record_struct_members[] =
+ {
+{{#fields}}
+ { .key = "{{{field_name}}}",
+ .type = &{{{abstract_field_type}}},
+ .offset = offsetof(xen_{{{class_lower}}}_record, {{{field_name_lower}}}) }{{^is_last}},{{/is_last}}
+{{/fields}}
+ };
+
+
+const abstract_type xen_{{{class_lower}}}_record_abstract_type_ =
+ {
+ .XEN_API_TYPE = STRUCT,
+ .struct_size = sizeof(xen_{{{class_lower}}}_record),
+ .member_count =
+ sizeof(xen_{{{class_lower}}}_record_struct_members) / sizeof(struct_member),
+ .members = xen_{{{class_lower}}}_record_struct_members
+ };
+
+
+const abstract_type xen_{{{class_lower}}}_record_set_abstract_type_ =
+ {
+ .XEN_API_TYPE = SET,
+ .child = &xen_{{{class_lower}}}_record_abstract_type_
+ };
+{{#has_all_records}}
+
+
+static const struct struct_member xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_members[] =
+{
+ {
+ .type = &abstract_type_string,
+ .offset = offsetof(xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_map_contents, key)
+ },
+ {
+ .type = &xen_{{{class_lower}}}_record_abstract_type_,
+ .offset = offsetof(xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_map_contents, val)
+ }
+};
+
+
+const abstract_type abstract_type_string_xen_{{{class_lower}}}_record_map =
+{
+ .XEN_API_TYPE = MAP,
+ .struct_size = sizeof(xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_map_contents),
+ .members = xen_{{{class_lower}}}_xen_{{{class_lower}}}_record_members
+};
+{{/has_all_records}}
+
+
+void
+xen_{{{class_lower}}}_record_free(xen_{{{class_lower}}}_record *record)
+{
+ if (record == NULL)
+ return;
+
+{{^is_event}}
+ free(record->handle);
+{{/is_event}}
+{{#fields}}
+{{#can_free}}
+ {{{free_record_field}}}
+{{/can_free}}
+{{/fields}}
+ free(record);
+}
+{{#messages}}
+
+
+bool
+xen_{{{class_lower}}}_{{{msg_name_lower}}}(xen_session *session{{#sync_params}}, {{{param_type}}}{{{param_name}}}{{/sync_params}})
+{
+{{#has_params}}
+ abstract_value param_values[] =
+ {
+{{#msg_params}}
+ { .type = &{{{abstract_param_type}}},
+ .u.{{{abstract_member}}}_val = {{{abstract_member_conv}}} }{{^is_last}},{{/is_last}}
+{{/msg_params}}
+ };
+{{/has_params}}
+{{#has_result}}
+
+ abstract_type result_type = {{{abstract_result_type}}};
+{{/has_result}}
+
+{{#init_result}}
+ *result = NULL;
+{{/init_result}}
+{{#has_result}}
+{{#has_params}}
+ XEN_CALL_("{{{class_name}}}.{{{msg_name}}}");
+{{/has_params}}
+{{^has_params}}
+ xen_call_(session, "{{{class_name}}}.{{{msg_name}}}", NULL, 0, &result_type, result);
+{{/has_params}}
+{{/has_result}}
+{{^has_result}}
+ xen_call_(session, "{{{class_name}}}.{{{msg_name}}}", {{#has_params}}param_values{{/has_params}}{{^has_params}}NULL{{/has_params}}, {{param_count}}, NULL, NULL);
+{{/has_result}}
+{{#is_result_record}}
+
+ if (session->ok)
+ (*result)->handle = xen_strdup_((*result)->uuid);
+
+{{/is_result_record}}
+ return session->ok;
+}
+{{#is_async}}
+
+
+bool
+xen_{{{class_lower}}}_{{{msg_name_lower}}}_async(xen_session *session{{#async_params}}, {{{param_type}}}{{{param_name}}}{{/async_params}})
+{
+{{#has_params}}
+ abstract_value param_values[] =
+ {
+{{#msg_params}}
+ { .type = &{{{abstract_param_type}}},
+ .u.{{{abstract_member}}}_val = {{{abstract_member_conv}}} }{{^is_last}},{{/is_last}}
+{{/msg_params}}
+ };
+{{/has_params}}
+
+ abstract_type result_type = abstract_type_string;
+
+ *result = NULL;
+{{#has_params}}
+ XEN_CALL_("Async.{{{class_name}}}.{{{msg_name}}}");
+{{/has_params}}
+{{^has_params}}
+ xen_call_(session, "Async.{{{class_name}}}.{{{msg_name}}}", NULL, 0, &result_type, result);
+{{/has_params}}
+ return session->ok;
+}
+{{/is_async}}
+{{/messages}}
+
diff --git a/ocaml/sdk-gen/c/templates/class.h.mustache b/ocaml/sdk-gen/c/templates/class.h.mustache
new file mode 100644
index 000000000..98dd1f374
--- /dev/null
+++ b/ocaml/sdk-gen/c/templates/class.h.mustache
@@ -0,0 +1,179 @@
+/*
+ * Copyright (c) Cloud Software Group, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1) Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2) Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following
+ * disclaimer in the documentation and/or other materials
+ * provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+ * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+
+#ifndef XEN_{{{class_upper}}}_H
+#define XEN_{{{class_upper}}}_H
+
+{{#headers}}
+#include <xen/api/xen_{{{header}}}.h>
+{{/headers}}
+
+
+{{{class_doc}}}
+
+
+{{^is_event}}
+/**
+ * Free the given xen_{{{class_lower}}}. The given handle must have been
+ * allocated by this library.
+ */
+extern void
+xen_{{{class_lower}}}_free(xen_{{{class_lower}}} {{{class_lower}}});
+
+
+typedef struct xen_{{{class_lower}}}_set
+{
+ size_t size;
+ xen_{{{class_lower}}} *contents[];
+} xen_{{{class_lower}}}_set;
+
+/**
+ * Allocate a xen_{{{class_lower}}}_set of the given size.
+ */
+extern xen_{{{class_lower}}}_set *
+xen_{{{class_lower}}}_set_alloc(size_t size);
+
+/**
+ * Free the given xen_{{{class_lower}}}_set. The given set must have been
+ * allocated by this library.
+ */
+extern void
+xen_{{{class_lower}}}_set_free(xen_{{{class_lower}}}_set *set);
+
+
+{{/is_event}}
+typedef struct xen_{{{class_lower}}}_record
+{
+{{^is_event}}
+ xen_{{{class_lower}}} handle;
+{{/is_event}}
+{{#fields}}
+ {{{field_type}}}{{{field_name_lower}}};
+{{/fields}}
+} xen_{{{class_lower}}}_record;
+
+/**
+ * Allocate a xen_{{{class_lower}}}_record.
+ */
+extern xen_{{{class_lower}}}_record *
+xen_{{{class_lower}}}_record_alloc(void);
+
+/**
+ * Free the given xen_{{{class_lower}}}_record, and all referenced values.
+ * The given record must have been allocated by this library.
+ */
+extern void
+xen_{{{class_lower}}}_record_free(xen_{{{class_lower}}}_record *record);
+
+
+{{^is_event}}
+typedef struct xen_{{{class_lower}}}_record_opt
+{
+ bool is_record;
+ union
+ {
+ xen_{{{class_lower}}} handle;
+ xen_{{{class_lower}}}_record *record;
+ } u;
+} xen_{{{class_lower}}}_record_opt;
+
+/**
+ * Allocate a xen_{{{class_lower}}}_record_opt.
+ */
+extern xen_{{{class_lower}}}_record_opt *
+xen_{{{class_lower}}}_record_opt_alloc(void);
+
+/**
+ * Free the given xen_{{{class_lower}}}_record_opt, and all referenced values.
+ * The given record_opt must have been allocated by this library.
+ */
+extern void
+xen_{{{class_lower}}}_record_opt_free(xen_{{{class_lower}}}_record_opt *record_opt);
+
+
+{{/is_event}}
+typedef struct xen_{{{class_lower}}}_record_set
+{
+ size_t size;
+ xen_{{{class_lower}}}_record *contents[];
+} xen_{{{class_lower}}}_record_set;
+
+/**
+ * Allocate a xen_{{{class_lower}}}_record_set of the given size.
+ */
+extern xen_{{{class_lower}}}_record_set *
+xen_{{{class_lower}}}_record_set_alloc(size_t size);
+
+/**
+ * Free the given xen_{{{class_lower}}}_record_set, and all referenced values.
+ * The given set must have been allocated by this library.
+ */
+extern void
+xen_{{{class_lower}}}_record_set_free(xen_{{{class_lower}}}_record_set *set);
+
+
+{{^is_event}}
+typedef struct xen_{{{class_lower}}}_record_opt_set
+{
+ size_t size;
+ xen_{{{class_lower}}}_record_opt *contents[];
+} xen_{{{class_lower}}}_record_opt_set;
+
+/**
+ * Allocate a xen_{{{class_lower}}}_record_opt_set of the given size.
+ */
+extern xen_{{{class_lower}}}_record_opt_set *
+xen_{{{class_lower}}}_record_opt_set_alloc(size_t size);
+
+/**
+ * Free the given xen_{{{class_lower}}}_record_opt_set, and all referenced
+ * values. The given set must have been allocated by this library.
+ */
+extern void
+xen_{{{class_lower}}}_record_opt_set_free(xen_{{{class_lower}}}_record_opt_set *set);
+
+
+{{/is_event}}
+{{#messages}}
+{{{msg_doc}}}
+extern bool
+xen_{{{class_lower}}}_{{{msg_name_lower}}}(xen_session *session{{#sync_params}}, {{{param_type}}}{{{param_name}}}{{/sync_params}});
+
+
+{{#is_async}}
+{{{msg_doc}}}
+extern bool
+xen_{{{class_lower}}}_{{{msg_name_lower}}}_async(xen_session *session{{#async_params}}, {{{param_type}}}{{{param_name}}}{{/async_params}});
+
+
+{{/is_async}}
+{{/messages}}
+#endif
+
diff --git a/ocaml/sdk-gen/c/templates/class_decl.h.mustache b/ocaml/sdk-gen/c/templates/class_decl.h.mustache
new file mode 100644
index 000000000..521d3d49d
--- /dev/null
+++ b/ocaml/sdk-gen/c/templates/class_decl.h.mustache
@@ -0,0 +1,47 @@
+/*
+ * Copyright (c) Cloud Software Group, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1) Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2) Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following
+ * disclaimer in the documentation and/or other materials
+ * provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+ * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+
+#ifndef XEN_{{{class_upper}}}_DECL_H
+#define XEN_{{{class_upper}}}_DECL_H
+
+{{^is_event}}
+typedef void *xen_{{{class_lower}}};
+
+struct xen_{{{class_lower}}}_set;
+{{/is_event}}
+struct xen_{{{class_lower}}}_record;
+struct xen_{{{class_lower}}}_record_set;
+{{^is_event}}
+struct xen_{{{class_lower}}}_record_opt;
+struct xen_{{{class_lower}}}_record_opt_set;
+{{/is_event}}
+
+#endif
+
diff --git a/ocaml/sdk-gen/c/templates/map.c.mustache b/ocaml/sdk-gen/c/templates/map.c.mustache
new file mode 100644
index 000000000..0b944b35a
--- /dev/null
+++ b/ocaml/sdk-gen/c/templates/map.c.mustache
@@ -0,0 +1,92 @@
+/*
+ * Copyright (c) Cloud Software Group, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1) Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2) Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following
+ * disclaimer in the documentation and/or other materials
+ * provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+ * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+
+{{#internal_headers}}
+#include "xen_{{{header}}}.h"
+{{/internal_headers}}
+{{#headers}}
+#include <xen/api/xen_{{{header}}}.h>
+{{/headers}}
+
+
+xen_{{{map_lower}}} *
+xen_{{{map_lower}}}_alloc(size_t size)
+{
+ xen_{{{map_lower}}} *result =
+ calloc(1, sizeof(xen_{{{map_lower}}}) +
+ size * sizeof(struct xen_{{{map_lower}}}_contents));
+ result->size = size;
+ return result;
+}
+
+
+void
+xen_{{{map_lower}}}_free(xen_{{{map_lower}}} *map)
+{
+{{#can_free}}
+ if (map == NULL)
+ return;
+
+ size_t n = map->size;
+ for (size_t i = 0; i < n; i++)
+ {
+{{#can_free_key}}
+ {{{free_key}}}
+{{/can_free_key}}
+{{#can_free_val}}
+ {{{free_val}}}
+{{/can_free_val}}
+ }
+
+{{/can_free}}
+ free(map);
+}
+{{#enum_map}}
+
+
+static const struct_member {{{map_lower}}}_struct_members[] =
+ {
+ { .type = &{{{abstract_type_key}}},
+ .offset = offsetof(xen_{{{map_lower}}}_contents, key) },
+ { .type = &{{{abstract_type_val}}},
+ .offset = offsetof(xen_{{{map_lower}}}_contents, val) },
+ };
+
+
+const abstract_type {{{map_lower}}}_abstract_type_ =
+ {
+ .XEN_API_TYPE = MAP,
+ .struct_size = sizeof({{{map_lower}}}_struct_members),
+ .member_count =
+ sizeof({{{map_lower}}}_struct_members) / sizeof(struct_member),
+ .members = {{{map_lower}}}_struct_members
+ };
+{{/enum_map}}
+
diff --git a/ocaml/sdk-gen/c/templates/map.h.mustache b/ocaml/sdk-gen/c/templates/map.h.mustache
new file mode 100644
index 000000000..aa7c96bf5
--- /dev/null
+++ b/ocaml/sdk-gen/c/templates/map.h.mustache
@@ -0,0 +1,68 @@
+/*
+ * Copyright (c) Cloud Software Group, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1) Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2) Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following
+ * disclaimer in the documentation and/or other materials
+ * provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+ * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+
+#ifndef XEN_{{{map_upper}}}_H
+#define XEN_{{{map_upper}}}_H
+
+
+{{#headers}}
+#include <xen/api/xen_{{{header}}}.h>
+{{/headers}}
+
+
+typedef struct xen_{{{map_lower}}}_contents
+{
+ {{{key_type_lower}}}key;
+ {{{val_type_lower}}}val;
+} xen_{{{map_lower}}}_contents;
+
+
+typedef struct xen_{{{map_lower}}}
+{
+ size_t size;
+ xen_{{{map_lower}}}_contents contents[];
+} xen_{{{map_lower}}};
+
+/**
+ * Allocate a xen_{{{map_lower}}} of the given size.
+ */
+extern xen_{{{map_lower}}} *
+xen_{{{map_lower}}}_alloc(size_t size);
+
+/**
+ * Free the given xen_{{{map_lower}}}
+ * and all referenced values. The map must have been allocated by this library.
+ */
+extern void
+xen_{{{map_lower}}}_free(xen_{{{map_lower}}} *map);
+
+
+#endif
+
diff --git a/ocaml/sdk-gen/c/templates/xen_all.h.mustache b/ocaml/sdk-gen/c/templates/xen_all.h.mustache
index 9d9bef914..fb86a54f4 100644
--- a/ocaml/sdk-gen/c/templates/xen_all.h.mustache
+++ b/ocaml/sdk-gen/c/templates/xen_all.h.mustache
@@ -27,7 +27,6 @@
* OF THE POSSIBILITY OF SUCH DAMAGE.
*/
-/* This file is autogenerated */
#ifndef XEN_API_XEN_ALL_H
#define XEN_API_XEN_ALL_H
@@ -37,9 +36,10 @@
#include <xen/api/xen_common.h>
#include <xen/api/xen_event_batch.h>
{{#api_headers}}
-#include <{{api_header}}>
+#include <xen/api/xen_{{api_header}}.h>
{{/api_headers}}
#include <xen/api/xen_int_set.h>
#include <xen/api/xen_string_set.h>
#endif
+
diff --git a/ocaml/sdk-gen/c/templates/xen_api_failure.c.mustache b/ocaml/sdk-gen/c/templates/xen_api_failure.c.mustache
new file mode 100644
index 000000000..f35926bfc
--- /dev/null
+++ b/ocaml/sdk-gen/c/templates/xen_api_failure.c.mustache
@@ -0,0 +1,58 @@
+/*
+ * Copyright (c) Cloud Software Group, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1) Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2) Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following
+ * disclaimer in the documentation and/or other materials
+ * provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+ * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+
+#include "xen_internal.h"
+#include <xen/api/xen_api_failure.h>
+
+
+/*
+ * Maintain this in the same order as the enum declaration!
+ */
+static const char *lookup_table[] =
+{
+{{#api_errors}}
+ "{{api_error}}",
+{{/api_errors}}
+};
+
+
+const char *
+xen_api_failure_to_string(enum xen_api_failure val)
+{
+ return lookup_table[val];
+}
+
+
+extern enum xen_api_failure
+xen_api_failure_from_string(const char *str)
+{
+ return ENUM_LOOKUP(str, lookup_table);
+}
+
diff --git a/ocaml/sdk-gen/c/templates/xen_api_failure.h.mustache b/ocaml/sdk-gen/c/templates/xen_api_failure.h.mustache
new file mode 100644
index 000000000..3094d7a51
--- /dev/null
+++ b/ocaml/sdk-gen/c/templates/xen_api_failure.h.mustache
@@ -0,0 +1,66 @@
+/*
+ * Copyright (c) Cloud Software Group, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1) Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2) Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following
+ * disclaimer in the documentation and/or other materials
+ * provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+ * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+
+#ifndef XEN_API_FAILURE_H
+#define XEN_API_FAILURE_H
+
+
+enum xen_api_failure
+{
+{{#api_errors}}
+{{{api_error_doc}}}
+ XEN_API_FAILURE_{{api_error}},
+
+{{/api_errors}}
+ /**
+ * Unknown to this SDK version.
+ */
+ XEN_API_FAILURE_UNDEFINED
+};
+
+
+/**
+ * Return the name corresponding to the given code. This string must
+ * not be modified or freed.
+ */
+extern const char *
+xen_api_failure_to_string(enum xen_api_failure val);
+
+
+/**
+ * Return the correct code for the given string, or UNDEFINED if the
+ * given string does not match a known code.
+ */
+extern enum xen_api_failure
+xen_api_failure_from_string(const char *str);
+
+
+#endif
+
diff --git a/ocaml/sdk-gen/c/templates/xen_api_version.c.mustache b/ocaml/sdk-gen/c/templates/xen_api_version.c.mustache
index 0a13575d3..94b0c894b 100644
--- a/ocaml/sdk-gen/c/templates/xen_api_version.c.mustache
+++ b/ocaml/sdk-gen/c/templates/xen_api_version.c.mustache
@@ -27,6 +27,7 @@
* OF THE POSSIBILITY OF SUCH DAMAGE.
*/
+
#include "xen/api/xen_api_version.h"
const char *
@@ -53,3 +54,4 @@ xen_api_version_from_int(int64_t major_version, int64_t minor_version)
{{/releases}}
return xen_api_unknown_version;
}
+
diff --git a/ocaml/sdk-gen/c/templates/xen_api_version.h.mustache b/ocaml/sdk-gen/c/templates/xen_api_version.h.mustache
index 5f55ec792..09115486a 100644
--- a/ocaml/sdk-gen/c/templates/xen_api_version.h.mustache
+++ b/ocaml/sdk-gen/c/templates/xen_api_version.h.mustache
@@ -27,6 +27,7 @@
* OF THE POSSIBILITY OF SUCH DAMAGE.
*/
+
#ifndef XEN_API_VERSION_H
#define XEN_API_VERSION_H
@@ -48,3 +49,4 @@ extern xen_api_version
xen_api_version_from_int(int64_t major_version, int64_t minor_version);
#endif
+
diff --git a/ocaml/sdk-gen/c/templates/xen_enum.c.mustache b/ocaml/sdk-gen/c/templates/xen_enum.c.mustache
index 421c9015a..90b1d2008 100644
--- a/ocaml/sdk-gen/c/templates/xen_enum.c.mustache
+++ b/ocaml/sdk-gen/c/templates/xen_enum.c.mustache
@@ -96,3 +96,4 @@ const abstract_type xen_{{{enum_name}}}_set_abstract_type_ =
{{/event_operations}}
+
diff --git a/ocaml/sdk-gen/c/templates/xen_enum.h.mustache b/ocaml/sdk-gen/c/templates/xen_enum.h.mustache
index 824179cf2..3a944a714 100644
--- a/ocaml/sdk-gen/c/templates/xen_enum.h.mustache
+++ b/ocaml/sdk-gen/c/templates/xen_enum.h.mustache
@@ -38,14 +38,12 @@
enum xen_{{{enum_name}}}
{
{{#enum_values}}
- /**
- * {{{enum_value_doc}}}
- */
+{{{enum_value_doc}}}
XEN_{{{enum_name_upper}}}_{{{enum_value_upper}}},
{{/enum_values}}
/**
- * Unknown to this version of the bindings.
+ * Unknown to this SDK version.
*/
XEN_{{{enum_name_upper}}}_UNDEFINED
};
@@ -64,8 +62,8 @@ extern xen_{{{enum_name}}}_set *
xen_{{{enum_name}}}_set_alloc(size_t size);
/**
- * Free the given xen_{{{enum_name}}}_set. The given set must have been
- * allocated by this library.
+ * Free the given xen_{{{enum_name}}}_set. The given set must
+ * have been allocated by this library.
*/
extern void
xen_{{{enum_name}}}_set_free(xen_{{{enum_name}}}_set *set);
@@ -89,3 +87,4 @@ xen_{{{enum_name}}}_from_string(xen_session *session, const char *str);
#endif
+
diff --git a/ocaml/sdk-gen/c/templates/xen_enum_internal.h.mustache b/ocaml/sdk-gen/c/templates/xen_enum_internal.h.mustache
index b9731686e..f3945be97 100644
--- a/ocaml/sdk-gen/c/templates/xen_enum_internal.h.mustache
+++ b/ocaml/sdk-gen/c/templates/xen_enum_internal.h.mustache
@@ -28,10 +28,9 @@
*/
-
/*
* Declarations of the abstract types used during demarshalling of enum
- * xen_{{{enum_name}}}. Internal to this library -- do not use from outside.
+ * xen_{{{enum_name}}}.
*/
@@ -43,9 +42,8 @@
extern const abstract_type xen_{{{enum_name}}}_abstract_type_;
-{{^event_operations}}
extern const abstract_type xen_{{{enum_name}}}_set_abstract_type_;
-{{/event_operations}}
#endif
+
diff --git a/ocaml/sdk-gen/c/templates/xen_enum_map_internal.h.mustache b/ocaml/sdk-gen/c/templates/xen_enum_map_internal.h.mustache
new file mode 100644
index 000000000..6d595ad16
--- /dev/null
+++ b/ocaml/sdk-gen/c/templates/xen_enum_map_internal.h.mustache
@@ -0,0 +1,39 @@
+/*
+ * Copyright (c) Cloud Software Group, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1) Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2) Redistributions in binary form must reproduce the above
+ * copyright notice, this list of conditions and the following
+ * disclaimer in the documentation and/or other materials
+ * provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+ * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+ * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+ * OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+
+#ifndef XEN_{{{map_upper}}}_INTERNAL_H
+#define XEN_{{{map_upper}}}_INTERNAL_H
+
+
+extern const abstract_type {{{map_lower}}}_abstract_type_;
+
+
+#endif
+
diff --git a/ocaml/sdk-gen/c/templates/xen_internal.mustache b/ocaml/sdk-gen/c/templates/xen_internal.mustache
index 934ae5047..621617511 100644
--- a/ocaml/sdk-gen/c/templates/xen_internal.mustache
+++ b/ocaml/sdk-gen/c/templates/xen_internal.mustache
@@ -27,6 +27,7 @@
* OF THE POSSIBILITY OF SUCH DAMAGE.
*/
+
#ifndef XEN_INTERNAL_H
#define XEN_INTERNAL_H
@@ -208,3 +209,4 @@ void type__ ## _record_opt_free(type__ ## _record_opt *opt) { \
#endif
+
diff --git a/ocaml/sdk-gen/powershell/autogen/README.md b/ocaml/sdk-gen/powershell/autogen/README.md
index cbe06791b..abbb3b0b1 100644
--- a/ocaml/sdk-gen/powershell/autogen/README.md
+++ b/ocaml/sdk-gen/powershell/autogen/README.md
@@ -51,9 +51,9 @@ The XenServer PowerShell Module is dependent upon the following libraries:
This archive contains the following folders that are relevant to PowerShell users:
-- `XenServerPowerShell\XenServerPSModule`: this is the XenServer PowerShell
+- `XenServerPowerShell\PowerShell_7\XenServerPSModule`: this is the XenServer PowerShell
Module
-- `XenServerPowerShell\src`: contains the C# source code for the XenServer
+- `XenServerPowerShell\PowerShell_7\src`: contains the C# source code for the XenServer
cmdlets shipped as a Visual Studio project.
## Getting Started
diff --git a/ocaml/sdk-gen/powershell/autogen/README_51.md b/ocaml/sdk-gen/powershell/autogen/README_51.md
index 8088982ff..4d5b19e26 100644
--- a/ocaml/sdk-gen/powershell/autogen/README_51.md
+++ b/ocaml/sdk-gen/powershell/autogen/README_51.md
@@ -51,9 +51,9 @@ The XenServer PowerShell Module is dependent upon the following libraries:
This archive contains the following folders that are relevant to PowerShell users:
-- `XenServerPowerShell\XenServerPSModule`: this is the XenServer PowerShell
+- `XenServerPowerShell\PowerShell_51\XenServerPSModule`: this is the XenServer PowerShell
Module
-- `XenServerPowerShell\src`: contains the C# source code for the XenServer
+- `XenServerPowerShell\PowerShell_51\src`: contains the C# source code for the XenServer
cmdlets shipped as a Visual Studio project.
## Getting Started
diff --git a/ocaml/tests/test_vm_check_operation_error.ml b/ocaml/tests/test_vm_check_operation_error.ml
index a91fdcfa2..0423338e6 100644
--- a/ocaml/tests/test_vm_check_operation_error.ml
+++ b/ocaml/tests/test_vm_check_operation_error.ml
@@ -1,54 +1,6 @@
-let all_vm_operations =
- [
- `assert_operation_valid
- ; `awaiting_memory_live
- ; `call_plugin
- ; `changing_VCPUs
- ; `changing_VCPUs_live
- ; `changing_dynamic_range
- ; `changing_memory_limits
- ; `changing_memory_live
- ; `changing_shadow_memory
- ; `changing_shadow_memory_live
- ; `changing_static_range
- ; `changing_NVRAM
- ; `checkpoint
- ; `clean_reboot
- ; `clean_shutdown
- ; `clone
- ; `copy
- ; `create_template
- ; `csvm
- ; `data_source_op
- ; `destroy
- ; `export
- ; `get_boot_record
- ; `hard_reboot
- ; `hard_shutdown
- ; `import
- ; `make_into_template
- ; `metadata_export
- ; `migrate_send
- ; `pause
- ; `pool_migrate
- ; `power_state_reset
- ; `provision
- ; `query_services
- ; `resume
- ; `resume_on
- ; `revert
- ; `reverting
- ; `send_sysrq
- ; `send_trigger
- ; `shutdown
- ; `snapshot
- ; `snapshot_with_quiesce
- ; `start
- ; `start_on
- ; `suspend
- ; `unpause
- ; `update_allowed_operations
- ]
+let vm_op_to_string = API.vm_operations_to_string
+
+let pp_vm_op () = Fmt.(str "%a" (of_to_string vm_op_to_string))
let with_test_vm f =
let __context = Mock.make_context_with_new_db "Mock context" in
@@ -75,7 +27,7 @@ let test_null_vdi () =
~strict:true
)
)
- all_vm_operations
+ API.vm_operations__all
)
let test_vm_set_nvram_running () =
@@ -155,6 +107,71 @@ let test_sxm_allowed_when_rum () =
)
)
+let test_is_allowed_concurrently (expected, (op, current_ops)) =
+ let ops_to_str ops =
+ String.concat "," (List.map (fun (_, op) -> vm_op_to_string op) ops)
+ in
+ let name =
+ match current_ops with
+ | [] ->
+ vm_op_to_string op
+ | lst ->
+ Printf.sprintf "%a when %s" pp_vm_op op (ops_to_str lst)
+ in
+
+ let test () =
+ let actual = Xapi_vm_lifecycle.is_allowed_concurrently ~op ~current_ops in
+ let name =
+ Printf.sprintf "%a allowed in [%s]" pp_vm_op op (ops_to_str current_ops)
+ in
+ Alcotest.(check bool) name expected actual
+ in
+ (name, `Quick, test)
+
+let allowed_specs =
+ let current_of op = ((), op) in
+ let allow_hard_shutdown =
+ List.map
+ (fun op ->
+ let allowed = match op with `hard_shutdown -> false | _ -> true in
+ (allowed, (`hard_shutdown, [current_of op]))
+ )
+ API.vm_operations__all
+ in
+ let allow_hard_reboot =
+ List.map
+ (fun op ->
+ let allowed =
+ match op with `hard_shutdown | `hard_reboot -> false | _ -> true
+ in
+ (allowed, (`hard_reboot, [current_of op]))
+ )
+ API.vm_operations__all
+ in
+ let allow_clean_shutdown =
+ List.map
+ (fun op ->
+ let allowed = match op with `migrate_send -> true | _ -> false in
+ (allowed, (`clean_shutdown, [current_of op]))
+ )
+ API.vm_operations__all
+ in
+ List.concat
+ [
+ [
+ (true, (`snapshot, []))
+ ; (true, (`snapshot, [current_of `checkpoint]))
+ ; (false, (`migrate_send, [current_of `clean_reboot]))
+ ; (true, (`clean_reboot, [current_of `migrate_send]))
+ ]
+ ; allow_hard_shutdown
+ ; allow_clean_shutdown
+ ; allow_hard_reboot
+ ]
+
+let test_allow_concurrently =
+ List.map test_is_allowed_concurrently allowed_specs
+
let test =
[
("test_null_vdi", `Quick, test_null_vdi)
@@ -166,3 +183,7 @@ let test =
; ("test_sxm_allowed_when_rum", `Quick, test_sxm_allowed_when_rum)
; ("test_vm_set_nvram when VM is running", `Quick, test_vm_set_nvram_running)
]
+
+let () =
+ Alcotest.run "Xapi_vm_lifecycle"
+ [("is_allowed_concurrently", test_allow_concurrently)]
diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml
index f8aa043eb..58ecb6cc8 100644
--- a/ocaml/xapi-cli-server/cli_frontend.ml
+++ b/ocaml/xapi-cli-server/cli_frontend.ml
@@ -1756,7 +1756,13 @@ let rec cmdtable_data : (string * cmd_spec) list =
; ( "vm-export"
, {
reqd= ["filename"]
- ; optn= ["preserve-power-state"; "compress"]
+ ; optn=
+ [
+ "preserve-power-state"
+ ; "compress"
+ ; "metadata"
+ ; "excluded-device-types"
+ ]
; help= "Export a VM to <filename>."
; implementation= With_fd Cli_operations.vm_export
; flags= [Standard; Vm_selectors]
@@ -1798,7 +1804,13 @@ let rec cmdtable_data : (string * cmd_spec) list =
; ( "snapshot-export-to-template"
, {
reqd= ["filename"; "snapshot-uuid"]
- ; optn= ["preserve-power-state"]
+ ; optn=
+ [
+ "preserve-power-state"
+ ; "compress"
+ ; "metadata"
+ ; "excluded-device-types"
+ ]
; help= "Export a snapshot to <filename>."
; implementation= With_fd Cli_operations.snapshot_export
; flags= [Standard]
@@ -1863,7 +1875,7 @@ let rec cmdtable_data : (string * cmd_spec) list =
; ( "template-export"
, {
reqd= ["filename"; "template-uuid"]
- ; optn= []
+ ; optn= ["compress"; "metadata"; "excluded-device-types"]
; help= "Export a template to <filename>."
; implementation= With_fd Cli_operations.template_export
; flags= [Standard]
diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml
index bc0d9ea30..4f28a4884 100644
--- a/ocaml/xapi-cli-server/cli_operations.ml
+++ b/ocaml/xapi-cli-server/cli_operations.ml
@@ -32,26 +32,10 @@ let failwith str = raise (Cli_util.Cli_failure str)
exception ExitWithError of int
let bool_of_string param string =
- let s = String.lowercase_ascii string in
- match s with
- | "true" ->
- true
- | "t" ->
- true
- | "1" ->
- true
- | "false" ->
- false
- | "f" ->
- false
- | "0" ->
- false
- | _ ->
- failwith
- ("Failed to parse parameter '"
- ^ param
- ^ "': expecting 'true' or 'false'"
- )
+ try Record_util.bool_of_string string
+ with Record_util.Record_failure msg ->
+ let msg = Printf.sprintf "Failed to parse parameter '%s': %s" param msg in
+ raise (Record_util.Record_failure msg)
let get_bool_param params ?(default = false) param =
List.assoc_opt param params
@@ -66,6 +50,24 @@ let get_float_param params param ~default =
let get_param params param ~default =
Option.value ~default (List.assoc_opt param params)
+let get_set_param params ?(default = []) param =
+ List.assoc_opt param params
+ |> Option.map (String.split_on_char ',')
+ |> Option.value ~default
+
+let get_map_param params ?(default = []) param =
+ let get_map x =
+ String.split_on_char ',' x
+ |> List.filter_map (fun x ->
+ match String.split_on_char ':' x with
+ | [k; v] ->
+ Some (k, v)
+ | _ ->
+ None
+ )
+ in
+ List.assoc_opt param params |> Option.map get_map |> Option.value ~default
+
(** [get_unique_param param params] is intended to replace [List.assoc_opt] in
the cases where a parameter can only exist once, as repeating it might
force the CLI to make choices the user didn't foresee. In those cases
@@ -1520,16 +1522,15 @@ let pool_management_reconfigure (_ : printer) rpc session_id params =
let pool_join printer rpc session_id params =
try
let force = get_bool_param params "force" in
+ let master_address = List.assoc "master-address" params in
+ let master_username = List.assoc "master-username" params in
+ let master_password = List.assoc "master-password" params in
if force then
- Client.Pool.join_force ~rpc ~session_id
- ~master_address:(List.assoc "master-address" params)
- ~master_username:(List.assoc "master-username" params)
- ~master_password:(List.assoc "master-password" params)
+ Client.Pool.join_force ~rpc ~session_id ~master_address ~master_username
+ ~master_password
else
- Client.Pool.join ~rpc ~session_id
- ~master_address:(List.assoc "master-address" params)
- ~master_username:(List.assoc "master-username" params)
- ~master_password:(List.assoc "master-password" params) ;
+ Client.Pool.join ~rpc ~session_id ~master_address ~master_username
+ ~master_password ;
printer
(Cli_printer.PList
[
@@ -3264,11 +3265,11 @@ let do_vm_op ?(include_control_vms = false) ?(include_template_vms = false)
select_vms ~include_control_vms ~include_template_vms rpc session_id
params ignore_params
in
- match List.length vms with
- | 0 ->
+ match vms with
+ | [] ->
failwith "No matching VMs found"
- | 1 ->
- [op (List.hd vms)]
+ | [vm] ->
+ [op vm]
| _ ->
if multiple && get_bool_param params "multiple" then
do_multiple op vms
@@ -3310,11 +3311,11 @@ let do_host_op rpc session_id op params ?(multiple = true) ignore_params =
let do_sr_op rpc session_id op params ?(multiple = true) ignore_params =
let srs = select_srs rpc session_id params ignore_params in
- match List.length srs with
- | 0 ->
+ match srs with
+ | [] ->
failwith "No matching hosts found"
- | 1 ->
- [op (List.hd srs)]
+ | [sr] ->
+ [op sr]
| _ ->
if multiple && get_bool_param params "multiple" then
do_multiple op srs
@@ -5575,12 +5576,7 @@ let vm_import fd _printer rpc session_id params =
raise
(Cli_util.Cli_failure "No SR specified and Pool default SR is null")
in
- let _type =
- if List.mem_assoc "type" params then
- List.assoc "type" params
- else
- "default"
- in
+ let _type = get_param ~default:"default" params "type" in
let full_restore = get_bool_param params "preserve" in
let vm_metadata_only = get_bool_param params "metadata" in
let force = get_bool_param params "force" in
@@ -5806,9 +5802,7 @@ let blob_put fd _printer rpc session_id params =
let blob_create printer rpc session_id params =
let name = List.assoc "name" params in
let mime_type = Listext.assoc_default "mime-type" params "" in
- let public =
- try bool_of_string "public" (List.assoc "public" params) with _ -> false
- in
+ let public = get_bool_param params "public" in
if List.mem_assoc "vm-uuid" params then
let uuid = List.assoc "vm-uuid" params in
let vm = Client.VM.get_by_uuid ~rpc ~session_id ~uuid in
@@ -5860,14 +5854,17 @@ let blob_create printer rpc session_id params =
let export_common fd _printer rpc session_id params filename num ?task_uuid
compression preserve_power_state vm =
- let vm_metadata_only : bool = get_bool_param params "metadata" in
- let export_snapshots : bool =
- if List.mem_assoc "include-snapshots" params then
- bool_of_string "include-snapshots" (List.assoc "include-snapshots" params)
+ let vm_metadata_only = get_bool_param params "metadata" in
+ let export_snapshots = get_bool_param params "include-snapshots" in
+ let uri, extra_args =
+ if vm_metadata_only then
+ ( Constants.export_metadata_uri
+ , Printf.sprintf "&excluded_device_types=%s"
+ (get_param params ~default:"" "excluded-device-types")
+ )
else
- vm_metadata_only
+ (Constants.export_uri, "")
in
- let vm_metadata_only = get_bool_param params "metadata" in
let vm_record = vm.record () in
let exporttask, task_destroy_fn =
match task_uuid with
@@ -5884,49 +5881,40 @@ let export_common fd _printer rpc session_id params filename num ?task_uuid
(* do not destroy the task that has been received *)
(Client.Task.get_by_uuid ~rpc ~session_id ~uuid:task_uuid, fun () -> ())
in
- (* Initially mark the task progress as -1.0. The first thing the export handler does it to mark it as zero *)
- (* This is used as a flag to show that the 'ownership' of the task has been passed to the handler, and it's *)
- (* not our responsibility any more to mark the task as completed/failed/etc. *)
+ (* Initially mark the task progress as -1.0. The first thing the export
+ handler does it to mark it as zero. This is used as a flag to show that
+ the 'ownership' of the task has been passed to the handler, and it's
+ not our responsibility any more to mark the task as completed/failed/etc.
+ *)
Client.Task.set_progress ~rpc ~session_id ~self:exporttask ~value:(-1.0) ;
finally
(fun () ->
- let f = if !num > 1 then filename ^ string_of_int !num else filename in
+ let num = Atomic.fetch_and_add num 1 in
+ let f = if num > 1 then filename ^ string_of_int num else filename in
download_file rpc session_id exporttask fd f
(Printf.sprintf
- "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b&export_snapshots=%b"
- ( if vm_metadata_only then
- Constants.export_metadata_uri
- else
- Constants.export_uri
- )
- (Ref.string_of session_id) (Ref.string_of exporttask)
+ "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b&export_snapshots=%b%s"
+ uri (Ref.string_of session_id) (Ref.string_of exporttask)
(Ref.string_of (vm.getref ()))
Constants.use_compression
(Compression_algorithms.to_string compression)
- preserve_power_state export_snapshots
+ preserve_power_state export_snapshots extra_args
)
- "Export" ;
- num := !num + 1
+ "Export"
)
(fun () -> task_destroy_fn ())
let get_compression_algorithm params =
- if List.mem_assoc "compress" params then
- Compression_algorithms.of_string (List.assoc "compress" params)
- else
- None
+ Option.bind
+ (List.assoc_opt "compress" params)
+ Compression_algorithms.of_string
let vm_export fd printer rpc session_id params =
let filename = List.assoc "filename" params in
let compression = get_compression_algorithm params in
let preserve_power_state = get_bool_param params "preserve-power-state" in
- let task_uuid =
- if List.mem_assoc "task-uuid" params then
- Some (List.assoc "task-uuid" params)
- else
- None
- in
- let num = ref 1 in
+ let task_uuid = List.assoc_opt "task-uuid" params in
+ let num = Atomic.make 1 in
let op vm =
export_common fd printer rpc session_id params filename num ?task_uuid
compression preserve_power_state vm
@@ -5939,6 +5927,7 @@ let vm_export fd printer rpc session_id params =
; "compress"
; "preserve-power-state"
; "include-snapshots"
+ ; "excluded-device-types"
]
)
@@ -5946,32 +5935,23 @@ let vm_export_aux obj_type fd printer rpc session_id params =
let filename = List.assoc "filename" params in
let compression = get_compression_algorithm params in
let preserve_power_state = get_bool_param params "preserve-power-state" in
- let num = ref 1 in
let uuid = List.assoc (obj_type ^ "-uuid") params in
- let ref = Client.VM.get_by_uuid ~rpc ~session_id ~uuid in
- if
- obj_type = "template"
- && not (Client.VM.get_is_a_template ~rpc ~session_id ~self:ref)
- then
- failwith
- (Printf.sprintf
- "This operation can only be performed on a VM template. %s is not a \
- VM template."
- uuid
- ) ;
- if
- obj_type = "snapshot"
- && not (Client.VM.get_is_a_snapshot ~rpc ~session_id ~self:ref)
- then
- failwith
- (Printf.sprintf
- "This operation can only be performed on a VM snapshot. %s is not a \
- VM snapshot."
- uuid
- ) ;
+ let vm = Client.VM.get_by_uuid ~rpc ~session_id ~uuid in
+ let is_template () = Client.VM.get_is_a_template ~rpc ~session_id ~self:vm in
+ let is_snapshot () = Client.VM.get_is_a_snapshot ~rpc ~session_id ~self:vm in
+ let msg () =
+ Printf.sprintf
+ "This operation can only be performed on a VM %s. %s is not a VM %s."
+ obj_type uuid obj_type
+ in
+ if obj_type = "template" && not (is_template ()) then
+ failwith (msg ()) ;
+ if obj_type = "snapshot" && not (is_snapshot ()) then
+ failwith (msg ()) ;
+ let num = Atomic.make 1 in
export_common fd printer rpc session_id params filename num compression
preserve_power_state
- (vm_record rpc session_id ref)
+ (vm_record rpc session_id vm)
let vm_copy_bios_strings printer rpc session_id params =
let host =
@@ -7349,7 +7329,7 @@ let vmss_create printer rpc session_id params =
let schedule = read_map_params "schedule" params in
(* optional parameters with default values *)
let name_description = get "name-description" ~default:"" in
- let enabled = Record_util.bool_of_string (get "enabled" ~default:"true") in
+ let enabled = get_bool_param ~default:true params "enabled" in
let retained_snapshots =
Int64.of_string (get "retained-snapshots" ~default:"7")
in
@@ -7918,13 +7898,7 @@ module VTPM = struct
let create printer rpc session_id params =
let vm_uuid = List.assoc "vm-uuid" params in
let vM = Client.VM.get_by_uuid ~rpc ~session_id ~uuid:vm_uuid in
- let is_unique =
- match List.assoc_opt "is_unique" params with
- | Some value ->
- bool_of_string "is_unique" value
- | None ->
- false
- in
+ let is_unique = get_bool_param params "is_unique" in
let ref = Client.VTPM.create ~rpc ~session_id ~vM ~is_unique in
let uuid = Client.VTPM.get_uuid ~rpc ~session_id ~self:ref in
printer (Cli_printer.PList [uuid])
@@ -7940,33 +7914,12 @@ module Observer = struct
let create printer rpc session_id params =
let name_label = List.assoc "name-label" params in
let hosts =
- List.assoc_opt "host-uuids" params
- |> Option.fold ~none:[] ~some:(fun host_uuids ->
- List.map
- (fun uuid -> Client.Host.get_by_uuid ~rpc ~session_id ~uuid)
- (String.split_on_char ',' host_uuids)
- )
- in
- let name_description =
- List.assoc_opt "name-description" params |> Option.value ~default:""
- in
- let enabled =
- List.assoc_opt "enabled" params
- |> Option.fold ~none:false ~some:(fun s ->
- try Stdlib.bool_of_string s with _ -> false
- )
- in
- let attributes =
- List.assoc_opt "attributes" params
- |> Option.fold ~none:[] ~some:(String.split_on_char ',')
- |> List.filter_map (fun kv ->
- match String.split_on_char ':' kv with
- | [k; v] ->
- Some (k, v)
- | _ ->
- None
- )
+ get_set_param params "host-uuids"
+ |> List.map (fun uuid -> Client.Host.get_by_uuid ~rpc ~session_id ~uuid)
in
+ let name_description = get_param ~default:"" params "name-description" in
+ let enabled = get_bool_param params "enabled" in
+ let attributes = get_map_param params "attributes" in
let endpoints =
List.assoc_opt "endpoints" params
|> Option.fold ~none:[Tracing.bugtool_name]
diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml
index 5332c2aee..8fbd141e9 100644
--- a/ocaml/xapi-cli-server/record_util.ml
+++ b/ocaml/xapi-cli-server/record_util.ml
@@ -953,12 +953,17 @@ let cluster_host_operation_to_string op =
let bool_of_string s =
match String.lowercase_ascii s with
- | "true" | "yes" ->
+ | "true" | "t" | "yes" | "y" | "1" ->
true
- | "false" | "no" ->
+ | "false" | "f" | "no" | "n" | "0" ->
false
| _ ->
- raise (Record_failure ("Expected 'true','yes','false','no', got " ^ s))
+ raise
+ (Record_failure
+ ("Expected 'true','t','yes','y','1','false','f','no','n','0' got "
+ ^ s
+ )
+ )
let sdn_protocol_of_string s =
match String.lowercase_ascii s with
diff --git a/ocaml/xapi-guard/lib/disk_cache.ml b/ocaml/xapi-guard/lib/disk_cache.ml
index 0f0a6e2c2..5e8b9bb06 100644
--- a/ocaml/xapi-guard/lib/disk_cache.ml
+++ b/ocaml/xapi-guard/lib/disk_cache.ml
@@ -62,18 +62,15 @@ let unlink_safe file =
type valid_file = t * string
-type file =
- | Latest of valid_file
- | Outdated of valid_file
- | Temporary of string
- | Invalid of string
-
-let path_of_key root (uuid, timestamp, key) =
- root
- // Uuidm.to_string uuid
+type file = Latest of valid_file | Outdated of valid_file | Invalid of string
+
+let print_key (uuid, timestamp, key) =
+ Uuidm.to_string uuid
// Types.Tpm.(serialize_key key |> string_of_int)
// Mtime.(to_uint64_ns timestamp |> Int64.to_string)
+let path_of_key root key = root // print_key key
+
let key_of_path path =
let ( let* ) = Option.bind in
let key_dir = Filename.(dirname path) in
@@ -81,7 +78,12 @@ let key_of_path path =
let* key =
Filename.basename key_dir
|> int_of_string_opt
- |> Option.map Types.Tpm.deserialize_key
+ |> Option.map (fun e ->
+ Types.Tpm.deserialize_key e
+ |> Result.map_error (fun msg -> D.info "Invalid key found: %s" msg)
+ |> Result.to_option
+ )
+ |> Option.join
in
let* timestamp =
Filename.basename path
@@ -90,24 +92,17 @@ let key_of_path path =
in
Some ((uuid, timestamp, key), path)
-let path_is_temp path =
- let pathlen = String.length path in
- String.ends_with ~suffix:".pre" path
- && key_of_path (String.sub path 0 (pathlen - 4)) |> Option.is_some
-
-let temp_of_path path = path ^ ".pre"
+let only_latest = function
+ | Latest f ->
+ Either.Left f
+ | Outdated (_, p) | Invalid p ->
+ Right p
let sort_updates contents =
let classify elem =
match key_of_path elem with
| None ->
- let file =
- if path_is_temp elem then
- Temporary elem
- else
- Invalid elem
- in
- Either.Right file
+ Either.Right (Invalid elem)
| Some valid_file ->
Either.Left valid_file
in
@@ -152,7 +147,7 @@ let read_from ~filename =
let persist_to ~filename:f_path ~contents =
let atomic_write_to_file ~perm f =
- let tmp_path = temp_of_path f_path in
+ let tmp_path = f_path ^ ".pre" in
let dirname = Filename.dirname f_path in
let flags = Unix.[O_WRONLY; O_CREAT; O_SYNC] in
let* fd_tmp = Lwt_unix.openfile tmp_path flags perm in
@@ -285,16 +280,10 @@ end = struct
let updates = sort_updates contents in
(* 2. Pick latest *)
- let only_latest = function
- | Latest (_, p) ->
- Either.Left p
- | Temporary p | Outdated (_, p) | Invalid p ->
- Right p
- in
let latest, _ = List.partition_map only_latest updates in
(* 3. fall back to remote read if needed *)
- let get_contents path =
+ let get_contents (_, path) =
Lwt.catch (fun () -> read_from ~filename:path) (fun _ -> read_remote ())
in
@@ -382,43 +371,38 @@ module Watcher : sig
end = struct
type push_cache = File of valid_file | Update_all | Wait
- (* Outdated and invalid files can be deleted, keep temporary files just in case
- they need to be recovered *)
- let discarder = function
- | Latest _ as f ->
- Either.Left f
- | Temporary _ as f ->
- Left f
- | Outdated (_, p) ->
- Right p
- | Invalid p ->
- Right p
-
let get_latest_and_delete_rest root =
let* files = get_all_contents root in
- let keep, to_delete = List.partition_map discarder files in
+ let latest, to_delete = List.partition_map only_latest files in
let* () = Lwt_list.iter_p unlink_safe to_delete in
- (* Ignore temporaty files *)
- let latest =
- List.filter_map (function Latest f -> Some f | _ -> None) keep
- in
Lwt.return latest
let retry_push push (uuid, timestamp, key) contents =
let __FUN = __FUNCTION__ in
let push' () = push (uuid, timestamp, key) contents in
- let rec retry k =
+ let counter = Mtime_clock.counter () in
+ let rec retry is_first_try =
let on_error e =
- D.info "%s: Error on push, attempt %i. Reason: %s" __FUN k
+ if is_first_try then
+ D.debug "%s: Error on push, retrying. Reason: %s" __FUN
(Printexc.to_string e) ;
let* () = Lwt_unix.sleep 0.1 in
- retry (k + 1)
+ retry false
in
Lwt.try_bind push'
- (function Ok () -> Lwt.return_unit | Error e -> on_error e)
+ (function
+ | Ok () -> Lwt.return (not is_first_try) | Error e -> on_error e
+ )
on_error
in
- retry 1
+ let* failed = retry true in
+ ( if failed then
+ let elapsed = Mtime_clock.count counter in
+ D.debug "%s: Pushed %s after trying for %s" __FUN
+ (print_key (uuid, timestamp, key))
+ (Fmt.to_to_string Mtime.Span.pp elapsed)
+ ) ;
+ Lwt.return_unit
let push_file push (key, path) =
let __FUN = __FUNCTION__ in
@@ -519,30 +503,28 @@ end
(** Module use to change the cache contents before the reader and writer start
running *)
module Setup : sig
- val retime_cache_contents : Types.Service.t -> unit Lwt.t
+ val retime_cache_contents : Types.Service.t -> t List.t Lwt.t
+ (** [retime_cache_contents typ] retimes the current cache contents so they
+ are time congruently with the current execution and returns the keys of
+ valid files that are yet to be pushed *)
end = struct
type file_action =
| Keep of file
| Delete of string
| Move of {from: string; into: string}
- let get_fs_action root now = function
+ let get_fs_action root now acc = function
| Latest ((uuid, timestamp, key), from) as latest ->
if Mtime.is_later ~than:now timestamp then
let timestamp = now in
let into = path_of_key root (uuid, timestamp, key) in
- Move {from; into}
+ ((uuid, timestamp, key) :: acc, Move {from; into})
else
- Keep latest
- | Temporary _ as temp ->
- Keep temp
+ ((uuid, timestamp, key) :: acc, Keep latest)
| Invalid p | Outdated (_, p) ->
- Delete p
+ (acc, Delete p)
let commit __FUN = function
- | Keep (Temporary p) ->
- D.warn "%s: Found temporary file, ignoring '%s'" __FUN p ;
- Lwt.return_unit
| Keep _ ->
Lwt.return_unit
| Delete p ->
@@ -585,19 +567,31 @@ end = struct
let now = Mtime_clock.now () in
let root = cache_of typ in
let* contents = get_all_contents root in
- let* () =
- contents
- |> List.map (get_fs_action root now)
- |> Lwt_list.iter_p (commit __FUNCTION__)
+ let pending, actions =
+ contents |> List.fold_left_map (get_fs_action root now) []
in
- delete_empty_dirs ~delete_root:false root
+ let* () = Lwt_list.iter_p (commit __FUNCTION__) actions in
+ let* () = delete_empty_dirs ~delete_root:false root in
+ Lwt.return pending
end
let setup typ read write =
- let* () = Setup.retime_cache_contents typ in
- let queue, push = Lwt_bounded_stream.create 2 in
+ let* pending = Setup.retime_cache_contents typ in
+ let capacity = 512 in
+ let queue, push = Lwt_bounded_stream.create capacity in
let lock = Lwt_mutex.create () in
- let q = {queue; push; lock; state= Disengaged} in
+ let state =
+ if pending = [] then
+ Direct
+ else if List.length pending < capacity then
+ let () =
+ List.iter (fun e -> Option.value ~default:() (push (Some e))) pending
+ in
+ Engaged
+ else
+ Disengaged
+ in
+ let q = {queue; push; lock; state} in
Lwt.return
( Writer.with_cache ~direct:(read, write) typ q
, Watcher.watch ~direct:write typ q
diff --git a/ocaml/xapi-guard/lib/types.ml b/ocaml/xapi-guard/lib/types.ml
index 3f2b41c76..ff6dbc1dd 100644
--- a/ocaml/xapi-guard/lib/types.ml
+++ b/ocaml/xapi-guard/lib/types.ml
@@ -28,13 +28,13 @@ module Tpm = struct
let deserialize_key = function
| 0 ->
- Perm
+ Ok Perm
| 1 ->
- Save
+ Ok Save
| 2 ->
- Volatile
+ Ok Volatile
| s ->
- Fmt.invalid_arg "Unknown TPM state key: %i" s
+ Error Printf.(sprintf "Unknown TPM state key: %i" s)
let empty_state = ""
diff --git a/ocaml/xapi-guard/lib/types.mli b/ocaml/xapi-guard/lib/types.mli
index f210ea8c9..06b811ba3 100644
--- a/ocaml/xapi-guard/lib/types.mli
+++ b/ocaml/xapi-guard/lib/types.mli
@@ -17,7 +17,7 @@ module Tpm : sig
(** [key_of_swtpm path] returns a state key represented by [path]. These paths
are parts of the requests generated by SWTPM and may contain slashes *)
- val deserialize_key : int -> key
+ val deserialize_key : int -> (key, string) Result.t
val serialize_key : key -> int
(** [serialize key] returns the state key represented by [key]. *)
diff --git a/ocaml/xapi-guard/test/cache_test.ml b/ocaml/xapi-guard/test/cache_test.ml
index 97b144839..3e51cab2c 100644
--- a/ocaml/xapi-guard/test/cache_test.ml
+++ b/ocaml/xapi-guard/test/cache_test.ml
@@ -12,7 +12,7 @@ module TPMs = struct
let request_persist uuid write =
let __FUN = __FUNCTION__ in
- let key = Tpm.deserialize_key (Random.int 3) in
+ let key = Tpm.deserialize_key (Random.int 3) |> Result.get_ok in
let time = Mtime_clock.now () in
let serial_n = Atomic.fetch_and_add writes_created 1 in
@@ -31,7 +31,7 @@ module TPMs = struct
let request_read uuid read =
let __FUN = __FUNCTION__ in
- let key = Tpm.deserialize_key (Random.int 3) in
+ let key = Tpm.deserialize_key (Random.int 3) |> Result.get_ok in
let time = Mtime_clock.now () in
let serial_n = Atomic.fetch_and_add reads_created 1 in
@@ -200,5 +200,6 @@ let main () =
Lwt.return_unit
let () =
+ Debug.log_to_stdout () ;
setup_log @@ Some Logs.Debug ;
Lwt_main.run (main ())
diff --git a/ocaml/xapi-storage/generator/lib/control.ml b/ocaml/xapi-storage/generator/lib/control.ml
index 93b2800a7..f4d8a22a4 100644
--- a/ocaml/xapi-storage/generator/lib/control.ml
+++ b/ocaml/xapi-storage/generator/lib/control.ml
@@ -30,6 +30,12 @@ type health =
(** Storage is busy recovering, e.g. rebuilding mirrors *)
[@@deriving rpcty]
+type volume_type =
+ | Data (** Normal data volume *)
+ | CBT_Metadata (** CBT Metadata only, data destroyed *)
+ | Data_and_CBT_Metadata (** Both Data and CBT Metadata *)
+[@@deriving rpcty]
+
(** Primary key for a specific Storage Repository. This can be any string
which is meaningful to the implementation. For example this could be an
NFS directory name, an LVM VG name or even a URI. This string is
@@ -116,6 +122,11 @@ type volume = {
; keys: (string * string) list
(** A list of key=value pairs which have been stored in the Volume
metadata. These should not be interpreted by the Volume plugin. *)
+ ; volume_type: volume_type option [@default Some Data]
+ (** The content type of this volume *)
+ ; cbt_enabled: bool option [@default Some false]
+ (** True means that the storage datapath will track changed dirty blocks
+ while writing and will be able to provide CBT Metadata when requested *)
}
[@@deriving rpcty]
diff --git a/ocaml/xapi-storage/generator/test/storage_test.ml b/ocaml/xapi-storage/generator/test/storage_test.ml
index eca6cf45a..3da8be647 100644
--- a/ocaml/xapi-storage/generator/test/storage_test.ml
+++ b/ocaml/xapi-storage/generator/test/storage_test.ml
@@ -57,6 +57,8 @@ let test_volume =
; physical_utilisation= 0L
; uri= ["uri1"]
; keys= []
+ ; cbt_enabled= Some false
+ ; volume_type= Some Data
}
(** Check that we successfully parse the responses and
diff --git a/ocaml/xapi-storage/rpc-light/SR.ls/response b/ocaml/xapi-storage/rpc-light/SR.ls/response
index b85cff59c..7f989e330 100644
--- a/ocaml/xapi-storage/rpc-light/SR.ls/response
+++ b/ocaml/xapi-storage/rpc-light/SR.ls/response
@@ -12,6 +12,8 @@
<member><name>physical_utilisation</name><value>0</value></member>
<member><name>uri</name><value><array><data><value>uri1</value></data></array></value></member>
<member><name>keys</name><value><struct></struct></value></member>
+ <member><name>volume_type</name><value>Data</value></member>
+ <member><name>cbt_enabled</name><value>false</value></member>
</struct></value></data>
</array></value></member>
</struct></value></param></params>
diff --git a/ocaml/xapi-storage/rpc-light/Volume.clone/response b/ocaml/xapi-storage/rpc-light/Volume.clone/response
index 4b0f52b23..dc4036f59 100644
--- a/ocaml/xapi-storage/rpc-light/Volume.clone/response
+++ b/ocaml/xapi-storage/rpc-light/Volume.clone/response
@@ -11,6 +11,8 @@
<member><name>physical_utilisation</name><value>0</value></member>
<member><name>uri</name><value><array><data><value>uri1</value></data></array></value></member>
<member><name>keys</name><value><struct></struct></value></member>
+ <member><name>volume_type</name><value>Data</value></member>
+ <member><name>cbt_enabled</name><value>false</value></member>
</struct>
</value></member>
</struct></value></param>
diff --git a/ocaml/xapi-storage/rpc-light/Volume.create/response b/ocaml/xapi-storage/rpc-light/Volume.create/response
index 4b0f52b23..dc4036f59 100644
--- a/ocaml/xapi-storage/rpc-light/Volume.create/response
+++ b/ocaml/xapi-storage/rpc-light/Volume.create/response
@@ -11,6 +11,8 @@
<member><name>physical_utilisation</name><value>0</value></member>
<member><name>uri</name><value><array><data><value>uri1</value></data></array></value></member>
<member><name>keys</name><value><struct></struct></value></member>
+ <member><name>volume_type</name><value>Data</value></member>
+ <member><name>cbt_enabled</name><value>false</value></member>
</struct>
</value></member>
</struct></value></param>
diff --git a/ocaml/xapi-storage/rpc-light/Volume.snapshot/response b/ocaml/xapi-storage/rpc-light/Volume.snapshot/response
index 4b0f52b23..dc4036f59 100644
--- a/ocaml/xapi-storage/rpc-light/Volume.snapshot/response
+++ b/ocaml/xapi-storage/rpc-light/Volume.snapshot/response
@@ -11,6 +11,8 @@
<member><name>physical_utilisation</name><value>0</value></member>
<member><name>uri</name><value><array><data><value>uri1</value></data></array></value></member>
<member><name>keys</name><value><struct></struct></value></member>
+ <member><name>volume_type</name><value>Data</value></member>
+ <member><name>cbt_enabled</name><value>false</value></member>
</struct>
</value></member>
</struct></value></param>
diff --git a/ocaml/xapi-types/features.ml b/ocaml/xapi-types/features.ml
index 37fafc090..d55d7d01c 100644
--- a/ocaml/xapi-types/features.ml
+++ b/ocaml/xapi-types/features.ml
@@ -64,6 +64,7 @@ type feature =
| Updates
| Internal_repo_access
| VTPM
+ | VM_anti_affinity
[@@deriving rpc]
type orientation = Positive | Negative
@@ -132,6 +133,9 @@ let keys_of_features =
, ("restrict_internal_repo_access", Negative, "Internal_repo_access")
)
; (VTPM, ("restrict_vtpm", Negative, "VTPM"))
+ ; ( VM_anti_affinity
+ , ("restrict_vm_anti_affinity", Negative, "VM_anti_affinity")
+ )
]
(* A list of features that must be considered "enabled" by `of_assoc_list`
diff --git a/ocaml/xapi-types/features.mli b/ocaml/xapi-types/features.mli
index c2f1ed2a5..0696b3ddb 100644
--- a/ocaml/xapi-types/features.mli
+++ b/ocaml/xapi-types/features.mli
@@ -72,6 +72,7 @@ type feature =
| Internal_repo_access
(** Enable restriction on repository access to pool members only *)
| VTPM (** Support VTPM device required by Win11 guests *)
+ | VM_anti_affinity (** Enable use of VM anti-affinity placement *)
val feature_of_rpc : Rpc.t -> feature
(** Convert RPC into {!feature}s *)
diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml
index 4179cf7d9..dce55ca4d 100644
--- a/ocaml/xapi/context.ml
+++ b/ocaml/xapi/context.ml
@@ -227,8 +227,64 @@ let parent_of_origin (origin : origin) span_name =
| _ ->
None
+let attribute_helper_fn f v = Option.fold ~none:[] ~some:f v
+
+let addr_port_of_sock s =
+ match s with
+ | None ->
+ (None, None)
+ | Some (Unix.ADDR_UNIX "") ->
+ (None, None)
+ | Some (Unix.ADDR_UNIX socket_name) ->
+ (Some socket_name, None)
+ | Some (Unix.ADDR_INET (addr, port)) ->
+ (Some (Unix.string_of_inet_addr addr), Some (string_of_int port))
+
+let with_try_get_addr f s =
+ (try Some (f s) with Unix.Unix_error (Unix.ENOTSOCK, _, _) -> None)
+ |> addr_port_of_sock
+
+let attr_of_fd s =
+ let peer_addr, peer_port = s |> with_try_get_addr Unix.getpeername in
+ let local_addr, local_port = s |> with_try_get_addr Unix.getsockname in
+ [
+ attribute_helper_fn
+ (fun addr -> [("network.local.address", addr)])
+ local_addr
+ ; attribute_helper_fn (fun port -> [("network.local.port", port)]) local_port
+ ; attribute_helper_fn (fun addr -> [("network.peer.address", addr)]) peer_addr
+ ; attribute_helper_fn (fun port -> [("network.peer.port", port)]) peer_port
+ ]
+ |> List.concat
+
+let attr_of_req (req : Http.Request.t) =
+ [
+ [
+ ("xs.xapi.task.origin", "http")
+ ; ("http.request.header.method", Http.string_of_method_t req.m)
+ ]
+ ; attribute_helper_fn
+ (fun user_agent -> [("http.request.header.user-agent", user_agent)])
+ req.user_agent
+ ; attribute_helper_fn
+ (fun content_type -> [("http.request.header.content-type", content_type)])
+ req.content_type
+ ; attribute_helper_fn
+ (fun content_length ->
+ [("http.request.body.size", Printf.sprintf "%Li" content_length)]
+ )
+ req.content_length
+ ; List.map
+ (fun (h, v) ->
+ ( h |> String.lowercase_ascii |> Printf.sprintf "http.request.header.%s"
+ , v
+ )
+ )
+ req.additional_headers
+ ]
+ |> List.concat
+
let make_attributes ?task_name ?task_id ?task_uuid ?session_id ?origin () =
- let attribute_helper_fn f v = Option.fold ~none:[] ~some:f v in
[
attribute_helper_fn
(fun task_name -> [("xs.xapi.task.name", task_name)])
@@ -249,8 +305,8 @@ let make_attributes ?task_name ?task_id ?task_uuid ?session_id ?origin () =
match origin with
| Internal ->
[("xs.xapi.task.origin", "internal")]
- | Http _ ->
- [("xs.xapi.task.origin", "http")]
+ | Http (req, s) ->
+ [attr_of_req req; attr_of_fd s] |> List.concat
)
origin
]
diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune
index 45d5e67aa..fe161e0dd 100644
--- a/ocaml/xapi/dune
+++ b/ocaml/xapi/dune
@@ -73,6 +73,7 @@
hex
http_lib
ipaddr
+ magic-mime
message-switch-core
message-switch-unix
mirage-crypto
diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml
index 49ccc7b0c..c549fb742 100644
--- a/ocaml/xapi/export.ml
+++ b/ocaml/xapi/export.ml
@@ -52,7 +52,7 @@ let make_id =
"Ref:" ^ string_of_int this
let rec update_table ~__context ~include_snapshots ~preserve_power_state
- ~include_vhd_parents ~table vm =
+ ~include_vhd_parents ~table ~excluded_devices vm =
let add r =
if not (Hashtbl.mem table (Ref.string_of r)) then
Hashtbl.add table (Ref.string_of r) (make_id ())
@@ -77,6 +77,7 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state
then (
add vm ;
let vm = Db.VM.get_record ~__context ~self:vm in
+ if not (List.mem Devicetype.VIF excluded_devices) then
List.iter
(fun vif ->
if Db.is_valid_ref __context vif then (
@@ -86,6 +87,7 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state
)
)
vm.API.vM_VIFs ;
+ if not (List.mem Devicetype.VBD excluded_devices) then
List.iter
(fun vbd ->
if Db.is_valid_ref __context vbd then (
@@ -96,6 +98,7 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state
)
)
vm.API.vM_VBDs ;
+ if not (List.mem Devicetype.VGPU excluded_devices) then
List.iter
(fun vgpu ->
if Db.is_valid_ref __context vgpu then (
@@ -107,8 +110,7 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state
)
vm.API.vM_VGPUs ;
(* add all PVS proxies that have a VIF belonging to this VM, add their
- * PVS sites as well
- *)
+ PVS sites as well *)
Db.PVS_proxy.get_all_records ~__context
|> List.filter (fun (_, p) -> List.mem p.API.pVS_proxy_VIF vm.API.vM_VIFs)
|> List.iter (fun (ref, proxy) ->
@@ -118,6 +120,7 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state
)
) ;
(* add VTPMs that belong to this VM *)
+ if not (List.mem Devicetype.VTPM excluded_devices) then
vm.API.vM_VTPMs
|> List.iter (fun ref -> if Db.is_valid_ref __context ref then add ref) ;
@@ -126,7 +129,7 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state
List.iter
(fun snap ->
update_table ~__context ~include_snapshots:false ~preserve_power_state
- ~include_vhd_parents ~table snap
+ ~include_vhd_parents ~table ~excluded_devices snap
)
vm.API.vM_snapshots ;
(* If VM is suspended then add the suspend_VDI *)
@@ -145,7 +148,7 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state
(* Add the parent VM *)
if include_snapshots && Db.is_valid_ref __context vm.API.vM_parent then
update_table ~__context ~include_snapshots:false ~preserve_power_state
- ~include_vhd_parents ~table vm.API.vM_parent
+ ~include_vhd_parents ~table ~excluded_devices vm.API.vM_parent
)
(** Walk the graph of objects and update the table of Ref -> ids for each object we wish
@@ -580,11 +583,11 @@ let make_all ~with_snapshot_metadata ~preserve_power_state table __context =
on metadata-export, include snapshots fields of the exported VM as well as the VM records of VMs
which are snapshots of the exported VM. *)
let vm_metadata ~with_snapshot_metadata ~preserve_power_state
- ~include_vhd_parents ~__context ~vms =
+ ~include_vhd_parents ~__context ~vms ~excluded_devices =
let table = create_table () in
List.iter
(update_table ~__context ~include_snapshots:with_snapshot_metadata
- ~preserve_power_state ~include_vhd_parents ~table
+ ~preserve_power_state ~include_vhd_parents ~table ~excluded_devices
)
vms ;
let objects =
@@ -603,31 +606,31 @@ let string_of_vm ~__context vm =
(** Export a VM's metadata only *)
let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state
- ~include_vhd_parents ~vms s =
+ ~include_vhd_parents ~vms ~excluded_devices s =
+ let infomsg vm =
+ info
+ "VM.export_metadata: VM = %s; with_snapshot_metadata = '%b'; \
+ include_vhd_parents = '%b'; preserve_power_state = '%s'; \
+ excluded_devices = '%s'"
+ vm with_snapshot_metadata include_vhd_parents
+ (string_of_bool preserve_power_state)
+ (String.concat ", " (List.map Devicetype.to_string excluded_devices))
+ in
+ let now = Date.now () |> Date.to_unix_time |> Int64.of_float in
( match vms with
| [] ->
failwith "need to specify at least one VM"
| [vm] ->
- info
- "VM.export_metadata: VM = %s; with_snapshot_metadata = '%b'; \
- include_vhd_parents = '%b'; preserve_power_state = '%s"
- (string_of_vm ~__context vm)
- with_snapshot_metadata include_vhd_parents
- (string_of_bool preserve_power_state)
+ infomsg (string_of_vm ~__context vm)
| vms ->
- info
- "VM.export_metadata: VM = %s; with_snapshot_metadata = '%b'; \
- preserve_power_state = '%s"
- (String.concat ", " (List.map (string_of_vm ~__context) vms))
- with_snapshot_metadata
- (string_of_bool preserve_power_state)
+ infomsg (String.concat ", " (List.map (string_of_vm ~__context) vms))
) ;
let _, ova_xml =
vm_metadata ~with_snapshot_metadata ~preserve_power_state
- ~include_vhd_parents ~__context ~vms
+ ~include_vhd_parents ~__context ~vms ~excluded_devices
in
let hdr =
- Tar.Header.make Xapi_globs.ova_xml_filename
+ Tar.Header.make ~mod_time:now Xapi_globs.ova_xml_filename
(Int64.of_int @@ String.length ova_xml)
in
Tar_helpers.write_block hdr (fun s -> Unixext.really_write_string s ova_xml) s ;
@@ -635,16 +638,17 @@ let export_metadata ~__context ~with_snapshot_metadata ~preserve_power_state
let export refresh_session __context rpc session_id s vm_ref
preserve_power_state =
+ let now = Date.now () |> Date.to_unix_time |> Int64.of_float in
info "VM.export: VM = %s; preserve_power_state = '%s'"
(string_of_vm ~__context vm_ref)
(string_of_bool preserve_power_state) ;
let table, ova_xml =
vm_metadata ~with_snapshot_metadata:false ~preserve_power_state
- ~include_vhd_parents:false ~__context ~vms:[vm_ref]
+ ~include_vhd_parents:false ~__context ~vms:[vm_ref] ~excluded_devices:[]
in
debug "Outputting ova.xml" ;
let hdr =
- Tar.Header.make Xapi_globs.ova_xml_filename
+ Tar.Header.make ~mod_time:now Xapi_globs.ova_xml_filename
(Int64.of_int @@ String.length ova_xml)
in
Tar_helpers.write_block hdr (fun s -> Unixext.really_write_string s ova_xml) s ;
@@ -716,35 +720,43 @@ let vm_from_request ~__context (req : Request.t) =
Client.VM.get_by_uuid ~rpc ~session_id ~uuid
)
-let bool_from_request ~__context (req : Request.t) default k =
- if List.mem_assoc k req.Request.query then
- bool_of_string (List.assoc k req.Request.query)
- else
- default
+let arg_from_request (req : Request.t) k = List.assoc_opt k req.Request.query
+
+let bool_from_request req default k =
+ arg_from_request req k |> Option.fold ~none:default ~some:bool_of_string
+
+let devicetypelist_from_request req default k =
+ let to_list = function
+ | "" ->
+ []
+ | x ->
+ String.split_on_char ',' x |> List.map Devicetype.of_string
+ in
+ arg_from_request req k |> Option.fold ~none:default ~some:to_list
+
+let export_all_vms_from_request req = bool_from_request req false "all"
-let export_all_vms_from_request ~__context (req : Request.t) =
- bool_from_request ~__context req false "all"
+let include_vhd_parents_from_request req =
+ bool_from_request req false "include_vhd_parents"
-let include_vhd_parents_from_request ~__context (req : Request.t) =
- bool_from_request ~__context req false "include_vhd_parents"
+let export_snapshots_from_request req =
+ bool_from_request req true "export_snapshots"
-let export_snapshots_from_request ~__context (req : Request.t) =
- bool_from_request ~__context req true "export_snapshots"
+let include_dom0_from_request req = bool_from_request req true "include_dom0"
-let include_dom0_from_request ~__context (req : Request.t) =
- bool_from_request ~__context req true "include_dom0"
+let excluded_devices_from_request req =
+ devicetypelist_from_request req [] "excluded_device_types"
let metadata_handler (req : Request.t) s _ =
debug "metadata_handler called" ;
req.Request.close <- true ;
(* Xapi_http.with_context always completes the task at the end *)
Xapi_http.with_context "VM.export_metadata" req s (fun __context ->
- let include_vhd_parents =
- include_vhd_parents_from_request ~__context req
- in
- let export_all = export_all_vms_from_request ~__context req in
- let export_snapshots = export_snapshots_from_request ~__context req in
- let include_dom0 = include_dom0_from_request ~__context req in
+ let include_vhd_parents = include_vhd_parents_from_request req in
+ let export_all = export_all_vms_from_request req in
+ let export_snapshots = export_snapshots_from_request req in
+ let include_dom0 = include_dom0_from_request req in
+ let excluded_devices = excluded_devices_from_request req in
(* Get the VM refs. In case of exporting the metadata of a particular VM, return a singleton list containing the vm ref. *)
(* In case of exporting all the VMs metadata, get all the VM records which are not default templates. *)
let vm_refs =
@@ -771,16 +783,6 @@ let metadata_handler (req : Request.t) s _ =
else
[vm_from_request ~__context req]
in
- if
- (not export_all)
- && Db.VM.get_is_a_snapshot ~__context ~self:(List.hd vm_refs)
- then
- raise
- (Api_errors.Server_error
- ( Api_errors.operation_not_allowed
- , ["Exporting metadata of a snapshot is not allowed"]
- )
- ) ;
let task_id = Ref.string_of (Context.get_task_id __context) in
let read_fd, write_fd = Unix.pipe () in
let export_error = ref None in
@@ -800,7 +802,7 @@ let metadata_handler (req : Request.t) s _ =
vm_refs ;
export_metadata ~with_snapshot_metadata:export_snapshots
~preserve_power_state:true ~include_vhd_parents
- ~__context ~vms:vm_refs write_fd
+ ~excluded_devices ~__context ~vms:vm_refs write_fd
)
(fun () ->
Unix.close write_fd ;
diff --git a/ocaml/xapi/fileserver.ml b/ocaml/xapi/fileserver.ml
index 1c4cf9520..ed9ed334d 100644
--- a/ocaml/xapi/fileserver.ml
+++ b/ocaml/xapi/fileserver.ml
@@ -42,40 +42,8 @@ let missing uri =
^ " was not found on this server.</p> <hr><address>Xapi \
Server</address></body></html>"
-let get_extension filename =
- try
- let basename = Filename.basename filename in
- let i = String.rindex basename '.' in
- Some (String.sub basename (i + 1) (String.length basename - i - 1))
- with _ -> None
-
-let application_octet_stream = "application/octet-stream"
-
-let mime_of_extension = function
- | "html" | "htm" ->
- "text/html"
- | "css" ->
- "text/css"
- | "js" ->
- "application/javascript"
- | "gif" ->
- "image/gif"
- | "png" ->
- "image/png"
- | "jpg" | "jpeg" ->
- "image/jpeg"
- | "xml" ->
- "application/xml"
- | "rpm" ->
- "application/x-rpm"
- | _ ->
- application_octet_stream
-
let response_file s file_path =
- let mime_content_type =
- let ext = Option.map String.lowercase_ascii (get_extension file_path) in
- Option.fold ~none:application_octet_stream ~some:mime_of_extension ext
- in
+ let mime_content_type = Magic_mime.lookup file_path in
let hsts_time = !Xapi_globs.hsts_max_age in
Http_svr.response_file ~mime_content_type ~hsts_time s file_path
diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml
index fd6d898b1..01e5ca256 100644
--- a/ocaml/xapi/import.ml
+++ b/ocaml/xapi/import.ml
@@ -2158,12 +2158,19 @@ let complete_import ~__context vmrefs =
Xapi_vm_lifecycle.update_allowed_operations ~__context ~self:vm
)
vmrefs ;
- (* We only keep VMs which are not snapshot *)
+ (* When only snapshots have been imported, return all of them.
+ Otherwise, only keep VMs which are not snapshots *)
let vmrefs =
+ let non_snapshots =
List.filter
- (fun vmref -> not (Db.VM.get_is_a_snapshot ~__context ~self:vmref))
+ (fun x -> not (Db.VM.get_is_a_snapshot ~__context ~self:x))
vmrefs
in
+ if non_snapshots = [] then
+ vmrefs
+ else
+ non_snapshots
+ in
(* We only set the result on the task since it is officially completed later. *)
TaskHelper.set_result ~__context (Some (API.rpc_of_ref_VM_set vmrefs))
with e ->
diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml
index a7354fce4..f90a8da80 100644
--- a/ocaml/xapi/importexport.ml
+++ b/ocaml/xapi/importexport.ml
@@ -469,6 +469,37 @@ module Format = struct
(* default *)
end
+module Devicetype = struct
+ type t = VIF | VBD | VGPU | VTPM
+
+ let all = [VIF; VBD; VGPU; VTPM]
+
+ let to_string = function
+ | VIF ->
+ "vif"
+ | VBD ->
+ "vbd"
+ | VGPU ->
+ "vgpu"
+ | VTPM ->
+ "vtpm"
+
+ let of_string x =
+ match String.lowercase_ascii x with
+ | "vif" ->
+ VIF
+ | "vbd" ->
+ VBD
+ | "vgpu" ->
+ VGPU
+ | "vtpm" ->
+ VTPM
+ | other ->
+ let fail fmt = Printf.kprintf failwith fmt in
+ fail "%s: Type '%s' not one of [%s]" __FUNCTION__ other
+ (String.concat "; " (List.map to_string all))
+end
+
let return_302_redirect (req : Http.Request.t) s address =
let address = Http.Url.maybe_wrap_IPv6_literal address in
let url =
diff --git a/ocaml/xapi/sm.ml b/ocaml/xapi/sm.ml
index 2526aa79b..0ae899f63 100644
--- a/ocaml/xapi/sm.ml
+++ b/ocaml/xapi/sm.ml
@@ -152,7 +152,7 @@ let sr_update ~dbg dconf driver sr =
let call = Sm_exec.make_call ~sr_ref:sr dconf "sr_update" [] in
Sm_exec.parse_unit (Sm_exec.exec_xmlrpc ~dbg (driver_filename driver) call)
-let vdi_create ~dbg dconf driver sr sm_config vdi_type size name_label
+let vdi_create ~dbg ?vdi_uuid dconf driver sr sm_config vdi_type size name_label
name_description metadata_of_pool is_a_snapshot snapshot_time snapshot_of
read_only =
with_dbg ~dbg ~name:"vdi_create" @@ fun di ->
@@ -164,8 +164,8 @@ let vdi_create ~dbg dconf driver sr sm_config vdi_type size name_label
) ;
srmaster_only dconf ;
let call =
- Sm_exec.make_call ~sr_ref:sr ~vdi_sm_config:sm_config ~vdi_type dconf
- "vdi_create"
+ Sm_exec.make_call ?vdi_uuid ~sr_ref:sr ~vdi_sm_config:sm_config ~vdi_type
+ dconf "vdi_create"
[
sprintf "%Lu" size
; name_label
diff --git a/ocaml/xapi/sm_exec.ml b/ocaml/xapi/sm_exec.ml
index a6d0d231e..a55b61d72 100644
--- a/ocaml/xapi/sm_exec.ml
+++ b/ocaml/xapi/sm_exec.ml
@@ -69,8 +69,8 @@ type call = {
}
let make_call ?driver_params ?sr_sm_config ?vdi_sm_config ?vdi_type
- ?vdi_location ?new_uuid ?sr_ref ?vdi_ref (subtask_of, device_config) cmd
- args =
+ ?vdi_location ?new_uuid ?sr_ref ?vdi_ref ?vdi_uuid
+ (subtask_of, device_config) cmd args =
Server_helpers.exec_with_new_task "sm_exec" (fun __context ->
(* Only allow a subset of calls if the SR has been introduced by a DR task. *)
Option.iter
@@ -117,7 +117,22 @@ let make_call ?driver_params ?sr_sm_config ?vdi_sm_config ?vdi_type
Option.map (fun self -> Db.VDI.get_location ~__context ~self) vdi_ref
in
let vdi_uuid =
- Option.map (fun self -> Db.VDI.get_uuid ~__context ~self) vdi_ref
+ match (cmd, vdi_ref, vdi_uuid) with
+ | "vdi_create", None, (Some x as uuid) ->
+ debug "%s: cmd=%s vdi_uuid=%s" __FUNCTION__ cmd x ;
+ uuid
+ (* when creating a VDI we sometimes want to provide the UUID
+ rather than letting the backend pick one. This is to
+ support backup VDIs CP-46179. So in that case, use the
+ provided UUID but not for other commands *)
+ | _, None, Some uuid ->
+ warn "%s: cmd=%s vdi_uuid=%s - should not happen" __FUNCTION__ cmd
+ uuid ;
+ None
+ | _, Some self, _ ->
+ Db.VDI.get_uuid ~__context ~self |> Option.some
+ | _, None, None ->
+ None
in
let vdi_on_boot =
Option.map
diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml
index 9ca3660ee..c7bdd772a 100644
--- a/ocaml/xapi/storage_smapiv1.ml
+++ b/ocaml/xapi/storage_smapiv1.ml
@@ -691,19 +691,33 @@ module SMAPIv1 : Server_impl = struct
let uuid = require_uuid vi in
vdi_info_from_db ~__context (Db.VDI.get_by_uuid ~__context ~uuid)
- let create _context ~dbg ~sr ~vdi_info =
+ let create _context ~dbg ~sr ~(vdi_info : Storage_interface.vdi_info) =
with_dbg ~name:"VDI.create" ~dbg @@ fun di ->
let dbg = Debuginfo.to_string di in
try
Server_helpers.exec_with_new_task "VDI.create"
~subtask_of:(Ref.of_string dbg) (fun __context ->
- let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr) in
+ let sr_uuid = s_of_sr sr in
+ let sr = Db.SR.get_by_uuid ~__context ~uuid:sr_uuid in
let vi =
+ (* we want to set vdi_uuid when creating a backup VDI with
+ a specific UUID. SM picks up vdi_uuid instead of creating
+ a new random UUID; Cf. Xapi_vdi.create *)
+ let vdi_uuid =
+ match vdi_info.uuid with
+ | Some uuid when uuid = Uuidx.(Hash.string sr_uuid |> to_string)
+ ->
+ info "%s: creating a backup VDI %s" __FUNCTION__ uuid ;
+ vdi_info.uuid
+ | _ ->
+ None
+ in
Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type ->
- Sm.vdi_create ~dbg device_config _type sr vdi_info.sm_config
- vdi_info.ty vdi_info.virtual_size vdi_info.name_label
- vdi_info.name_description vdi_info.metadata_of_pool
- vdi_info.is_a_snapshot vdi_info.snapshot_time
+ Sm.vdi_create ~dbg ?vdi_uuid device_config _type sr
+ vdi_info.sm_config vdi_info.ty vdi_info.virtual_size
+ vdi_info.name_label vdi_info.name_description
+ vdi_info.metadata_of_pool vdi_info.is_a_snapshot
+ vdi_info.snapshot_time
(s_of_vdi vdi_info.snapshot_of)
vdi_info.read_only
)
diff --git a/ocaml/xapi/stream_vdi.ml b/ocaml/xapi/stream_vdi.ml
index 64b1da93e..3c27d158a 100644
--- a/ocaml/xapi/stream_vdi.ml
+++ b/ocaml/xapi/stream_vdi.ml
@@ -163,6 +163,31 @@ let get_nbd_device path =
else
None
+(* Copied from vhd-tool/src/image.ml.
+ * Just keep the situation of xapi doesn't depend on vhd-tool OCaml module.
+ *)
+let image_behind_nbd_device = function
+ | Some (path, _exportname) as image ->
+ (* The nbd server path exposed by tapdisk can lead us to the actual image
+ file below. Following the symlink gives a path like
+ `/run/blktap-control/nbd<pid>.<minor>`,
+ containing the tapdisk pid and minor number. Using this information,
+ we can get the file path from tap-ctl.
+ *)
+ let default _ _ = image in
+ let filename = Unix.realpath path |> Filename.basename in
+ Scanf.ksscanf filename default "nbd%d.%d" (fun pid minor ->
+ match Tapctl.find (Tapctl.create ()) ~pid ~minor with
+ | _, _, Some ("vhd", vhd) ->
+ Some ("vhd", vhd)
+ | _, _, Some ("aio", vhd) ->
+ Some ("raw", vhd)
+ | _, _, _ | (exception _) ->
+ None
+ )
+ | _ ->
+ None
+
type extent = {flags: int32; length: int64} [@@deriving rpc]
type extent_list = extent list [@@deriving rpc]
diff --git a/ocaml/xapi/vhd_tool_wrapper.ml b/ocaml/xapi/vhd_tool_wrapper.ml
index 7e22dc865..6fe4e40d7 100644
--- a/ocaml/xapi/vhd_tool_wrapper.ml
+++ b/ocaml/xapi/vhd_tool_wrapper.ml
@@ -170,9 +170,16 @@ let vhd_of_device path =
| _, _, _ ->
raise Not_found
with
- | Tapctl.Not_blktap ->
+ | Tapctl.Not_blktap -> (
debug "Device %s is not controlled by blktap" path ;
+ (* Check if it is a VHD behind a NBD deivce *)
+ Stream_vdi.(get_nbd_device path |> image_behind_nbd_device) |> function
+ | Some ("vhd", vhd) ->
+ debug "%s is a VHD behind NBD device %s" vhd path ;
+ Some vhd
+ | _ ->
None
+ )
| Tapctl.Not_a_device ->
debug "%s is not a device" path ;
None
@@ -186,15 +193,18 @@ let send progress_cb ?relative_to (protocol : string) (dest_format : string)
(s : Unix.file_descr) (path : string) (size : Int64.t) (prefix : string) =
let s' = Uuidx.(to_string (make ())) in
let source_format, source =
- match (Stream_vdi.get_nbd_device path, vhd_of_device path) with
- | Some (nbd_server, exportname), _ ->
+ match (Stream_vdi.get_nbd_device path, vhd_of_device path, relative_to) with
+ | Some (nbd_server, exportname), _, None ->
( "nbdhybrid"
, Printf.sprintf "%s:%s:%s:%Ld" path nbd_server exportname size
)
- | None, Some vhd ->
+ | Some _, Some vhd, Some _ | None, Some vhd, _ ->
("hybrid", path ^ ":" ^ vhd)
- | None, None ->
+ | None, None, None ->
("raw", path)
+ | _, None, Some _ ->
+ let msg = "Cannot compute differences on non-VHD images" in
+ error "%s" msg ; failwith msg
in
let relative_to =
match relative_to with
diff --git a/ocaml/xapi/xapi_dr.ml b/ocaml/xapi/xapi_dr.ml
index e9c1c53ad..bdbb4dee6 100644
--- a/ocaml/xapi/xapi_dr.ml
+++ b/ocaml/xapi/xapi_dr.ml
@@ -245,6 +245,7 @@ let create_import_objects ~__context ~vms =
List.iter
(Export.update_table ~__context ~include_snapshots:true
~preserve_power_state:true ~include_vhd_parents:false ~table
+ ~excluded_devices:[]
)
vms ;
Export.make_all ~with_snapshot_metadata:true ~preserve_power_state:true table
diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml
index 040f57822..00f01d83e 100644
--- a/ocaml/xapi/xapi_host_helpers.ml
+++ b/ocaml/xapi/xapi_host_helpers.ml
@@ -26,19 +26,7 @@ let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute
let finally = Xapi_stdext_pervasives.Pervasiveext.finally
-let all_operations =
- [
- `provision
- ; `evacuate
- ; `reboot
- ; `shutdown
- ; `vm_start
- ; `vm_resume
- ; `vm_migrate
- ; `power_on
- ; `apply_updates
- ; `enable
- ]
+let all_operations = API.host_allowed_operations__all
(** Returns a table of operations -> API error options (None if the operation would be ok) *)
let valid_operations ~__context record _ref' =
diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml
index b44c8bf59..8f7a7d801 100644
--- a/ocaml/xapi/xapi_sr_operations.ml
+++ b/ocaml/xapi/xapi_sr_operations.ml
@@ -26,29 +26,7 @@ open Client
open Record_util
-let all_ops : API.storage_operations_set =
- [
- `scan
- ; `destroy
- ; `forget
- ; `plug
- ; `unplug
- ; `vdi_create
- ; `vdi_destroy
- ; `vdi_resize
- ; `vdi_clone
- ; `vdi_snapshot
- ; `vdi_mirror
- ; `vdi_enable_cbt
- ; `vdi_disable_cbt
- ; `vdi_data_destroy
- ; `vdi_list_changed_blocks
- ; `vdi_set_on_boot
- ; `vdi_introduce
- ; `update
- ; `pbd_create
- ; `pbd_destroy
- ]
+let all_ops = API.storage_operations__all
(* This list comes from https://github.com/xenserver/xen-api/blob/tampa-bugfix/ocaml/xapi/xapi_sr_operations.ml#L36-L38 *)
let all_rpu_ops : API.storage_operations_set =
diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml
index ac989551b..bc7bafb23 100644
--- a/ocaml/xapi/xapi_vdi.ml
+++ b/ocaml/xapi/xapi_vdi.ml
@@ -625,13 +625,27 @@ let create ~__context ~name_label ~name_description ~sR ~virtual_size ~_type
| `cbt_metadata ->
"cbt_metadata"
in
+ (* special case: we want to use a specific UUID for Pool Meta Data
+ Backup *)
+ let uuid_ =
+ match (_type, name_label) with
+ | `user, "Pool Metadata Backup" ->
+ let sr = Db.SR.get_uuid ~__context ~self:sR in
+ let uuid = Uuidx.(Hash.string sr |> to_string) in
+ info "%s: using deterministic UUID for '%s' VDI: %s" __FUNCTION__
+ name_label uuid ;
+ Some uuid
+ | _ ->
+ None
+ in
let open Storage_access in
let task = Context.get_task_id __context in
let open Storage_interface in
let vdi_info =
{
Storage_interface.default_vdi_info with
- name_label
+ uuid= uuid_
+ ; name_label
; name_description
; ty= vdi_type
; read_only
diff --git a/ocaml/xapi/xapi_vdi_helpers.ml b/ocaml/xapi/xapi_vdi_helpers.ml
index 2e3355ef1..6b4366a80 100644
--- a/ocaml/xapi/xapi_vdi_helpers.ml
+++ b/ocaml/xapi/xapi_vdi_helpers.ml
@@ -26,26 +26,7 @@ module D = Debug.Make (struct let name = "xapi_vdi_helpers" end)
open D
-let all_ops : API.vdi_operations_set =
- [
- `blocked
- ; `clone
- ; `copy
- ; `data_destroy
- ; `destroy
- ; `disable_cbt
- ; `enable_cbt
- ; `force_unlock
- ; `forget
- ; `generate_config
- ; `list_changed_blocks
- ; `mirror
- ; `resize
- ; `resize_online
- ; `set_on_boot
- ; `snapshot
- ; `update
- ]
+let all_ops = API.vdi_operations__all
(* CA-26514: Block operations on 'unmanaged' VDIs *)
let assert_managed ~__context ~vdi =
diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml
index d90da3961..ccee66500 100644
--- a/ocaml/xapi/xapi_vm_lifecycle.ml
+++ b/ocaml/xapi/xapi_vm_lifecycle.ml
@@ -749,49 +749,41 @@ let vtpm_update_allowed_operations ~__context ~self =
let allowed = match state with `Halted -> ops | _ -> [] in
Db.VTPM.set_allowed_operations ~__context ~self ~value:allowed
+let ignored_ops =
+ [
+ `create_template
+ ; `power_state_reset
+ ; `csvm
+ ; `get_boot_record
+ ; `send_sysrq
+ ; `send_trigger
+ ; `query_services
+ ; `shutdown
+ ; `call_plugin
+ ; `changing_memory_live
+ ; `awaiting_memory_live
+ ; `changing_memory_limits
+ ; `changing_shadow_memory_live
+ ; `changing_VCPUs
+ ; `assert_operation_valid
+ ; `data_source_op
+ ; `update_allowed_operations
+ ; `import
+ ; `reverting
+ ]
+
+let allowable_ops =
+ List.filter (fun op -> not (List.mem op ignored_ops)) API.vm_operations__all
+
let update_allowed_operations ~__context ~self =
- let check_operation_error = check_operation_error ~__context ~ref:self in
let check accu op =
- match check_operation_error ~op ~strict:true with
+ match check_operation_error ~__context ~ref:self ~op ~strict:true with
| None ->
op :: accu
- | _ ->
+ | Some _err ->
accu
in
- let allowed =
- List.fold_left check []
- [
- `snapshot
- ; `copy
- ; `clone
- ; `revert
- ; `checkpoint
- ; `snapshot_with_quiesce
- ; `start
- ; `start_on
- ; `pause
- ; `unpause
- ; `clean_shutdown
- ; `clean_reboot
- ; `hard_shutdown
- ; `hard_reboot
- ; `suspend
- ; `resume
- ; `resume_on
- ; `export
- ; `destroy
- ; `provision
- ; `changing_VCPUs_live
- ; `pool_migrate
- ; `migrate_send
- ; `make_into_template
- ; `changing_static_range
- ; `changing_shadow_memory
- ; `changing_dynamic_range
- ; `changing_NVRAM
- ; `create_vtpm
- ]
- in
+ let allowed = List.fold_left check [] allowable_ops in
(* FIXME: need to be able to deal with rolling-upgrade for orlando as well *)
let allowed =
if Helpers.rolling_upgrade_in_progress ~__context then
diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml
index ec883f3de..0eb6ef5ac 100644
--- a/ocaml/xenopsd/cli/xn.ml
+++ b/ocaml/xenopsd/cli/xn.ml
@@ -65,74 +65,6 @@ let diagnose_error f =
exit 1
)
-let usage () =
- Printf.fprintf stderr
- "%s <command> [args] - send commands to the xenops daemon\n" Sys.argv.(0) ;
- Printf.fprintf stderr "%s add <config> - add a VM from <config>\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s list [verbose] - query the states of known VMs\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s remove <name or id> - forget about a VM\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s start <name or id> [paused] - start a VM\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s pause <name or id> - pause a VM\n" Sys.argv.(0) ;
- Printf.fprintf stderr "%s unpause <name or id> - unpause a VM\n" Sys.argv.(0) ;
- Printf.fprintf stderr "%s shutdown <name or id> - shutdown a VM\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s reboot <name or id> - reboot a VM\n" Sys.argv.(0) ;
- Printf.fprintf stderr "%s suspend <name or id> <disk> - suspend a VM\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s resume <name or id> <disk> - resume a VM\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s migrate <name or id> <url> - migrate a VM to <url>\n" Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s vbd-list <name or id> - query the states of a VM's block devices\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s console-list <name or id> - query the states of a VM's consoles\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s pci-add <name or id> <number> <bdf> - associate the PCI device <bdf> \
- with <name or id>\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s pci-remove <name or id> <number> - disassociate the PCI device <bdf> \
- with <name or id>\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s pci-list <name or id> - query the states of a VM's PCI devices\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s cd-insert <id> <disk> - insert a CD into a VBD\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s cd-eject <id> - eject a CD from a VBD\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s export-metadata <id> - export metadata associated with <id>\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s export-metadata-xm <id> - export metadata associated with <id> in xm \
- format\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s delay <id> <time> - add an explicit delay of length <time> to this \
- VM's queue\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s events-watch - display all events generated by the server\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr
- "%s set-worker-pool-size <threads> - set the size of the worker pool\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s diagnostics - display diagnostic information\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s task-list - display the state of all known tasks\n"
- Sys.argv.(0) ;
- Printf.fprintf stderr "%s shutdown - shutdown the xenops service\n"
- Sys.argv.(0) ;
- ()
-
let dbg = "xn"
let finally = Xapi_stdext_pervasives.Pervasiveext.finally
@@ -905,12 +837,6 @@ let export copts metadata xm filename (x : Vm.id option) () =
let export copts metadata xm filename x =
diagnose_error (export copts metadata xm filename x)
-let delay x t =
- let vm, _ = find_by_name x in
- Client.VM.delay dbg vm.Vm.id t
- |> wait_for_task dbg
- |> success_task ignore_task
-
let import_metadata _copts filename =
let ic = open_in filename in
let buf = Buffer.create 128 in
@@ -1014,99 +940,6 @@ let resume _copts disk x =
let resume copts disk x = diagnose_error (need_vm (resume copts disk) x)
-let migrate ~id ~url ~compress ~verify_dest =
- let vm, _ = find_by_name id in
- let bool b =
- match String.lowercase_ascii b with
- | "t" | "true" | "on" | "1" ->
- true
- | _ ->
- false
- in
- Client.VM.migrate dbg vm.Vm.id [] [] [] url (bool compress) (bool verify_dest)
- |> wait_for_task dbg
-
-let trim limit str =
- let l = String.length str in
- if l < limit then
- str
- else
- "..." ^ String.sub str (l - limit + 3) (limit - 3)
-
-let vbd_list x =
- let vm, _ = find_by_name x in
- let vbds = Client.VBD.list dbg vm.Vm.id in
- let line id position mode ty plugged disk disk2 =
- Printf.sprintf "%-10s %-8s %-4s %-5s %-7s %-35s %-35s " id position mode ty
- plugged disk disk2
- in
- let header =
- line "id" "position" "mode" "type" "plugged" "disk" "xenstore_disk"
- in
- let lines =
- List.map
- (fun (vbd, state) ->
- let id = snd vbd.Vbd.id in
- let position =
- match vbd.Vbd.position with
- | None ->
- "None"
- | Some x ->
- Device_number.to_linux_device x
- in
- let mode = if vbd.Vbd.mode = Vbd.ReadOnly then "RO" else "RW" in
- let ty =
- match vbd.Vbd.ty with
- | Vbd.CDROM ->
- "CDROM"
- | Vbd.Floppy ->
- "Floppy"
- | Vbd.Disk ->
- "HDD"
- in
- let plugged = if state.Vbd.plugged then "X" else " " in
- let disk =
- match vbd.Vbd.backend with
- | None ->
- ""
- | Some (Local x) ->
- x |> trim 32
- | Some (VDI path) ->
- path |> trim 32
- in
- let info = Client.VBD.stat dbg vbd.Vbd.id in
- let disk2 =
- match (snd info).Vbd.backend_present with
- | None ->
- ""
- | Some (Local x) ->
- x |> trim 32
- | Some (VDI path) ->
- path |> trim 32
- in
- line id position mode ty plugged disk disk2
- )
- vbds
- in
- List.iter print_endline (header :: lines)
-
-let console_list _copts x =
- let _, s = find_by_name x in
- Printf.fprintf stderr "json=[%s]\n%!" (Jsonrpc.to_string (rpc_of Vm.state s)) ;
- let line protocol port = Printf.sprintf "%-10s %-6s" protocol port in
- let header = line "protocol" "port" in
- let lines =
- List.map
- (fun c ->
- let protocol =
- match c.Vm.protocol with Vm.Rfb -> "RFB" | Vm.Vt100 -> "VT100"
- in
- line protocol (string_of_int c.Vm.port)
- )
- s.Vm.consoles
- in
- List.iter print_endline (header :: lines)
-
let raw_console_proxy sockaddr =
let long_connection_retry_timeout = 5. in
let with_raw_mode f =
@@ -1346,49 +1179,6 @@ let create copts x console () =
let create copts console x = diagnose_error (create copts console x)
-let pci_add x idx bdf =
- let vm, _ = find_by_name x in
- let open Pci in
- let domain, bus, dev, fn =
- Scanf.sscanf bdf "%04x:%02x:%02x.%1x" (fun a b c d -> (a, b, c, d))
- in
- let address = {domain; bus; dev; fn} in
- let id =
- Client.PCI.add dbg
- {
- id= (vm.Vm.id, idx)
- ; position= int_of_string idx
- ; address
- ; msitranslate= None
- ; power_mgmt= None
- }
- in
- Printf.printf "%s.%s\n" (fst id) (snd id)
-
-let pci_remove x idx =
- let vm, _ = find_by_name x in
- Client.PCI.remove dbg (vm.Vm.id, idx)
-
-let pci_list x =
- let vm, _ = find_by_name x in
- let pcis = Client.PCI.list dbg vm.Vm.id in
- let line id bdf = Printf.sprintf "%-10s %-3s %-12s" id bdf in
- let header = line "id" "pos" "bdf" in
- let lines =
- List.map
- (fun (pci, _state) ->
- let open Pci in
- let id = snd pci.id in
- let bdf =
- Printf.sprintf "%04x:%02x:%02x.%01x" pci.address.domain
- pci.address.bus pci.address.dev pci.address.fn
- in
- line id (string_of_int pci.position) bdf
- )
- pcis
- in
- List.iter print_endline (header :: lines)
-
let find_vbd id =
let vbd_id : Vbd.id =
match Re.Str.bounded_split_delim (Re.Str.regexp "[.]") id 2 with
@@ -1454,8 +1244,6 @@ let rec events_watch from =
let events _copts = events_watch None
-let set_worker_pool_size size = Client.HOST.set_worker_pool_size dbg size
-
let print_date float =
let time = Unix.gmtime float in
Printf.sprintf "%04d%02d%02dT%02d:%02d:%02dZ" (time.Unix.tm_year + 1900)
@@ -1484,88 +1272,3 @@ let task_cancel _ = function
`Error (true, "Please supply a task id")
| Some id ->
Client.TASK.cancel dbg id ; `Ok ()
-
-let debug_shutdown () = Client.DEBUG.shutdown dbg ()
-
-let verbose_task t =
- let string_of_state = function
- | Task.Completed t ->
- Printf.sprintf "%.2f" t.Task.duration
- | Task.Failed x ->
- Printf.sprintf "Error: %s" (x |> Jsonrpc.to_string)
- | Task.Pending _ ->
- Printf.sprintf "Error: still pending"
- in
- let rows =
- List.map
- (fun (name, state) -> [name; string_of_state state])
- t.Task.subtasks
- in
- let rows = rows @ List.map (fun (k, v) -> [k; v]) t.Task.debug_info in
- Table.print rows ;
- Printf.printf "\n" ;
- Printf.printf "Overall: %s\n" (string_of_state t.Task.state)
-
-let old_main () =
- let args = Sys.argv |> Array.to_list |> List.tl in
- let verbose = List.mem "-v" args in
- let args = List.filter (fun x -> x <> "-v") args in
- (* Extract any -path X argument *)
- let extract args key =
- let result = ref None in
- let args =
- List.fold_left
- (fun (acc, foundit) x ->
- if foundit then (
- result := Some x ;
- (acc, false)
- ) else if x = key then
- (acc, true)
- else
- (x :: acc, false)
- )
- ([], false) args
- |> fst
- |> List.rev
- in
- (!result, args)
- in
- let path, args = extract args "-path" in
- ( match path with
- | Some path ->
- Xenops_interface.set_sockets_dir path
- | None ->
- ()
- ) ;
- let task = success_task (if verbose then verbose_task else ignore_task) in
- match args with
- | ["help"] | [] ->
- usage () ; exit 0
- | ["migrate"; id; url] ->
- migrate ~id ~url ~compress:"false" ~verify_dest:"false" |> task
- | ["migrate"; id; url; compress] ->
- migrate ~id ~url ~compress ~verify_dest:"false" |> task
- | ["migrate"; id; url; compress; verify_dest] ->
- migrate ~id ~url ~compress ~verify_dest |> task
- | ["vbd-list"; id] ->
- vbd_list id
- | ["pci-add"; id; idx; bdf] ->
- pci_add id idx bdf
- | ["pci-remove"; id; idx] ->
- pci_remove id idx
- | ["pci-list"; id] ->
- pci_list id
- | ["cd-insert"; id; disk] ->
- cd_insert id disk |> task
- | ["delay"; id; t] ->
- delay id (float_of_string t)
- | ["events-watch"] ->
- events_watch None
- | ["set-worker-pool-size"; size] ->
- set_worker_pool_size (int_of_string size)
- | ["shutdown"] ->
- debug_shutdown ()
- | cmd :: _ ->
- Printf.fprintf stderr "Unrecognised command: %s\n" cmd ;
- usage () ;
- exit 1
diff --git a/ocaml/xenopsd/cli/xn.mli b/ocaml/xenopsd/cli/xn.mli
new file mode 100644
index 000000000..0acd3551e
--- /dev/null
+++ b/ocaml/xenopsd/cli/xn.mli
@@ -0,0 +1,72 @@
+val add : 'a -> string option -> [> `Error of bool * string | `Ok of unit]
+
+val list : Common.t -> unit
+
+val stat_vm : 'a -> string -> [> `Ok of unit]
+
+val diagnostics : 'a -> [> `Ok of unit]
+
+val remove : 'a -> string option -> [> `Error of bool * string | `Ok of unit]
+
+val export :
+ 'a
+ -> bool
+ -> bool
+ -> string option
+ -> string option
+ -> [> `Error of bool * string | `Ok of unit]
+
+val import :
+ 'a -> bool -> string option -> [> `Error of bool * string | `Ok of unit]
+
+val shutdown :
+ 'a
+ -> float option
+ -> string option
+ -> [> `Error of bool * string | `Ok of unit]
+
+val pause : 'a -> string option -> [> `Error of bool * string | `Ok of unit]
+
+val unpause : 'a -> string option -> [> `Error of bool * string | `Ok of unit]
+
+val reboot :
+ 'a
+ -> float option
+ -> string option
+ -> [> `Error of bool * string | `Ok of unit]
+
+val suspend :
+ 'a
+ -> string option
+ -> string option
+ -> [> `Error of bool * string | `Ok of unit]
+
+val resume :
+ 'a
+ -> string option
+ -> string option
+ -> [> `Error of bool * string | `Ok of unit]
+
+val console_connect :
+ 'a -> string option -> [> `Error of bool * string | `Ok of unit]
+
+val start :
+ 'a
+ -> bool
+ -> bool
+ -> string option
+ -> [> `Error of bool * string | `Ok of unit]
+
+val create :
+ 'a -> string option -> bool -> [> `Error of bool * string | `Ok of unit]
+
+val cd_eject : 'a -> string option -> [> `Error of bool * string | `Ok of unit]
+
+val cd_insert : string -> string -> string
+
+val events : 'a -> 'b
+
+val task_list : 'a -> [> `Ok of unit]
+
+val task_cancel :
+ 'a -> string option -> [> `Error of bool * string | `Ok of unit]
diff --git a/ocaml/xenopsd/lib/xenops_utils.ml b/ocaml/xenopsd/lib/xenops_utils.ml
index 9a6ae66a9..d948f9865 100644
--- a/ocaml/xenopsd/lib/xenops_utils.ml
+++ b/ocaml/xenopsd/lib/xenops_utils.ml
@@ -584,7 +584,7 @@ let _sys_hypervisor_version_major = "/sys/hypervisor/version/major"
let _sys_hypervisor_version_minor = "/sys/hypervisor/version/minor"
type hypervisor =
- | Xen of string * string
+ | Xen of int * int
(* major, minor *)
| Other of string
@@ -601,7 +601,7 @@ let detect_hypervisor () =
let minor =
String.trim (Unixext.string_of_file _sys_hypervisor_version_minor)
in
- Some (Xen (major, minor))
+ Some (Xen (int_of_string major, int_of_string minor))
| x ->
Some (Other x)
else
diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml
index 4de4bbc35..2f60e3b27 100644
--- a/ocaml/xenopsd/xc/xenops_server_xen.ml
+++ b/ocaml/xenopsd/xc/xenops_server_xen.ml
@@ -5147,11 +5147,10 @@ let init () =
look_for_forkexec () ;
let major, minor = look_for_xen () in
look_for_xenctrl () ;
- if
- major < "4" || ((major = "4" && minor < "2") && !Xenopsd.run_hotplug_scripts)
+ if major < 4 || ((major = 4 && minor < 2) && !Xenopsd.run_hotplug_scripts)
then (
error
- "This is xen version %s.%s. On all versions < 4.1 we must use \
+ "This is xen version %d.%d. On all versions < 4.2 we must use \
hotplug/udev scripts"
major minor ;
error
diff --git a/python3/packages/observer.py b/python3/packages/observer.py
index 1eee0f2a7..b257aa9b3 100644
--- a/python3/packages/observer.py
+++ b/python3/packages/observer.py
@@ -71,7 +71,7 @@ def _get_configs_list(config_dir):
def read_config(config_path, header):
"""Read a config file and return a dictionary of key-value pairs."""
- parser = configparser.ConfigParser()
+ parser = configparser.ConfigParser(interpolation=None)
with open(config_path, encoding="utf-8") as config_file:
try:
parser.read_string(f"[{header}]\n{config_file.read()}")
diff --git a/quality-gate.sh b/quality-gate.sh
index 77238f4ab..7222e062c 100755
--- a/quality-gate.sh
+++ b/quality-gate.sh
@@ -3,7 +3,7 @@
set -e
list-hd () {
- N=318
+ N=315
LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc)
if [ "$LIST_HD" -eq "$N" ]; then
echo "OK counted $LIST_HD List.hd usages"
@@ -25,10 +25,10 @@ verify-cert () {
}
mli-files () {
- N=522
+ N=515
# do not count ml files from the tests in ocaml/{tests/perftest/quicktest}
- MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)
- MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)
+ MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)
+ MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)
num_mls_without_mlis=$(comm -23 <(sort <<<"$MLS") <(sort <<<"$MLIS") | wc -l)
if [ "$num_mls_without_mlis" -eq "$N" ]; then
echo "OK counted $num_mls_without_mlis .ml files without an .mli"
diff --git a/scripts/plugins/perfmon b/scripts/plugins/perfmon
index 2186c9389..e3dc24526 100644
--- a/scripts/plugins/perfmon
+++ b/scripts/plugins/perfmon
@@ -14,16 +14,17 @@ def send_perfmon_cmd(cmd):
"Return True for success, or ERROR_%d: <msg> otherwise"
if len(cmd) >= cmdmaxlen:
return "ERROR_0: command too long"
+ cmd_bytes = cmd.encode()
try:
sock = socket.socket(socket.AF_UNIX, socket.SOCK_DGRAM)
- rc = sock.sendto(cmd, cmdsockname)
+ rc = sock.sendto(cmd_bytes, cmdsockname)
except socket.error as e:
err, msg = e.args
return "ERROR_%d: %s" % (err, msg)
except Exception:
return "ERROR_1: unknown error"
- return str(rc == len(cmd))
+ return str(rc == len(cmd_bytes))
def stop(session, args):
diff --git a/scripts/varstored-guard.service b/scripts/varstored-guard.service
index 59e45110f..c9d1b9bd9 100644
--- a/scripts/varstored-guard.service
+++ b/scripts/varstored-guard.service
@@ -2,7 +2,7 @@
Description=Varstored XAPI socket deprivileging daemon
Documentation=man:varstored-guard(1)
After=message-switch.service syslog.target
-Before=xenopsd.service
+Before=xapi-domains.service xenopsd.service
Wants=message-switch.service syslog.target
[Service]
diff --git a/scripts/xe-backup-metadata b/scripts/xe-backup-metadata
index 4aa09b7f7..47b21108b 100755
--- a/scripts/xe-backup-metadata
+++ b/scripts/xe-backup-metadata
@@ -39,6 +39,7 @@ function usage {
echo " -k: Number of older backups to preserve (default: ${history_kept})"
echo " -n: Just try to find a backup VDI and stop the script after that"
echo " -f Force backup even when less than 10% free capacity is left on the backup VDI"
+ echo " -y: Assume non-interactive mode and yes to all questions"
echo " -v: Verbose output"
echo
echo
@@ -48,10 +49,33 @@ function usage {
exit 1
}
+function uuid5 {
+ # could use a modern uuidgen but it's not on XS 8
+ # should work with Python 2 and 3
+ python -c "import uuid; print (uuid.uuid5(uuid.UUID('$1'), '$2'))"
+}
+
+function validate_vdi_uuid {
+ # we check that vdi has the expected UUID which depends on the UUID of
+ # the SR. This is a deterministic hash of the SR UUID and the
+ # namespace UUID $NS. This UUID must match what Xapi's Uuidx module is using.
+ local NS="e93e0639-2bdb-4a59-8b46-352b3f408c19"
+ local sr="$1"
+ local vdi="$2"
+ local uuid
+
+ uuid=$(uuid5 "$NS" "$sr")
+ if [ "$vdi" != "$uuid" ]; then
+ return 1
+ else
+ return 0
+ fi
+}
+
function test_sr {
sr_uuid_found=$(${XE} sr-list uuid="$1" --minimal)
if [ "${sr_uuid_found}" != "$1" ]; then
- echo Invalid SR UUID specified: $1
+ echo "Invalid SR UUID specified: $1"
usage
fi
}
@@ -63,7 +87,8 @@ just_find_vdi=0
fs_uninitialised=0
usage_alert=90
force_backup=0
-while getopts "hvink:u:dcf" opt ; do
+yes=0
+while getopts "yhvink:u:dcf" opt ; do
case $opt in
h) usage ;;
c) create_vdi=1 ; fs_uninitialised=1 ;;
@@ -73,6 +98,7 @@ while getopts "hvink:u:dcf" opt ; do
d) leave_mounted=1 ;;
n) just_find_vdi=1 ;;
v) debug="" ;;
+ y) yes=1 ;;
f) force_backup=1 ;;
*) echo "Invalid option"; usage ;;
esac
@@ -89,32 +115,32 @@ fi
# determine if the SR UUID is vaid
if [ -z "${sr_uuid}" ]; then
# use the default-SR from the pool
- sr_uuid=$(${XE} pool-param-get uuid=${pool_uuid} param-name=default-SR)
+ sr_uuid=$(${XE} pool-param-get uuid="${pool_uuid}" param-name=default-SR)
fi
test_sr "${sr_uuid}"
-sr_name=$(${XE} sr-param-get uuid=${sr_uuid} param-name=name-label)
+sr_name=$(${XE} sr-param-get uuid="${sr_uuid}" param-name=name-label)
# see if a backup VDI already exists on the selected SR
-vdi_uuid=$(${XE} vdi-list other-config:ctxs-pool-backup=true sr-uuid=${sr_uuid} params=uuid --minimal)
+vdi_uuid=$(${XE} vdi-list other-config:ctxs-pool-backup=true sr-uuid="${sr_uuid}" params=uuid --minimal)
mnt=
function cleanup {
trap "" TERM INT
cd /
if [ ! -z "${mnt}" ]; then
- umount ${mnt} >/dev/null 2>&1
- rmdir ${mnt}
+ umount "${mnt}" >/dev/null 2>&1
+ rmdir "${mnt}"
fi
if [ ! -z "${vbd_uuid}" ]; then
${debug} echo -n "Unplugging VBD: "
- ${XE} vbd-unplug uuid=${vbd_uuid} timeout=20
+ ${XE} vbd-unplug uuid="${vbd_uuid}" timeout=20
# poll for the device to go away if we know its name
if [ "${device}" != "" ]; then
device_gone=0
for ((i=0; i<10; i++)); do
${debug} echo -n "."
- if [ ! -b ${device} ]; then
+ if [ ! -b "${device}" ]; then
${debug} echo " done"
device_gone=1
break
@@ -123,22 +149,35 @@ function cleanup {
done
if [ ${device_gone} -eq 0 ]; then
${debug} echo " failed"
- echo Please destroy VBD ${vbd_uuid} manually.
+ echo "Please destroy VBD ${vbd_uuid} manually."
else
- ${XE} vbd-destroy uuid=${vbd_uuid}
+ ${XE} vbd-destroy uuid="${vbd_uuid}"
fi
fi
fi
if [ ${fs_uninitialised} -eq 1 -a -n "${vdi_uuid}" ] ; then
- ${XE} vdi-destroy uuid=${vdi_uuid}
+ ${XE} vdi-destroy uuid="${vdi_uuid}"
fi
}
-echo Using SR: ${sr_name}
+# if we can't validate the UUID of the VDI, prompt the user
+if [ -n "${vdi_uuid}" ]; then
+ if ! validate_vdi_uuid "${sr_uuid}" "${vdi_uuid}" && [ "$yes" -eq 0 ]; then
+ echo "Backup VDI $vdi_uuid was most likley create by an earlier"
+ echo "version of this code. Make sure this is a VDI that you"
+ echo "created as we can't validate it without mounting it."
+ read -p "Continue? [Y/N]" -n 1 -r; echo
+ if [[ ! $REPLY =~ ^[Yy]$ ]]; then exit 1; fi
+ fi
+fi
+
+echo "Using SR: ${sr_name}"
if [ -z "${vdi_uuid}" ]; then
if [ "${create_vdi}" -gt 0 ]; then
echo -n "Creating new backup VDI: "
- vdi_uuid=$(${XE} vdi-create virtual-size=500MiB sr-uuid=${sr_uuid} type=user name-label="Pool Metadata Backup")
+ label="Pool Metadata Backup"
+ # the label must match what xapi_vdi.ml is using for backup VDIs
+ vdi_uuid=$(${XE} vdi-create virtual-size=500MiB sr-uuid="${sr_uuid}" type=user name-label="${label}")
init_fs=1
if [ $? -ne 0 ]; then
echo failed
@@ -148,8 +187,8 @@ if [ -z "${vdi_uuid}" ]; then
echo "Backup VDI not found, aborting. You can initialise one using the '-c' flag."
exit 3
fi
- echo ${vdi_uuid}
- ${XE} vdi-param-set uuid=${vdi_uuid} other-config:ctxs-pool-backup=true
+ echo "${vdi_uuid}"
+ ${XE} vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true
else
${debug} echo "Using existing backup VDI: ${vdi_uuid}"
fs_uninitialised=0
@@ -160,110 +199,110 @@ if [ ${just_find_vdi} -gt 0 ]; then
fi
${debug} echo -n "Creating VBD: "
-vbd_uuid=$(${XE} vbd-create vm-uuid=${CONTROL_DOMAIN_UUID} vdi-uuid=${vdi_uuid} device=autodetect)
-${debug} echo ${vbd_uuid}
+vbd_uuid=$(${XE} vbd-create vm-uuid="${CONTROL_DOMAIN_UUID}" vdi-uuid="${vdi_uuid}" device=autodetect)
+${debug} echo "${vbd_uuid}"
if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then
- echo error creating VBD
+ echo "error creating VBD"
cleanup
exit 1
fi
${debug} echo -n "Plugging VBD: "
-${XE} vbd-plug uuid=${vbd_uuid}
-device=/dev/$(${XE} vbd-param-get uuid=${vbd_uuid} param-name=device)
+${XE} vbd-plug uuid="${vbd_uuid}"
+device=/dev/$(${XE} vbd-param-get uuid="${vbd_uuid}" param-name=device)
-if [ ! -b ${device} ]; then
- ${debug} echo ${device}: not a block special
+if [ ! -b "${device}" ]; then
+ ${debug} echo "${device}: not a block special"
cleanup
exit 1
fi
-${debug} echo ${device}
+${debug} echo "${device}"
-if [ $init_fs -eq 1 ]; then
+if [ "$init_fs" -eq 1 ]; then
${debug} echo -n "Creating filesystem: "
- mkfs.ext3 -j -F ${device} > /dev/null 2>&1
+ mkfs.ext3 -j -F "${device}" > /dev/null 2>&1
${debug} echo "done"
fs_uninitialised=0
fi
${debug} echo -n "Mounting filesystem: "
-mnt=/var/run/pool-backup-${vdi_uuid}
-mkdir -p ${mnt}
+mnt="/var/run/pool-backup-${vdi_uuid}"
+mkdir -p "${mnt}"
-/sbin/fsck -a ${device} >/dev/null 2>&1
+/sbin/fsck -a "${device}" >/dev/null 2>&1
if [ $? -ne 0 ]; then
${debug} fsck failed. Please correct manually
cleanup
exit 1
fi
-mount ${device} ${mnt} > /dev/null 2>&1
+mount "${device}" "${mnt}" > /dev/null 2>&1
if [ $? -ne 0 ]; then
${debug} echo failed
cleanup
exit 1
fi
-${debug} echo ${mnt}
+${debug} echo "${mnt}"
if [ ${leave_mounted} -eq 0 ]; then
- lrconf=${mnt}/conf/${vdi_uuid}
- if [ ! -f ${lrconf} ]; then
+ lrconf="${mnt}/conf/${vdi_uuid}"
+ if [ ! -f "${lrconf}" ]; then
${debug} echo -n "Initialising rotation: "
- mkdir -p ${mnt}/conf/
- echo "${mnt}/${pool_uuid}.db {" >> ${lrconf}
- echo " rotate ${history_kept}" >> ${lrconf}
- echo " missingok" >> ${lrconf}
- echo "}" >> ${lrconf}
- echo done
- echo ${metadata_version} >> ${mnt}/.ctxs-metadata-backup
+ mkdir -p "${mnt}/conf/"
+ echo "${mnt}/${pool_uuid}.db {" >> "${lrconf}"
+ echo " rotate ${history_kept}" >> "${lrconf}"
+ echo " missingok" >> "${lrconf}"
+ echo "}" >> "${lrconf}"
+ echo "done"
+ echo "${metadata_version}" >> "${mnt}/.ctxs-metadata-backup"
fi
# check the usage of the backup VDI
- usage=`cd ${mnt} && df . | sed -n "2p" | awk '{ print $5 }' | tr -d '%'`
+ usage=`cd "${mnt}" && df . | sed -n "2p" | awk '{ print $5 }' | tr -d '%'`
echo "Checking backup VDI space usage: $usage%"
- if [ $usage -gt $usage_alert ] && [ ${force_backup} -eq 0 ]; then
- echo "Running out of space, you can use "-d" option to attach VDI and free more space, exit now."
+ if [ "$usage" -gt "$usage_alert" ] && [ "${force_backup}" -eq 0 ]; then
+ echo "Running out of space, you can use '-d' option to attach VDI and free more space, exit now."
cleanup
exit 1
fi
# invoke logrotate to rotate over old pool db backups
echo -n "Rotating old backups: "
- logrotate -f ${lrconf}
- num_found=$(find ${mnt} -name \*.db\.* | wc -l)
- echo found ${num_found}
+ logrotate -f "${lrconf}"
+ num_found=$(find "${mnt}" -name '*.db.*' | wc -l)
+ echo "found ${num_found}"
# perform the pool database dump
echo -n "Backing up pool database: "
- ${XE} pool-dump-database file-name=${mnt}/${pool_uuid}.db
+ ${XE} pool-dump-database file-name="${mnt}/${pool_uuid}.db"
echo done
# backup the VM metadata for each VM in the pool into a dated directory
datetime=$(date +%F-%H-%M-%S)
- metadir=${mnt}/metadata/${datetime}
- mkdir -p ${metadir}
+ metadir="${mnt}/metadata/${datetime}"
+ mkdir -p "${metadir}"
echo -n "Cleaning old VM metadata: "
IFS=" "
- todelete=$(cd ${mnt}/metadata && ls -1 |sort -n | head -n -${history_kept} | xargs echo)
+ todelete=$(cd "${mnt}/metadata" && ls -1 |sort -n | head -n -${history_kept} | xargs echo)
for dir in ${todelete}; do
- rm -rf ${mnt}/metadata/${dir}
+ rm -rf "${mnt}/metadata/${dir}"
done
echo done
IFS=","
echo -n "Backing up SR metadata: "
- mkdir -p ${metadir}
- "@LIBEXECDIR@/backup-sr-metadata.py" -f ${metadir}/SRMETA.xml
+ mkdir -p "${metadir}"
+ "@LIBEXECDIR@/backup-sr-metadata.py" -f "${metadir}/SRMETA.xml"
echo "done"
echo -n "Backing up VM metadata: "
${debug} echo ""
- mkdir -p ${metadir}/all
+ mkdir -p "${metadir}/all"
for vmuuid in $(${XE} vm-list params=uuid is-control-domain=false --minimal); do
${debug} echo -n .
- ${XE} vm-export --metadata uuid=${vmuuid} filename=${metadir}/all/${vmuuid}.vmmeta >/dev/null 2>&1
+ ${XE} vm-export --metadata uuid="${vmuuid}" filename="${metadir}/all/${vmuuid}.vmmeta" >/dev/null 2>&1
done
echo "done"
echo -n "Backing up Template metadata: "
@@ -271,13 +310,13 @@ if [ ${leave_mounted} -eq 0 ]; then
template_uuids=$("@LIBEXECDIR@/print-custom-templates")
if [ $? -eq 0 ]; then
for tmpl_uuid in ${template_uuids}; do
- ${XE} template-export --metadata template-uuid=${tmpl_uuid} filename=${metadir}/all/${tmpl_uuid}.vmmeta >/dev/null 2>&1
+ ${XE} template-export --metadata template-uuid="${tmpl_uuid}" filename="${metadir}/all/${tmpl_uuid}.vmmeta" >/dev/null 2>&1
done
fi
echo "done"
- "@LIBEXECDIR@/link-vms-by-sr.py" -d ${metadir}
+ "@LIBEXECDIR@/link-vms-by-sr.py" -d "${metadir}"
else
- cd ${mnt}
+ cd "${mnt}"
env PS1="Mounted backup VDI on: ${mnt}\nPress ^D to exit shell and safely detach it.\n\n[\u@\h \W]\$ " bash
fi
diff --git a/scripts/xe-restore-metadata b/scripts/xe-restore-metadata
index 81beb51b7..093cd7721 100755
--- a/scripts/xe-restore-metadata
+++ b/scripts/xe-restore-metadata
@@ -47,11 +47,18 @@ function usage {
function test_sr {
sr_uuid_found=$(${XE} sr-list uuid="$1" --minimal)
if [ "${sr_uuid_found}" != "$1" ]; then
- echo Invalid SR UUID specified: $1
+ echo "Invalid SR UUID specified: $1"
usage
fi
}
+# name space to hash SRs for a deterministic VDI UUID
+NS="e93e0639-2bdb-4a59-8b46-352b3f408c19"
+function uuid5 {
+ # could use a modern uuidgen but it's not on XS 8
+ python -c "import uuid; print (uuid.uuid5(uuid.UUID('$1'), '$2'))"
+}
+
dry_run=0
sr_uuid=
yes=0
@@ -94,35 +101,42 @@ fi
# determine if the SR UUID is vaid
if [ -z "${sr_uuid}" ]; then
# use the default-SR from the pool
- sr_uuid=$(${XE} pool-param-get uuid=${pool_uuid} param-name=default-SR)
+ sr_uuid=$(${XE} pool-param-get uuid="${pool_uuid}" param-name=default-SR)
fi
test_sr "${sr_uuid}"
-sr_name=$(${XE} sr-param-get uuid=${sr_uuid} param-name=name-label)
+sr_name=$(${XE} sr-param-get uuid="${sr_uuid}" param-name=name-label)
+
+# probe first for a VDI with known UUID derived from the SR to avoid
+# scanning for a VDI
+backup_vdi=$(uuid5 "${NS}" "${sr_uuid}")
+if [ -z "${vdis}" ]; then
+ vdis=$(${XE} vdi-list uuid="${backup_vdi}" sr-uuid="${sr_uuid}" read-only=false --minimal)
+fi
# get a list of all VDIs if an override has not been provided on the cmd line
if [ -z "${vdis}" ]; then
- vdis=$(${XE} vdi-list params=uuid sr-uuid=${sr_uuid} read-only=false --minimal)
+ vdis=$(${XE} vdi-list params=uuid sr-uuid="${sr_uuid}" read-only=false --minimal)
fi
mnt=
function cleanup {
cd /
if [ ! -z "${mnt}" ]; then
- umount ${mnt} >/dev/null 2>&1
- rmdir ${mnt}
+ umount "${mnt}" >/dev/null 2>&1
+ rmdir "${mnt}"
mnt=""
fi
if [ ! -z "${vbd_uuid}" ]; then
${debug} echo -n "Unplugging VBD: " >&2
- ${XE} vbd-unplug uuid=${vbd_uuid} timeout=20
+ ${XE} vbd-unplug uuid="${vbd_uuid}" timeout=20
# poll for the device to go away if we know its name
if [ "${device}" != "" ]; then
device_gone=0
for ((i=0; i<10; i++)); do
${debug} echo -n "." >&2
- if [ ! -b ${device} ]; then
+ if [ ! -b "${device}" ]; then
${debug} echo " done" >&2
device_gone=1
break
@@ -131,9 +145,9 @@ function cleanup {
done
if [ ${device_gone} -eq 0 ]; then
${debug} echo " failed" >&2
- ${debug} echo Please destroy VBD ${vbd_uuid} manually. >&2
+ ${debug} echo "Please destroy VBD ${vbd_uuid} manually." >&2
else
- ${XE} vbd-destroy uuid=${vbd_uuid}
+ ${XE} vbd-destroy uuid="${vbd_uuid}"
vbd_uuid=""
fi
fi
@@ -142,88 +156,96 @@ function cleanup {
}
if [ -z "${vdis}" ]; then
- echo No VDIs found on SR. >&2
+ echo "No VDIs found on SR." >&2
exit 0
fi
trap cleanup SIGINT ERR
for vdi_uuid in ${vdis}; do
+ if [ "${vdi_uuid}" != "${backup_vdi}" ] && [ "$yes" -eq 0 ]; then
+ echo "Probing VDI ${vdi_uuid}."
+ echo "This VDI was created with a prior version of this code."
+ echo "Its validity can't be checked without mounting it first."
+ read -p "Continue? [Y/N]" -n 1 -r; echo
+ if [[ ! $REPLY =~ ^[Yy]$ ]]; then exit 1; fi
+ fi
+
${debug} echo -n "Creating VBD: " >&2
- vbd_uuid=$(${XE} vbd-create vm-uuid=${CONTROL_DOMAIN_UUID} vdi-uuid=${vdi_uuid} device=autodetect 2>/dev/null)
+ vbd_uuid=$(${XE} vbd-create vm-uuid="${CONTROL_DOMAIN_UUID}" vdi-uuid="${vdi_uuid}" device=autodetect 2>/dev/null)
if [ $? -ne 0 -o -z "${vbd_uuid}" ]; then
- ${debug} echo error creating VBD for VDI ${vdi_uuid} >&2
+ ${debug} echo "error creating VBD for VDI ${vdi_uuid}" >&2
cleanup
continue
fi
- ${debug} echo ${vbd_uuid} >&2
+ ${debug} echo "${vbd_uuid}" >&2
${debug} echo -n "Plugging VBD: " >&2
- ${XE} vbd-plug uuid=${vbd_uuid}
- device=/dev/$(${XE} vbd-param-get uuid=${vbd_uuid} param-name=device)
+ ${XE} vbd-plug uuid="${vbd_uuid}"
+ device=/dev/$(${XE} vbd-param-get uuid="${vbd_uuid}" param-name=device)
- if [ ! -b ${device} ]; then
- ${debug} echo ${device}: not a block special >&2
+ if [ ! -b "${device}" ]; then
+ ${debug} echo "${device}: not a block special" >&2
cleanup
continue
fi
- ${debug} echo ${device} >&2
+ ${debug} echo "${device}" >&2
${debug} echo -n "Probing device: " >&2
probecmd="@LIBEXECDIR@/probe-device-for-file"
metadata_stamp="/.ctxs-metadata-backup"
mnt=
- ${probecmd} ${device} ${metadata_stamp}
+ ${probecmd} "${device}" "${metadata_stamp}"
if [ $? -eq 0 ]; then
- ${debug} echo found metadata backup >&2
+ ${debug} echo "found metadata backup" >&2
${debug} echo -n "Mounting filesystem: " >&2
- mnt=/var/run/pool-backup-${vdi_uuid}
- mkdir -p ${mnt}
- /sbin/fsck -a ${device} >/dev/null 2>&1
+ mnt="/var/run/pool-backup-${vdi_uuid}"
+ mkdir -p "${mnt}"
+ /sbin/fsck -a "${device}" >/dev/null 2>&1
if [ $? -ne 0 ]; then
- echo File system integrity error. Please correct manually. >&2
+ echo "File system integrity error. Please correct manually." >&2
cleanup
continue
fi
- mount ${device} ${mnt} >/dev/null 2>&1
+ mount "${device}" "${mnt}" >/dev/null 2>&1
if [ $? -ne 0 ]; then
${debug} echo failed >&2
cleanup
else
if [ -e "${mnt}/.ctxs-metadata-backup" ]; then
- ${debug} echo Found backup metadata on VDI: ${vdi_uuid} >&2
- xe vdi-param-set uuid=${vdi_uuid} other-config:ctxs-pool-backup=true
+ ${debug} echo "Found backup metadata on VDI: ${vdi_uuid}" >&2
+ xe vdi-param-set uuid="${vdi_uuid}" other-config:ctxs-pool-backup=true
break
fi
fi
else
- ${debug} echo backup metadata not found >&2
+ ${debug} echo "backup metadata not found" >&2
fi
cleanup
done
if [ $just_probe -gt 0 ]; then
- echo ${vdi_uuid}
+ echo "${vdi_uuid}"
cleanup
exit 0
fi
-cd ${mnt}
+cd "${mnt}"
${debug} echo "" >&2
-if [ ! -d ${mnt}/metadata ]; then
- echo Metadata backups not found. >&2
+if [ ! -d "${mnt}/metadata" ]; then
+ echo "Metadata backups not found." >&2
cleanup
exit 1
fi
-cd ${mnt}/metadata
+cd "${mnt}/metadata"
-if [ $just_list_dates -gt 0 ]; then
- ls -1r ${mnt}/metadata
+if [ "$just_list_dates" -gt 0 ]; then
+ ls -1r "${mnt}/metadata"
cleanup
exit 0
fi
@@ -231,54 +253,54 @@ fi
if [ -z "${chosen_date}" ]; then
chosen_metadata_dir=$(ls | sort -n | tail -1)
if [ -z "${chosen_metadata_dir}" ]; then
- echo No VM metadata backups found in ${mnt}/metadata >&2
+ echo "No VM metadata backups found in ${mnt}/metadata" >&2
cleanup
exit 1
fi
else
- if [ ! -d ${mnt}/metadata/${chosen_date} ]; then
- echo Date directory "${chosen_date}" not found >&2
+ if [ ! -d "${mnt}/metadata/${chosen_date}" ]; then
+ echo "Date directory ${chosen_date} not found" >&2
cleanup
exit 1
fi
- chosen_metadata_dir=${chosen_date}
+ chosen_metadata_dir="${chosen_date}"
fi
case ${restore_mode} in
sr)
- full_dir=${mnt}/metadata/${chosen_metadata_dir}/by-sr/${sr_uuid}
+ full_dir="${mnt}/metadata/${chosen_metadata_dir}/by-sr/${sr_uuid}"
;;
all)
- full_dir=${mnt}/metadata/${chosen_metadata_dir}/all
+ full_dir="${mnt}/metadata/${chosen_metadata_dir}/all"
;;
esac
-if [ ! -d ${full_dir} ]; then
- echo No VM metadata exports were found for the selected SR >&2
+if [ ! -d "${full_dir}" ]; then
+ echo "No VM metadata exports were found for the selected SR" >&2
cleanup
exit 1
fi
-${debug} echo Selected: ${full_dir}
+${debug} echo "Selected: ${full_dir}"
-cd ${full_dir}
+cd "${full_dir}"
${debug} echo "" >&2
-${debug} echo Latest VM metadata found is: >&2
+${debug} echo "Latest VM metadata found is": >&2
${debug} ls >&2
-if [ $yes -eq 0 ]; then
+if [ "$yes" -eq 0 ]; then
echo "Do you wish to reimport all VM metadata?"
- echo "Please type in "yes" and <enter> to continue."
+ echo "Please type in 'yes' and <enter> to continue."
read response
if [ "$response" != "yes" ]; then
- echo Aborting metadata restore.
+ echo "Aborting metadata restore."
cleanup
exit 1
fi
fi
${debug} echo "" >&2
-${debug} echo Restoring VM metadata: >&2
+${debug} echo "Restoring VM metadata:" >&2
trap - ERR
@@ -297,8 +319,8 @@ else
fi
shopt -s nullglob
for meta in *.vmmeta; do
- echo xe vm-import filename=${meta} sr-uuid=${sr_uuid} --metadata --preserve${force_flag}${dry_run_flag}
- "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid=${sr_uuid} --metadata --preserve${force_flag}${dry_run_flag}
+ echo xe vm-import filename="${meta}" sr-uuid="${sr_uuid}" --metadata --preserve"${force_flag}""${dry_run_flag}"
+ "@OPTDIR@/bin/xe" vm-import filename="${full_dir}/${meta}" sr-uuid="${sr_uuid}" --metadata --preserve"${force_flag}""${dry_run_flag}"
if [ $? -gt 0 ]; then
error_count=$(( $error_count + 1 ))
else
@@ -306,16 +328,16 @@ for meta in *.vmmeta; do
fi
done
-smmeta_file=${mnt}/metadata/${chosen_metadata_dir}/SRMETA.xml
+smmeta_file="${mnt}/metadata/${chosen_metadata_dir}/SRMETA.xml"
if [ "$restore_mode" == "all" ]; then
cmd="@LIBEXECDIR@/restore-sr-metadata.py -f ${smmeta_file}"
else
cmd="@LIBEXECDIR@/restore-sr-metadata.py -u ${sr_uuid} -f ${smmeta_file}"
fi
-if [ -e ${smmeta_file} ]; then
- if [ ${dry_run} -gt 0 ]; then
- echo ${cmd}
+if [ -e "${smmeta_file}" ]; then
+ if [ "${dry_run}" -gt 0 ]; then
+ echo "${cmd}"
else
${cmd}
fi
@@ -323,4 +345,4 @@ fi
echo "Restored ${good_count} VM(s), and ${error_count} error(s)"
cleanup
-exit ${error_count}
+exit "${error_count}"An empty You can check the results of the job here |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
No description provided.