diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs index 4c2762b5222..d8259ca9cd8 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 80b32b5c8d9..db28438062f 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 87d5cc8721f..c4d133d2fa1 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,10 +76,19 @@ 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 - + - name: Zip PowerShell 7.x SDK artifacts for deployment shell: bash run: zip PowerShell-SDK-7.x-prerelease-unsigned.zip ./sdk_powershell_7x -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 45a0b3e6b09..d4a2b01bacf 100644 --- a/Makefile +++ b/Makefile @@ -122,10 +122,10 @@ 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 +.PHONY: sdk-build-c sdk-build-c: sdk - cd _build/install/default/xapi/sdk/c && make -j $(JOBS) + cd _build/install/default/xapi/sdk/c && make clean && make -j $(JOBS) .PHONY: sdk-build-java @@ -207,6 +207,7 @@ install: build doc sdk doc-json install -D -m 755 _build/install/default/bin/xcp-rrdd-iostat $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-iostat install -D -m 755 _build/install/default/bin/xcp-rrdd-squeezed $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-squeezed install -D -m 755 _build/install/default/bin/xcp-rrdd-xenpm $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-xenpm + install -D -m 755 _build/install/default/bin/xcp-rrdd-dcmi $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-dcmi install -D -m 644 ocaml/xcp-rrdd/bugtool-plugin/rrdd-plugins.xml $(DESTDIR)$(ETCXENDIR)/bugtool/xcp-rrdd-plugins.xml install -D -m 644 ocaml/xcp-rrdd/bugtool-plugin/rrdd-plugins/stuff.xml $(DESTDIR)$(ETCXENDIR)/bugtool/xcp-rrdd-plugins/stuff.xml install -D -m 755 ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins $(DESTDIR)/etc/sysconfig/xcp-rrdd-plugins diff --git a/forkexec.opam b/forkexec.opam index c458ac94713..a3296ea9771 100644 --- a/forkexec.opam +++ b/forkexec.opam @@ -21,6 +21,7 @@ depends: [ "xapi-log" "xapi-stdext-pervasives" "xapi-stdext-unix" + "xapi-tracing" ] synopsis: "Sub-process control service for xapi" description: diff --git a/forkexec.opam.template b/forkexec.opam.template index 6e9cd4df453..cf537533421 100644 --- a/forkexec.opam.template +++ b/forkexec.opam.template @@ -19,6 +19,7 @@ depends: [ "xapi-log" "xapi-stdext-pervasives" "xapi-stdext-unix" + "xapi-tracing" ] synopsis: "Sub-process control service for xapi" description: diff --git a/message-switch-core.opam b/message-switch-core.opam index 960934bea54..44e2983cc5b 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 7ec11e91dc3..7f65fa07598 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/dune b/ocaml/forkexecd/lib/dune index 2830cd13937..160f444dd34 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -7,12 +7,13 @@ fd-send-recv rpclib.core rpclib.json + rpclib.xml uuid xapi-backtrace xapi-log xapi-stdext-pervasives xapi-stdext-unix - rpclib.xml + xapi-tracing ) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/forkexecd/lib/fe.ml b/ocaml/forkexecd/lib/fe.ml index 1a176a62baa..c928cd3fc10 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 d55901c3c68..2c8041b9535 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|] @@ -34,6 +36,10 @@ let test_path = let runtime_path = Option.value ~default:"/var" test_path +let _with_tracing ?tracing ~name f = + let name = Printf.sprintf "forkhelpers.%s" name in + Tracing.with_tracing ?parent:tracing ~name f + let finally = Xapi_stdext_pervasives.Pervasiveext.finally type pidty = Unix.file_descr * int @@ -72,14 +78,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 +175,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 6252f0e75ca..186cbe51872 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 197f3b91f65..0bdb5fc1dc1 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 bb740d94df8..42991d5f16b 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 fa5ffc514cd..aa0b9899ee7 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 c8fa2614150..4d4edd972ac 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] @@ -6520,14 +6520,55 @@ module Network_sriov = struct end (** PCI devices *) +let pci_dom0_access = + Enum + ( "pci_dom0_access" + , [ + ("enabled", "dom0 can access this device as normal") + ; ( "disable_on_reboot" + , "On host reboot dom0 will be blocked from accessing this device" + ) + ; ("disabled", "dom0 cannot access this device") + ; ( "enable_on_reboot" + , "On host reboot dom0 will be allowed to access this device" + ) + ] + ) module PCI = struct + let disable_dom0_access = + call ~name:"disable_dom0_access" ~lifecycle:[] + ~doc: + "Hide a PCI device from the dom0 kernel. (Takes affect after next \ + boot.)" + ~params:[(Ref _pci, "self", "The PCI to hide")] + ~result:(pci_dom0_access, "The accessibility of this PCI from dom0") + ~allowed_roles:_R_POOL_OP () + + let enable_dom0_access = + call ~name:"enable_dom0_access" ~lifecycle:[] + ~doc: + "Unhide a PCI device from the dom0 kernel. (Takes affect after next \ + boot.)" + ~params:[(Ref _pci, "self", "The PCI to unhide")] + ~result:(pci_dom0_access, "The accessibility of this PCI from dom0") + ~allowed_roles:_R_POOL_OP () + + let get_dom0_access_status = + call ~name:"get_dom0_access_status" ~lifecycle:[] + ~doc:"Return a PCI device dom0 access status." + ~params:[(Ref _pci, "self", "The PCI")] + ~result:(pci_dom0_access, "The accessibility of this PCI from dom0") + ~allowed_roles:_R_POOL_OP () + let t = create_obj ~name:_pci ~descr:"A PCI device" ~doccomments:[] ~gen_constructor_destructor:false ~gen_events:true ~in_db:true ~lifecycle:[(Published, rel_boston, "")] - ~messages:[] ~messages_default_allowed_roles:_R_POOL_OP - ~persist:PersistEverything ~in_oss_since:None ~db_logging:Log_destroy + ~messages: + [disable_dom0_access; enable_dom0_access; get_dom0_access_status] + ~messages_default_allowed_roles:_R_POOL_OP ~persist:PersistEverything + ~in_oss_since:None ~db_logging:Log_destroy ~contents: [ uid _pci ~lifecycle:[(Published, rel_boston, "")] @@ -6621,21 +6662,6 @@ end (** Physical GPUs (pGPU) *) module PGPU = struct - let dom0_access = - Enum - ( "pgpu_dom0_access" - , [ - ("enabled", "dom0 can access this device as normal") - ; ( "disable_on_reboot" - , "On host reboot dom0 will be blocked from accessing this device" - ) - ; ("disabled", "dom0 cannot access this device") - ; ( "enable_on_reboot" - , "On host reboot dom0 will be allowed to access this device" - ) - ] - ) - let add_enabled_VGPU_types = call ~name:"add_enabled_VGPU_types" ~lifecycle:[(Published, rel_vgpu_tech_preview, "")] @@ -6756,7 +6782,11 @@ module PGPU = struct let enable_dom0_access = call ~name:"enable_dom0_access" - ~lifecycle:[(Published, rel_cream, "")] + ~lifecycle: + [ + (Published, rel_cream, "") + ; (Deprecated, "24.14.0", "Use PCI.enable_dom0_access instead.") + ] ~versioned_params: [ { @@ -6767,12 +6797,16 @@ module PGPU = struct ; param_default= None } ] - ~result:(dom0_access, "The accessibility of this PGPU from dom0") + ~result:(pci_dom0_access, "The accessibility of this PGPU from dom0") ~allowed_roles:_R_POOL_OP () let disable_dom0_access = call ~name:"disable_dom0_access" - ~lifecycle:[(Published, rel_cream, "")] + ~lifecycle: + [ + (Published, rel_cream, "") + ; (Deprecated, "24.14.0", "Use PCI.disable_dom0_access instead.") + ] ~versioned_params: [ { @@ -6783,7 +6817,7 @@ module PGPU = struct ; param_default= None } ] - ~result:(dom0_access, "The accessibility of this PGPU from dom0") + ~result:(pci_dom0_access, "The accessibility of this PGPU from dom0") ~allowed_roles:_R_POOL_OP () let t = @@ -6844,8 +6878,15 @@ module PGPU = struct "A map relating each VGPU type supported on this GPU to the \ maximum number of VGPUs of that type which can run simultaneously \ on this GPU" - ; field ~qualifier:DynamicRO ~ty:dom0_access - ~lifecycle:[(Published, rel_cream, "")] + ; field ~qualifier:DynamicRO ~ty:pci_dom0_access + ~lifecycle: + [ + (Published, rel_cream, "") + ; ( Deprecated + , "24.14.0" + , "Use PCI.get_dom0_access_status instead." + ) + ] ~default_value:(Some (VEnum "enabled")) "dom0_access" "The accessibility of this device from dom0" ; field ~qualifier:DynamicRO ~ty:Bool @@ -8177,6 +8218,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_common.ml b/ocaml/idl/datamodel_common.ml index 709cb5eb059..fc13fb0a7b1 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/ocaml/idl/datamodel_common.ml @@ -10,7 +10,7 @@ open Datamodel_roles to leave a gap for potential hotfixes needing to increment the schema version.*) let schema_major_vsn = 5 -let schema_minor_vsn = 775 +let schema_minor_vsn = 776 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 diff --git a/ocaml/idl/datamodel_observer.ml b/ocaml/idl/datamodel_observer.ml index bbda9021898..1d80d030a62 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 c1a6b9a7d9c..aa45d93de5b 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 0bceed12255..2b63e09b332 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 @@ -395,6 +412,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 e3ab8ac19dd..a01ae955586 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 c8e5972c9a6..d25bb9e4219 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 = "7db36ba4b150b06a5098ff9bed87b191" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/libs/sexpr/sExpr.ml b/ocaml/libs/sexpr/sExpr.ml index 2976f121f68..ec354e373b1 100644 --- a/ocaml/libs/sexpr/sExpr.ml +++ b/ocaml/libs/sexpr/sExpr.ml @@ -27,6 +27,8 @@ let unescape_buf buf s = if Astring.String.fold_left aux false s then Buffer.add_char buf '\\' +let is_escape_char = function '\\' | '"' | '\'' -> true | _ -> false + (* XXX: This escapes "'c'" and "\'c\'" to "\\'c\\'". * They are both unescaped as "'c'". They have been ported * to make sure that this corner case is left unchanged. @@ -36,28 +38,31 @@ let unescape_buf buf s = * that have guaranteed invariants and optimised performances *) let escape s = let open Astring in - let escaped = Buffer.create (String.length s + 10) in - String.iter - (fun c -> - let c' = + if String.exists is_escape_char s then ( + let escaped = Buffer.create (String.length s + 10) in + String.iter + (fun c -> match c with | '\\' -> - "\\\\" + Buffer.add_string escaped "\\\\" | '"' -> - "\\\"" + Buffer.add_string escaped "\\\"" | '\'' -> - "\\\'" + Buffer.add_string escaped "\\\'" | _ -> - Astring.String.of_char c - in - Buffer.add_string escaped c' - ) - s ; - Buffer.contents escaped + Buffer.add_char escaped c + ) + s ; + Buffer.contents escaped + ) else + s let unescape s = - let buf = Buffer.create (String.length s) in - unescape_buf buf s ; Buffer.contents buf + if String.contains s '\\' then ( + let buf = Buffer.create (String.length s) in + unescape_buf buf s ; Buffer.contents buf + ) else + s let mkstring x = String (unescape x) diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index bd2d8fd768b..434239cc24e 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -1,23 +1,29 @@ (library - (name tracing) - (public_name xapi-tracing) - (libraries - cohttp - cohttp-posix - ptime - ptime.clock.os - re - rpclib.core - rpclib.json - result - rresult - uri - threads.posix - xapi-log - xapi-open-uri - xapi-stdext-threads - xapi-stdext-unix - zstd - ) - (preprocess (pps ppx_deriving_rpc)) -) + (name tracing) + (modules tracing) + (libraries re uri xapi-log xapi-stdext-threads threads.posix) + (public_name xapi-tracing)) + +(library + (name tracing_export) + (modules tracing_export) + (public_name xapi-tracing.export) + (libraries + cohttp + cohttp-posix + ptime + ptime.clock.os + rpclib.core + rpclib.json + result + rresult + tracing + threads.posix + uri + xapi-log + xapi-open-uri + xapi-stdext-threads + xapi-stdext-unix + zstd) + (preprocess + (pps ppx_deriving_rpc))) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 87326fb65cf..8327ad3a299 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -88,8 +88,6 @@ let observe = ref true let set_observe mode = observe := mode -let ( let@ ) f x = f x - module SpanKind = struct type t = Server | Consumer | Client | Producer | Internal [@@deriving rpcty] @@ -154,6 +152,8 @@ module SpanContext = struct None let trace_id_of_span_context t = t.trace_id + + let span_id_of_span_context t = t.span_id end module SpanLink = struct @@ -216,6 +216,21 @@ module Span = struct let get_tag t tag = Attributes.find tag t.attributes + let get_name span = span.name + + let get_parent span = span.parent + + let get_span_kind span = span.span_kind + + let get_begin_time span = span.begin_time + + let get_end_time span = span.end_time + + let get_events span = span.events + + let get_attributes span = + Attributes.fold (fun k v tags -> (k, v) :: tags) span.attributes [] + let finish ?(attributes = Attributes.empty) ~span () = let attributes = Attributes.union (fun _k a _b -> Some a) attributes span.attributes @@ -281,6 +296,8 @@ module Spans = struct let spans = Hashtbl.create 100 + let span_count () = Hashtbl.length spans + let max_spans = ref 1000 let set_max_spans x = max_spans := x @@ -617,315 +634,3 @@ let with_tracing ?(attributes = []) ?(parent = None) ~name f = | Error e -> warn "Failed to start tracing: %s" (Printexc.to_string e) ; f None - -module Export = struct - let export_interval = ref 30. - - let set_export_interval t = export_interval := t - - let host_id = ref "localhost" - - let set_host_id id = host_id := id - - let service_name = ref None - - let set_service_name name = service_name := Some name - - let get_service_name () = - match !service_name with - | None -> - warn "service name not yet set!" ; - "unknown" - | Some name -> - name - - module Content = struct - module Json = struct - module Zipkinv2 = struct - module ZipkinSpan = struct - type zipkinEndpoint = {serviceName: string} [@@deriving rpcty] - - type annotation = {timestamp: int; value: string} [@@deriving rpcty] - - type t = { - id: string - ; traceId: string - ; parentId: string option - ; name: string - ; timestamp: int - ; duration: int - ; kind: string option - ; localEndpoint: zipkinEndpoint - ; annotations: annotation list - ; tags: (string * string) list - } - [@@deriving rpcty] - - type t_list = t list [@@deriving rpcty] - - let kind_to_zipkin_kind = function - | SpanKind.Internal -> - None - | k -> - Some k - - let json_of_t_list s = - Rpcmarshal.marshal t_list.Rpc.Types.ty s |> Jsonrpc.to_string - end - - let zipkin_span_of_span (s : Span.t) : ZipkinSpan.t = - let serviceName = get_service_name () in - let annotations = - List.map - (fun event : ZipkinSpan.annotation -> - let timestamp = - int_of_float (event.SpanEvent.time *. 1000000.) - in - let value = event.SpanEvent.name in - {timestamp; value} - ) - s.events - in - { - id= s.context.span_id - ; traceId= s.context.trace_id - ; parentId= Option.map (fun x -> x.Span.context.span_id) s.parent - ; name= s.name - ; timestamp= int_of_float (s.begin_time *. 1000000.) - ; duration= - Option.value s.end_time ~default:(Unix.gettimeofday () *. 1000000.) - -. s.begin_time - |> ( *. ) 1000000. - |> int_of_float - ; kind= - Option.map SpanKind.to_string - (ZipkinSpan.kind_to_zipkin_kind s.span_kind) - ; localEndpoint= {serviceName} - ; annotations - ; tags= - Attributes.fold (fun k v tags -> (k, v) :: tags) s.attributes [] - } - - let content_of (spans : Span.t list) = - List.map zipkin_span_of_span spans |> ZipkinSpan.json_of_t_list - end - end - end - - module Destination = struct - module File = struct - let trace_log_dir = ref "/var/log/dt/zipkinv2/json" - - let max_file_size = ref (1 lsl 20) - - let compress_tracing_files = ref true - - let set_trace_log_dir dir = trace_log_dir := dir - - let get_trace_log_dir () = !trace_log_dir - - let set_max_file_size size = max_file_size := size - - let set_compress_tracing_files enabled = compress_tracing_files := enabled - - let file_name = ref None - - let lock = Mutex.create () - - let new_file_name () = - let date = Ptime_clock.now () |> Ptime.to_rfc3339 ~frac_s:6 in - let ( // ) = Filename.concat in - let name = - !trace_log_dir - // String.concat "-" [get_service_name (); !host_id; date] - ^ ".ndjson" - in - file_name := Some name ; - name - - let with_fd file_name = - Xapi_stdext_unix.Unixext.with_file file_name - [O_WRONLY; O_CREAT; O_APPEND] - 0o700 - - let write fd str = - let content = str ^ "\n" in - ignore @@ Unix.write_substring fd content 0 (String.length content) - - let export json = - try - let file_name = - match !file_name with None -> new_file_name () | Some x -> x - in - Xapi_stdext_unix.Unixext.mkdir_rec (Filename.dirname file_name) 0o700 ; - let@ fd = file_name |> with_fd in - write fd json ; - if (Unix.fstat fd).st_size >= !max_file_size then ( - debug "Tracing: Rotating file %s > %d" file_name !max_file_size ; - if !compress_tracing_files then - Zstd.Fast.compress_file Zstd.Fast.compress ~file_path:file_name - ~file_ext:"zst" ; - ignore @@ new_file_name () - ) ; - Ok () - with e -> Error e - - let with_stream f = - Xapi_stdext_threads.Threadext.Mutex.execute lock (fun () -> f export) - end - - module Http = struct - module Request = Cohttp.Request.Make (Cohttp_posix_io.Buffered_IO) - module Response = Cohttp.Response.Make (Cohttp_posix_io.Buffered_IO) - - let export ~url json = - try - let body = json in - let headers = - Cohttp.Header.of_list - ([ - ("Content-Type", "application/json") - ; ("Content-Length", string_of_int (String.length body)) - ] - @ - match Uri.host url with - | None -> - [] - | Some h -> - let port = - match Uri.port url with - | Some p -> - ":" ^ string_of_int p - | None -> - "" - in - [("Host", h ^ port)] - ) - in - Open_uri.with_open_uri url (fun fd -> - let request = - Cohttp.Request.make ~meth:`POST ~version:`HTTP_1_1 ~headers url - in - let ic = Unix.in_channel_of_descr fd in - let oc = Unix.out_channel_of_descr fd in - Request.write - (fun writer -> Request.write_body writer body) - request oc ; - (* We flush instead of closing the sending stream as nginx responds to a TCP - half-shutdown with a full shutdown of both directions of the HTTP request *) - flush oc ; - match try Response.read ic with _ -> `Eof with - | `Eof -> - Ok () - | `Invalid x -> - Error (Failure ("invalid read: " ^ x)) - | `Ok response - when Cohttp.Code.(response.status |> code_of_status |> is_error) - -> - Error (Failure (Cohttp.Code.string_of_status response.status)) - | `Ok response -> - let body = Buffer.create 128 in - let reader = Response.make_body_reader response ic in - let rec loop () = - match Response.read_body_chunk reader with - | Cohttp.Transfer.Chunk x -> - Buffer.add_string body x ; loop () - | Cohttp.Transfer.Final_chunk x -> - Buffer.add_string body x - | Cohttp.Transfer.Done -> - () - in - loop () ; Ok () - ) - with e -> Error e - end - - let export_to_endpoint parent traces endpoint = - debug "Tracing: About to export" ; - try - File.with_stream (fun file_export -> - let export, name = - match endpoint with - | Url url -> - (Http.export ~url, "Tracing.Http.export") - | Bugtool -> - (file_export, "Tracing.File.export") - in - let all_spans = - Hashtbl.fold (fun _ spans acc -> spans @ acc) traces [] - in - let attributes = - [ - ("export.span.count", List.length all_spans |> string_of_int) - ; ("export.endpoint", endpoint_to_string endpoint) - ; ( "xs.tracing.spans_table.count" - , Hashtbl.length Spans.spans |> string_of_int - ) - ; ( "xs.tracing.finished_spans_table.count" - , Hashtbl.length traces |> string_of_int - ) - ] - in - let@ _ = with_tracing ~parent ~attributes ~name in - Content.Json.Zipkinv2.content_of all_spans - |> export - |> Result.iter_error raise - ) - with exn -> - debug "Tracing: unable to export span : %s" (Printexc.to_string exn) - - let flush_spans () = - let span_list = Spans.since () in - let attributes = - [("export.traces.count", Hashtbl.length span_list |> string_of_int)] - in - let@ parent = - with_tracing ~parent:None ~attributes ~name:"Tracing.flush_spans" - in - get_tracer_providers () - |> List.filter (fun x -> x.TracerProvider.enabled) - |> List.concat_map (fun x -> TracerProvider.get_endpoints x) - |> List.iter (export_to_endpoint parent span_list) - - let delay = Delay.make () - - (* Note this signal will flush the spans and terminate the exporter thread *) - let signal () = Delay.signal delay - - let create_exporter () = - enable_span_garbage_collector () ; - Thread.create - (fun () -> - let signaled = ref false in - while not !signaled do - debug "Tracing: Waiting %d seconds before exporting spans" - (int_of_float !export_interval) ; - if not (Delay.wait delay !export_interval) then ( - debug "Tracing: we are signaled, export spans now and exit" ; - signaled := true - ) ; - flush_spans () - done - ) - () - - let exporter = ref None - - let lock = Mutex.create () - - let main () = - Xapi_stdext_threads.Threadext.Mutex.execute lock (fun () -> - match !exporter with - | None -> - let tid = create_exporter () in - exporter := Some tid ; - tid - | Some tid -> - tid - ) - end -end - -let flush_and_exit = Export.Destination.signal - -let main = Export.Destination.main diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index ee30b29f041..0440339c6b9 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -34,12 +34,24 @@ module SpanKind : sig val to_string : t -> string end +module Attributes : sig + include Map.S with type key := String.t + + val of_list : (string * 'a) list -> 'a t + + val to_assoc_list : 'a t -> (string * 'a) list +end + module Status : sig type status_code type t end +module SpanEvent : sig + type t = {name: string; time: float; attributes: string Attributes.t} +end + module SpanContext : sig type t @@ -48,6 +60,8 @@ module SpanContext : sig val of_traceparent : string -> t option val trace_id_of_span_context : t -> string + + val span_id_of_span_context : t -> string end module Span : sig @@ -61,9 +75,23 @@ module Span : sig val add_event : t -> string -> (string * string) list -> t + val get_events : t -> SpanEvent.t list + val set_span_kind : t -> SpanKind.t -> t + val get_span_kind : t -> SpanKind.t + val get_tag : t -> string -> string + + val get_name : t -> string + + val get_parent : t -> t option + + val get_begin_time : t -> float + + val get_end_time : t -> float option + + val get_attributes : t -> (string * string) list end module Spans : sig @@ -71,6 +99,10 @@ module Spans : sig val set_max_traces : int -> unit + val span_count : unit -> int + + val since : unit -> (string, Span.t list) Hashtbl.t + val dump : unit -> (string, Span.t list) Hashtbl.t * (string, Span.t list) Hashtbl.t end @@ -133,6 +165,8 @@ val get_tracer_providers : unit -> TracerProvider.t list val get_tracer : name:string -> Tracer.t +val enable_span_garbage_collector : ?timeout:float -> unit -> unit + val with_tracing : ?attributes:(string * string) list -> ?parent:Span.t option @@ -140,36 +174,6 @@ val with_tracing : -> (Span.t option -> 'a) -> 'a -module Export : sig - val set_export_interval : float -> unit - - val set_host_id : string -> unit - - val set_service_name : string -> unit - - module Destination : sig - module File : sig - val set_max_file_size : int -> unit - - val set_trace_log_dir : string -> unit - - val get_trace_log_dir : unit -> string - - val set_compress_tracing_files : bool -> unit - end - - val flush_spans : unit -> unit - - module Http : sig - val export : url:Uri.t -> string -> (unit, exn) result - end - end -end - val set_observe : bool -> unit val validate_attribute : string * string -> bool - -val flush_and_exit : unit -> unit - -val main : unit -> Thread.t diff --git a/ocaml/libs/tracing/tracing_export.ml b/ocaml/libs/tracing/tracing_export.ml new file mode 100644 index 00000000000..a769b2403bc --- /dev/null +++ b/ocaml/libs/tracing/tracing_export.ml @@ -0,0 +1,328 @@ +(* + * Copyright (C) 2024 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module D = Debug.Make (struct let name = "tracing_export" end) + +module Delay = Xapi_stdext_threads.Threadext.Delay +open D +open Tracing + +let ( let@ ) f x = f x + +let export_interval = ref 30. + +let set_export_interval t = export_interval := t + +let host_id = ref "localhost" + +let set_host_id id = host_id := id + +let service_name = ref "unknown" + +let set_service_name name = service_name := name + +let get_service_name () = !service_name + +module Content = struct + module Json = struct + module ZipkinV2 = struct + (* Module that helps export spans under Zipkin protocol, version 2. *) + module ZipkinSpan = struct + type zipkinEndpoint = {serviceName: string} [@@deriving rpcty] + + type annotation = {timestamp: int; value: string} [@@deriving rpcty] + + type t = { + id: string + ; traceId: string + ; parentId: string option + ; name: string + ; timestamp: int + ; duration: int + ; kind: string option + ; localEndpoint: zipkinEndpoint + ; annotations: annotation list + ; tags: (string * string) list + } + [@@deriving rpcty] + + type t_list = t list [@@deriving rpcty] + + let kind_to_zipkin_kind = function + | SpanKind.Internal -> + None + | k -> + Some k + + let json_of_t_list s = + Rpcmarshal.marshal t_list.Rpc.Types.ty s |> Jsonrpc.to_string + end + + let zipkin_span_of_span (s : Span.t) : ZipkinSpan.t = + let serviceName = get_service_name () in + let annotations = + s + |> Span.get_events + |> List.map (fun event : ZipkinSpan.annotation -> + let timestamp = + int_of_float (event.SpanEvent.time *. 1000000.) + in + let value = event.SpanEvent.name in + {timestamp; value} + ) + in + { + id= s |> Span.get_context |> SpanContext.span_id_of_span_context + ; traceId= s |> Span.get_context |> SpanContext.trace_id_of_span_context + ; parentId= + s + |> Span.get_parent + |> Option.map (fun x -> + x |> Span.get_context |> SpanContext.span_id_of_span_context + ) + ; name= s |> Span.get_name + ; timestamp= int_of_float (Span.get_begin_time s *. 1000000.) + ; duration= + Option.value (Span.get_end_time s) + ~default:(Unix.gettimeofday () *. 1000000.) + -. Span.get_begin_time s + |> ( *. ) 1000000. + |> int_of_float + ; kind= + s + |> Span.get_span_kind + |> ZipkinSpan.kind_to_zipkin_kind + |> Option.map SpanKind.to_string + ; localEndpoint= {serviceName} + ; annotations + ; tags= Span.get_attributes s + } + + let content_of (spans : Span.t list) = + List.map zipkin_span_of_span spans |> ZipkinSpan.json_of_t_list + end + end +end + +module Destination = struct + module File = struct + let trace_log_dir = ref "/var/log/dt/zipkinv2/json" + + let max_file_size = ref (1 lsl 20) + + let compress_tracing_files = ref true + + let set_trace_log_dir dir = trace_log_dir := dir + + let get_trace_log_dir () = !trace_log_dir + + let set_max_file_size size = max_file_size := size + + let set_compress_tracing_files enabled = compress_tracing_files := enabled + + let file_name = ref None + + let lock = Mutex.create () + + let make_file_name () = + let date = Ptime_clock.now () |> Ptime.to_rfc3339 ~frac_s:6 in + let ( // ) = Filename.concat in + let name = + !trace_log_dir + // String.concat "-" [get_service_name (); !host_id; date] + ^ ".ndjson" + in + file_name := Some name ; + name + + let with_fd file_name = + Xapi_stdext_unix.Unixext.with_file file_name + [O_WRONLY; O_CREAT; O_APPEND] + 0o700 + + let write fd str = + let content = str ^ "\n" in + ignore @@ Unix.write_substring fd content 0 (String.length content) + + let export json = + try + let file_name = + match !file_name with None -> make_file_name () | Some x -> x + in + Xapi_stdext_unix.Unixext.mkdir_rec (Filename.dirname file_name) 0o700 ; + let@ fd = file_name |> with_fd in + write fd json ; + if (Unix.fstat fd).st_size >= !max_file_size then ( + debug "Tracing: Rotating file %s > %d" file_name !max_file_size ; + if !compress_tracing_files then + Zstd.Fast.compress_file Zstd.Fast.compress ~file_path:file_name + ~file_ext:"zst" ; + ignore @@ make_file_name () + ) ; + Ok () + with e -> Error e + + let with_stream f = + Xapi_stdext_threads.Threadext.Mutex.execute lock (fun () -> f export) + end + + module Http = struct + module Request = Cohttp.Request.Make (Cohttp_posix_io.Buffered_IO) + module Response = Cohttp.Response.Make (Cohttp_posix_io.Buffered_IO) + + let export ~url json = + try + let body = json in + let content_headers = + [ + ("Content-Type", "application/json") + ; ("Content-Length", string_of_int (String.length body)) + ] + in + let host = + match (Uri.host url, Uri.port url) with + | None, _ -> + None + | Some host, None -> + Some host + | Some host, Some port -> + Some (Printf.sprintf "%s:%d" host port) + in + let host_headers = + Option.fold ~none:[] ~some:(fun h -> [("Host", h)]) host + in + let headers = + List.concat [content_headers; host_headers] |> Cohttp.Header.of_list + in + + Open_uri.with_open_uri url (fun fd -> + let request = + Cohttp.Request.make ~meth:`POST ~version:`HTTP_1_1 ~headers url + in + (* `with_open_uri` already closes the `fd`. And therefore + according to the documentation of `in_channel_of_descr` and + `out_channel_of_descr` we should not close the channels on top of + `fd`. *) + let ic = Unix.in_channel_of_descr fd in + let oc = Unix.out_channel_of_descr fd in + Request.write + (fun writer -> Request.write_body writer body) + request oc ; + (* We flush instead of closing the sending stream as nginx responds to a TCP + half-shutdown with a full shutdown of both directions of the HTTP request *) + flush oc ; + match try Response.read ic with _ -> `Eof with + | `Eof -> + Ok () + | `Invalid x -> + Error (Failure ("invalid read: " ^ x)) + | `Ok response + when Cohttp.Code.(response.status |> code_of_status |> is_error) + -> + Error (Failure (Cohttp.Code.string_of_status response.status)) + | `Ok _ -> + Ok () + ) + with e -> Error e + end + + let export_to_endpoint parent traces endpoint = + debug "Tracing: About to export" ; + try + File.with_stream (fun file_export -> + let export, name = + match endpoint with + | Url url -> + (Http.export ~url, "Tracing.Http.export") + | Bugtool -> + (file_export, "Tracing.File.export") + in + let all_spans = + Hashtbl.fold (fun _ spans acc -> spans @ acc) traces [] + in + let attributes = + [ + ("export.span.count", all_spans |> List.length |> string_of_int) + ; ("export.endpoint", endpoint_to_string endpoint) + ; ( "xs.tracing.spans_table.count" + , Spans.span_count () |> string_of_int + ) + ; ( "xs.tracing.finished_spans_table.count" + , traces |> Hashtbl.length |> string_of_int + ) + ] + in + let@ _ = with_tracing ~parent ~attributes ~name in + all_spans + |> Content.Json.ZipkinV2.content_of + |> export + |> Result.iter_error raise + ) + with exn -> + debug "Tracing: unable to export span : %s" (Printexc.to_string exn) + + let flush_spans () = + let span_list = Spans.since () in + let attributes = + [("export.traces.count", Hashtbl.length span_list |> string_of_int)] + in + let@ parent = + with_tracing ~parent:None ~attributes ~name:"Tracing.flush_spans" + in + get_tracer_providers () + |> List.filter TracerProvider.get_enabled + |> List.concat_map TracerProvider.get_endpoints + |> List.iter (export_to_endpoint parent span_list) + + let delay = Delay.make () + + (* Note this signal will flush the spans and terminate the exporter thread *) + let signal () = Delay.signal delay + + let create_exporter () = + enable_span_garbage_collector () ; + Thread.create + (fun () -> + let signaled = ref false in + while not !signaled do + debug "Tracing: Waiting %d seconds before exporting spans" + (int_of_float !export_interval) ; + if not (Delay.wait delay !export_interval) then ( + debug "Tracing: we are signaled, export spans now and exit" ; + signaled := true + ) ; + flush_spans () + done + ) + () + + let exporter = ref None + + let lock = Mutex.create () + + let main () = + Xapi_stdext_threads.Threadext.Mutex.execute lock (fun () -> + match !exporter with + | None -> + let tid = create_exporter () in + exporter := Some tid ; + tid + | Some tid -> + tid + ) +end + +let flush_and_exit = Destination.signal + +let main = Destination.main diff --git a/ocaml/libs/tracing/tracing_export.mli b/ocaml/libs/tracing/tracing_export.mli new file mode 100644 index 00000000000..3f8ca750026 --- /dev/null +++ b/ocaml/libs/tracing/tracing_export.mli @@ -0,0 +1,95 @@ +(* +* Copyright (C) 2024 Cloud Software Group +* +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU Lesser General Public License as published +* by the Free Software Foundation; version 2.1 only. with the special +* exception on linking described in file LICENSE. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU Lesser General Public License for more details. +*) + +(** [Tracing_export] is a module dedicated for the creation and management of + threads that export the tracing data. + *) + +val set_export_interval : float -> unit +(** [set_export_interval seconds] sets the time interval between consecutive + exports of the finished spans to [seconds]. + + Default is every [30.] seconds. + *) + +val set_host_id : string -> unit +(** [set_host_id id] sets the id of the host to [id]. + + Default is ["localhost"]. + *) + +val set_service_name : string -> unit +(** [set_service_name name] sets the name of the service to [name]. + All spans will be exported under this service's name. + + Default name is ["unknown"]. + *) + +(** [Destination] is a module for managing the export of tracing data to + different types of endpoints, whether is exporting it to a [File] or an + [Http] endpoint. + *) +module Destination : sig + (** [File] is a module for managing the files in which the tracing data is + exported. + *) + module File : sig + val set_max_file_size : int -> unit + (** [set_max_file_size n] sets the maximum file size to [n]. If a file is + is already created at the time of export and the file exceeds the + maximum size, a new tracing file is created. + *) + + val set_trace_log_dir : string -> unit + (** [set_trace_log_dir log_dir] sets the location to which traces will be + exported. + + Default is ["/var/log/dt/zipkinv2/json"] + *) + + val get_trace_log_dir : unit -> string + (** [get_trace_log_dir ()] returns the cuurent location to which traces are + exported. + *) + + val set_compress_tracing_files : bool -> unit + (** [set_compress_tracing_files flag] sets wheater or not the tracing files + are compressed or not. + *) + end + + val flush_spans : unit -> unit + (** [flush_spans ()] forcefully flushes the spans to the current enabled + endpoints. + *) + + (** [Http] is a module for managing exporting tracing data to an http + endpoint. + *) + module Http : sig + val export : url:Uri.t -> string -> (unit, exn) result + (** [export ~url json] forcefully flushes json formatted spans [json] to the + given [url] . + *) + end +end + +val flush_and_exit : unit -> unit +(** [flush_and_exit ()] sends a signal to flush the finish spans and terminate + the exporter thread. + *) + +val main : unit -> Thread.t +(** [main ()] starts the exporter thread. + *) diff --git a/ocaml/message-switch/async/dune b/ocaml/message-switch/async/dune index 28ee31ecfa5..89f2c3a5ff4 100644 --- a/ocaml/message-switch/async/dune +++ b/ocaml/message-switch/async/dune @@ -2,12 +2,12 @@ (name message_switch_async) (public_name message-switch-async) (libraries - async - async_unix + (re_export async) + (re_export async_unix) async_kernel base cohttp-async - core + (re_export core) core_unix core_kernel core_unix.time_unix diff --git a/ocaml/message-switch/async/protocol_async.ml b/ocaml/message-switch/async/protocol_async.ml index 9ec9cc42b74..5898d22f77f 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 f691c24c989..d18b37b742c 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/core/dune b/ocaml/message-switch/core/dune index 676fa3f20ee..41cbf9e9f2d 100644 --- a/ocaml/message-switch/core/dune +++ b/ocaml/message-switch/core/dune @@ -8,7 +8,10 @@ rpclib.json sexplib sexplib0 + threads.posix 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 54e8904e1a9..224012909ac 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 00000000000..3b8da9803fe --- /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 f99e0582687..423304d1b24 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 2372cb34c98..cd7984bec27 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,7 +35,10 @@ let process = function let main () = let (_ : 'a Deferred.t) = - Server.listen ~process ~switch:!path ~queue:!name () + if !concurrent then + Server.listen_p ~process ~switch:!path ~queue:!name () + else + Server.listen ~process ~switch:!path ~queue:!name () in Ivar.read shutdown >>= fun () -> Clock.after (Time.Span.of_sec 1.) >>= fun () -> exit 0 @@ -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 e73c3a873d1..877790370a2 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 00000000000..a91768972fe --- /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 d500c101354..449f2fae5c5 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 00000000000..85cde8eaecb --- /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 00000000000..784599dafa4 --- /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 c30021ff35d..ece423dcb74 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 () = - Message_switch_lwt.Protocol_lwt.Server.listen ~process ~switch:!path - ~queue:!name () + ( 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/dune b/ocaml/message-switch/lwt/dune index 2aaf432952b..12f03301298 100644 --- a/ocaml/message-switch/lwt/dune +++ b/ocaml/message-switch/lwt/dune @@ -4,8 +4,8 @@ (libraries cohttp-lwt-unix message-switch-core - lwt - lwt.unix + (re_export lwt) + (re_export lwt.unix) ) ) diff --git a/ocaml/message-switch/lwt/protocol_lwt.ml b/ocaml/message-switch/lwt/protocol_lwt.ml index 6da59eb3212..26c9c874d55 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 c9bd220155d..64ca15c0e8e 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 9bf78973a85..583baf6e594 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 678b302ab5a..485964a40ec 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/sdk-gen/README.md b/ocaml/sdk-gen/README.md index 7473d141f83..fb4d71650bf 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 dfe92390216..e5fb8622069 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/gen_c_binding.ml b/ocaml/sdk-gen/c/gen_c_binding.ml index 2302fc6cf99..757046ac336 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,295 +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 gen_decl cls = + let headers = ref (StringSet.add (cls.name ^ "_decl") StringSet.empty) in + let rec get_needed = function + | Field fr -> + find_needed headers fr.ty + | Namespace (_, cs) -> + List.iter get_needed cs + in + List.iter get_needed cls.contents ; -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 - ) + 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 - let full_stop = - if Astring.String.is_suffix ~affix:"." description then "" else "." + 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 - let rec get_needed x = - match x with +and gen_impl cls = + let headers = ref 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) - ) ; + List.iter get_needed cls.contents ; - 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 - -and decl_set tn referenced = - let alloc_com = - Helper.comment true (sprintf "Allocate a %s_set of the given size." tn) - 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") + 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_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 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 -> + "" in - - 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 - | 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 - -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 - -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 - "" - -and get_message_comment message = - let full_stop = - if Astring.String.is_suffix ~affix:"." message.msg_doc then "" else "." + 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 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 + let is_result_record message = + match message.msg_result with + | Some res -> ( + match fst res with Record _ -> true | _ -> false + ) + | None -> + false 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") + 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 result_bits = - match message.msg_result with + let syncParams x = + match x.msg_result with | Some res -> - abstract_result_handling classname message.msg_name param_count res + { + param_type= fst res + ; param_name= "*result" + ; param_doc= "" + ; param_release= x.msg_release + ; param_default= None + } + :: x.msg_params | None -> - sprintf - " xen_call_(session, \"%s.%s\", %s, %d, NULL, NULL);\n\ - \ return session->ok;\n" - classname message.msg_name - (if param_count = 0 then "NULL" else param_call) - param_count + x.msg_params 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") - 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 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 + `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 + 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 - let result_bits = - abstract_result_handling_async classname message.msg_name param_count - in - sprintf "\n%s%s\n{\n%s\n%s}" - (get_deprecated_message message) - messageSigAsync param_decl result_bits - else - "" +and full_stop x = if Astring.String.is_suffix ~affix:"." x then "" else "." -and abstract_params params = joined ",\n " abstract_param params +and full_class_doc cls = + let intro = sprintf "The %s class.\n\n" cls.name in + intro ^ cls.description ^ full_stop cls.description -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_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 _ -> @@ -443,9 +449,7 @@ and abstract_member = function "bool" | DateTime -> "datetime" - | Set _ -> - "set" - | Map _ -> + | Set _ | Map _ -> "set" | Record _ -> "struct" @@ -453,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" @@ -575,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 @@ -677,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)) ) @@ -702,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) - in - - 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 - | Enum (x, _) -> - "\n" ^ hash_include x - | _ -> - "" - -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") +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 - Fun.protect - (fun () -> - print_h_header out_chan protect ; - gen_failure_enum out_chan ; - gen_failure_funcs out_chan ; - print_h_footer out_chan + render_file + ( "xen_enum_map_internal.h.mustache" + , sprintf "include/xen_%s_internal.h" (String.lowercase_ascii x) ) - ~finally:(fun () -> close_out out_chan) - -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 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 + json templates_dir destdir + +and render_map_decl l r = + let headers = ref StringSet.empty in + let add_enum_header = function + | Enum (x, _) -> + headers := StringSet.add x !headers + | _ -> + () + 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 - 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) - ) - :: 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 \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 ())) + 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 failure_lookup_entries () = - List.sort String.compare - (Hashtbl.fold failure_lookup_entry Datamodel.errors []) +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_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 - ) - 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 + 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 - 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 + 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) + ) + ) + ) + ) + ; ( "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 mappingName = sprintf "%s_%s" tn record_tn in - - let free_block = - String.concat "\n" - (( if is_event then - [] - else - [sprintf "XEN_FREE(%s)" tn; sprintf "XEN_SET_ALLOC_FREE(%s)" tn] - ) - @ [ - sprintf "XEN_ALLOC(%s)" record_tn - ; sprintf "XEN_SET_ALLOC_FREE(%s)" record_tn - ] - @ - if is_event then - [] - else - [ - sprintf "XEN_ALLOC(%s)" record_opt_tn - ; sprintf "XEN_RECORD_OPT_FREE(%s)" tn - ; sprintf "XEN_SET_ALLOC_FREE(%s)" record_opt_tn - ] + 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 + +and gen_failure () = + let errors = + Hashtbl.fold + (fun _ x acc -> + (x.Datamodel_types.err_name, x.Datamodel_types.err_doc) :: acc ) + 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 + [ + ("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 \n#include \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, _) -> @@ -1091,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 -> @@ -1167,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 @@ -1220,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" @@ -1262,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) @@ -1284,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 @@ -1302,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) @@ -1319,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 384ffcb174d..ac78e5ca1e6 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 00000000000..55f6da267ae --- /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 +#include + +{{#internal_headers}} +#include "xen_{{header}}.h" +{{/internal_headers}} +{{#headers}} +#include +{{/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 00000000000..98dd1f37446 --- /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 +{{/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 00000000000..521d3d49d40 --- /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 00000000000..0b944b35ad3 --- /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 +{{/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 00000000000..aa7c96bf512 --- /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 +{{/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 9d9bef9143e..fb86a54f4ef 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 #include {{#api_headers}} -#include <{{api_header}}> +#include {{/api_headers}} #include #include #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 00000000000..f35926bfce1 --- /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 + + +/* + * 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 00000000000..3094d7a51ea --- /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 0a13575d334..94b0c894b47 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 5f55ec79291..09115486aa6 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 421c9015a6f..90b1d200868 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 824179cf2d3..3a944a71438 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 b9731686edb..f3945be9738 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 00000000000..6d595ad16fc --- /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 934ae5047e0..621617511ce 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 cbe06791bad..abbb3b0b1e7 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 8088982ff47..4d5b19e26be 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/dune b/ocaml/tests/dune index d1f8df151af..c6c7caed7e7 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -132,7 +132,7 @@ (package xapi) (modes (best exe)) (modules test_observer) -(libraries alcotest fmt tracing xapi_internal tests_common yojson log uri xapi-stdext-unix re ppx_deriving.runtime xapi-stdext-std)) +(libraries alcotest fmt tracing xapi_internal tests_common yojson log uri xapi-stdext-unix re ppx_deriving.runtime xapi-stdext-std xapi-tracing.export)) (rule (alias runtest) diff --git a/ocaml/tests/record_util/old_record_util.ml b/ocaml/tests/record_util/old_record_util.ml index be84179d744..b8648bbafb7 100644 --- a/ocaml/tests/record_util/old_record_util.ml +++ b/ocaml/tests/record_util/old_record_util.ml @@ -728,7 +728,7 @@ let host_numa_affinity_policy_of_string a = ("Expected 'any', 'best_effort' or 'default_policy', got " ^ s) ) -let pgpu_dom0_access_to_string x = host_display_to_string x +let pci_dom0_access_to_string x = host_display_to_string x let string_to_vdi_onboot s = match String.lowercase_ascii s with diff --git a/ocaml/tests/record_util/test_record_util.ml b/ocaml/tests/record_util/test_record_util.ml index e560904366b..225c2aca446 100644 --- a/ocaml/tests/record_util/test_record_util.ml +++ b/ocaml/tests/record_util/test_record_util.ml @@ -177,7 +177,7 @@ let tests = , N.host_numa_affinity_policy_to_string ) ; mk __LINE__ None all_pgpu_dom0_access - (O.pgpu_dom0_access_to_string, N.pgpu_dom0_access_to_string) + (O.pci_dom0_access_to_string, N.pci_dom0_access_to_string) ; mk __LINE__ None all_vbd_mode (O.vbd_mode_to_string, N.vbd_mode_to_string) (*; mk __LINE__ None all_power (O.power_to_string, N.power_to_string)*) ; mk __LINE__ None all_vdi_type (O.vdi_type_to_string, N.vdi_type_to_string) diff --git a/ocaml/tests/test_observer.ml b/ocaml/tests/test_observer.ml index 165bc4afd1b..a6b943741b1 100644 --- a/ocaml/tests/test_observer.ml +++ b/ocaml/tests/test_observer.ml @@ -12,6 +12,7 @@ * GNU Lesser General Public License for more details. *) open Tracing +open Tracing_export module D = Debug.Make (struct let name = "test_observer" end) @@ -38,8 +39,8 @@ let trace_log_dir ?(test_name = "") () = (Printf.sprintf "%s/var/log/dt/zipkinv2/json/" test_name) let () = - Export.Destination.File.set_trace_log_dir (trace_log_dir ()) ; - Export.set_service_name "unit_tests" ; + Destination.File.set_trace_log_dir (trace_log_dir ()) ; + set_service_name "unit_tests" ; set_observe false module Xapi_DB = struct @@ -62,17 +63,15 @@ end module TracerProvider = struct let assert_num_observers ~__context x = - let providers = Tracing.get_tracer_providers () in + let providers = get_tracer_providers () in Alcotest.(check int) (Printf.sprintf "%d provider(s) exists in lib " x) x (List.length providers) let find_provider_exn ~name = - let providers = Tracing.get_tracer_providers () in + let providers = get_tracer_providers () in match - List.find_opt - (fun x -> Tracing.TracerProvider.get_name_label x = name) - providers + List.find_opt (fun x -> TracerProvider.get_name_label x = name) providers with | Some provider -> provider @@ -83,11 +82,11 @@ module TracerProvider = struct let provider = find_provider_exn ~name in Alcotest.(check bool) "Provider disabled" false - (Tracing.TracerProvider.get_enabled provider) + (TracerProvider.get_enabled provider) let assert_mandatory_attributes ~name = let provider = find_provider_exn ~name in - let tags = Tracing.TracerProvider.get_attributes provider in + let tags = TracerProvider.get_attributes provider in List.iter (fun x -> try @@ -106,7 +105,7 @@ module TracerProvider = struct let check_endpoints ~name ~endpoints = let provider = find_provider_exn ~name in let provider_endpoints = - Tracing.TracerProvider.get_endpoints provider + TracerProvider.get_endpoints provider |> List.map (fun endpoint -> match endpoint with | Bugtool -> @@ -338,7 +337,7 @@ let test_file_export_writes () = let test_trace_log_dir = trace_log_dir ~test_name:"test_file_export_writes" () in - Export.Destination.File.set_trace_log_dir test_trace_log_dir ; + Destination.File.set_trace_log_dir test_trace_log_dir ; let __context = Test_common.make_test_database () in let self = test_create ~__context ~enabled:true () in clear_dir ~test_trace_log_dir () ; @@ -347,7 +346,7 @@ let test_file_export_writes () = match span with | Ok x -> ( let _ = Tracer.finish x in - Tracing.Export.Destination.flush_spans () ; + Destination.flush_spans () ; Alcotest.(check bool) "tracing files written to disk when tracing enabled by default" false @@ -365,7 +364,7 @@ let test_file_export_writes () = match span with | Ok x -> let _ = Tracer.finish x in - Tracing.Export.Destination.flush_spans () ; + Destination.flush_spans () ; Alcotest.(check bool) "tracing files not written when tracing disabled" true (is_dir_empty ~test_trace_log_dir) @@ -424,7 +423,7 @@ let test_hashtbl_leaks () = (Tracer.finished_span_hashtbl_is_empty ()) false ; - Tracing.Export.Destination.flush_spans () ; + Destination.flush_spans () ; Alcotest.(check bool) "Span export clears finished_spans hashtable" (Tracer.finished_span_hashtbl_is_empty ()) @@ -515,14 +514,14 @@ let test_attribute_validation () = Alcotest.(check bool) ("Good key, value pair with " ^ key ^ ":" ^ value) true - (Tracing.validate_attribute (key, value)) + (validate_attribute (key, value)) in let test_bad_attribute (key, value) = Alcotest.(check bool) ("Bad key, value pair with " ^ key ^ ":" ^ value) false - (Tracing.validate_attribute (key, value)) + (validate_attribute (key, value)) in List.iter test_good_attribute good_attributes ; diff --git a/ocaml/tests/test_vm_check_operation_error.ml b/ocaml/tests/test_vm_check_operation_error.ml index a91fdcfa229..0423338e630 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 f8aa043eb5a..72f34e3ace9 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 ." ; 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 ." ; 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 ." ; implementation= With_fd Cli_operations.template_export ; flags= [Standard] @@ -3671,6 +3683,33 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [] } ) + ; ( "pci-enable-dom0-access" + , { + reqd= ["uuid"] + ; optn= [] + ; help= "Enable PCI access to dom0." + ; implementation= No_fd Cli_operations.pci_enable_dom0_access + ; flags= [] + } + ) + ; ( "pci-disable-dom0-access" + , { + reqd= ["uuid"] + ; optn= [] + ; help= "Disable PCI access to dom0." + ; implementation= No_fd Cli_operations.pci_disable_dom0_access + ; flags= [] + } + ) + ; ( "pci-get-dom0-access-status" + , { + reqd= ["uuid"] + ; optn= [] + ; help= "Return a PCI device's dom0 access status." + ; implementation= No_fd Cli_operations.get_dom0_access_status + ; flags= [] + } + ) ] let cmdtable : (string, cmd_spec) Hashtbl.t = Hashtbl.create 50 diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index bc0d9ea30bc..bc16bfb1286 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 @@ -1142,7 +1144,7 @@ let gen_cmds rpc session_id = ) ; Client.PGPU.( mk get_all_records_where get_by_uuid pgpu_record "pgpu" [] - ["uuid"; "vendor-name"; "device-name"; "gpu-group-uuid"] + ["uuid"; "pci-uuid"; "vendor-name"; "device-name"; "gpu-group-uuid"] rpc session_id ) ; Client.GPU_group.( @@ -1329,6 +1331,11 @@ let gen_cmds rpc session_id = ] rpc session_id ) + ; Client.PCI.( + mk get_all_records_where get_by_uuid pci_record "pci" [] + ["uuid"; "vendor-name"; "device-name"; "pci-id"] + rpc session_id + ) ] let message_create (_ : printer) rpc session_id params = @@ -1520,16 +1527,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 +3270,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 +3316,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 +5581,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 +5807,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 +5859,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 +5886,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 +5932,7 @@ let vm_export fd printer rpc session_id params = ; "compress" ; "preserve-power-state" ; "include-snapshots" + ; "excluded-device-types" ] ) @@ -5946,32 +5940,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 +7334,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 @@ -7503,13 +7488,13 @@ let pgpu_enable_dom0_access printer rpc session_id params = let uuid = List.assoc "uuid" params in let ref = Client.PGPU.get_by_uuid ~rpc ~session_id ~uuid in let result = Client.PGPU.enable_dom0_access ~rpc ~session_id ~self:ref in - printer (Cli_printer.PMsg (Record_util.pgpu_dom0_access_to_string result)) + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) let pgpu_disable_dom0_access printer rpc session_id params = let uuid = List.assoc "uuid" params in let ref = Client.PGPU.get_by_uuid ~rpc ~session_id ~uuid in let result = Client.PGPU.disable_dom0_access ~rpc ~session_id ~self:ref in - printer (Cli_printer.PMsg (Record_util.pgpu_dom0_access_to_string result)) + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) let lvhd_enable_thin_provisioning _printer rpc session_id params = let sr_uuid = List.assoc "sr-uuid" params in @@ -7533,6 +7518,24 @@ let lvhd_enable_thin_provisioning _printer rpc session_id params = ["sr-uuid"; "initial-allocation"; "allocation-quantum"] ) +let pci_enable_dom0_access printer rpc session_id params = + let uuid = List.assoc "uuid" params in + let ref = Client.PCI.get_by_uuid ~rpc ~session_id ~uuid in + let result = Client.PCI.enable_dom0_access ~rpc ~session_id ~self:ref in + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) + +let pci_disable_dom0_access printer rpc session_id params = + let uuid = List.assoc "uuid" params in + let ref = Client.PCI.get_by_uuid ~rpc ~session_id ~uuid in + let result = Client.PCI.disable_dom0_access ~rpc ~session_id ~self:ref in + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) + +let get_dom0_access_status printer rpc session_id params = + let uuid = List.assoc "uuid" params in + let ref = Client.PCI.get_by_uuid ~rpc ~session_id ~uuid in + let result = Client.PCI.get_dom0_access_status ~rpc ~session_id ~self:ref in + printer (Cli_printer.PMsg (Record_util.pci_dom0_access_to_string result)) + module PVS_site = struct let introduce printer rpc session_id params = let name_label = List.assoc "name-label" params in @@ -7918,13 +7921,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 +7937,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 bacf9177698..b30af37674a 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -738,7 +738,7 @@ let host_numa_affinity_policy_of_string a = ("Expected 'any', 'best_effort' or 'default_policy', got " ^ s) ) -let pgpu_dom0_access_to_string x = host_display_to_string x +let pci_dom0_access_to_string x = host_display_to_string x let string_to_vdi_onboot s = match String.lowercase_ascii s with @@ -954,12 +954,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-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index 6648d755876..91374487259 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -4127,6 +4127,9 @@ let pgpu_record rpc session_id pgpu = ; fields= [ make_field ~name:"uuid" ~get:(fun () -> (x ()).API.pGPU_uuid) () + ; make_field ~name:"pci-uuid" + ~get:(fun () -> try (xp ()).API.pCI_uuid with _ -> nid) + () ; make_field ~name:"vendor-name" ~get:(fun () -> try (xp ()).API.pCI_vendor_name with _ -> nid) () @@ -4135,7 +4138,7 @@ let pgpu_record rpc session_id pgpu = () ; make_field ~name:"dom0-access" ~get:(fun () -> - Record_util.pgpu_dom0_access_to_string (x ()).API.pGPU_dom0_access + Record_util.pci_dom0_access_to_string (x ()).API.pGPU_dom0_access ) () ; make_field ~name:"is-system-display-device" @@ -5500,3 +5503,80 @@ let observer_record rpc session_id observer = () ] } + +let pci_record rpc session_id pci = + let _ref = ref pci in + let empty_record = + ToGet (fun () -> Client.PCI.get_record ~rpc ~session_id ~self:!_ref) + in + let record = ref empty_record in + let x () = lzy_get record in + let pci_record p = + ref (ToGet (fun () -> Client.PCI.get_record ~rpc ~session_id ~self:p)) + in + let xp0 p = lzy_get (pci_record p) in + { + setref= + (fun r -> + _ref := r ; + record := empty_record + ) + ; setrefrec= + (fun (a, b) -> + _ref := a ; + record := Got b + ) + ; record= x + ; getref= (fun () -> !_ref) + ; fields= + [ + make_field ~name:"uuid" ~get:(fun () -> (x ()).API.pCI_uuid) () + ; make_field ~name:"vendor-name" + ~get:(fun () -> try (x ()).API.pCI_vendor_name with _ -> nid) + () + ; make_field ~name:"device-name" + ~get:(fun () -> try (x ()).API.pCI_device_name with _ -> nid) + () + ; make_field ~name:"driver-name" + ~get:(fun () -> try (x ()).API.pCI_driver_name with _ -> nid) + () + ; make_field ~name:"host-uuid" + ~get:(fun () -> + try get_uuid_from_ref (x ()).API.pCI_host with _ -> nid + ) + () + ; make_field ~name:"host-name-label" + ~get:(fun () -> + try get_name_from_ref (x ()).API.pCI_host with _ -> nid + ) + () + ; make_field ~name:"pci-id" + ~get:(fun () -> try (x ()).API.pCI_pci_id with _ -> nid) + () + ; make_field ~name:"dependencies" + ~get:(fun () -> + map_and_concat + (fun pci -> (xp0 pci).API.pCI_pci_id) + (x ()).API.pCI_dependencies + ) + ~get_set:(fun () -> + List.map + (fun pci -> (xp0 pci).API.pCI_pci_id) + (x ()).API.pCI_dependencies + ) + () + ; make_field ~name:"other-config" + ~get:(fun () -> + Record_util.s2sm_to_string "; " (x ()).API.pCI_other_config + ) + ~add_to_map:(fun key value -> + Client.PCI.add_to_other_config ~rpc ~session_id ~self:pci ~key + ~value + ) + ~remove_from_map:(fun key -> + Client.PCI.remove_from_other_config ~rpc ~session_id ~self:pci ~key + ) + ~get_map:(fun () -> (x ()).API.pCI_other_config) + () + ] + } diff --git a/ocaml/xapi-guard/lib/disk_cache.ml b/ocaml/xapi-guard/lib/disk_cache.ml index 0f0a6e2c248..5e8b9bb0650 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 - (Printexc.to_string e) ; + 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 3f2b41c7682..ff6dbc1dd3c 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 f210ea8c96a..06b811ba30c 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 97b144839a6..3e51cab2c35 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-guard/test/dune b/ocaml/xapi-guard/test/dune index 88e9d6887d9..9d44fdefbac 100644 --- a/ocaml/xapi-guard/test/dune +++ b/ocaml/xapi-guard/test/dune @@ -32,6 +32,8 @@ lwt.unix mtime mtime.clock.os + result uuidm + xapi-log xapi_guard) (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-storage/generator/lib/control.ml b/ocaml/xapi-storage/generator/lib/control.ml index 93b2800a766..f4d8a22a4a5 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 eca6cf45afb..3da8be64711 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 b85cff59c56..7f989e33066 100644 --- a/ocaml/xapi-storage/rpc-light/SR.ls/response +++ b/ocaml/xapi-storage/rpc-light/SR.ls/response @@ -12,6 +12,8 @@ physical_utilisation0 uriuri1 keys + volume_typeData + cbt_enabledfalse diff --git a/ocaml/xapi-storage/rpc-light/Volume.clone/response b/ocaml/xapi-storage/rpc-light/Volume.clone/response index 4b0f52b2305..dc4036f599d 100644 --- a/ocaml/xapi-storage/rpc-light/Volume.clone/response +++ b/ocaml/xapi-storage/rpc-light/Volume.clone/response @@ -11,6 +11,8 @@ physical_utilisation0 uriuri1 keys + volume_typeData + cbt_enabledfalse diff --git a/ocaml/xapi-storage/rpc-light/Volume.create/response b/ocaml/xapi-storage/rpc-light/Volume.create/response index 4b0f52b2305..dc4036f599d 100644 --- a/ocaml/xapi-storage/rpc-light/Volume.create/response +++ b/ocaml/xapi-storage/rpc-light/Volume.create/response @@ -11,6 +11,8 @@ physical_utilisation0 uriuri1 keys + volume_typeData + cbt_enabledfalse diff --git a/ocaml/xapi-storage/rpc-light/Volume.snapshot/response b/ocaml/xapi-storage/rpc-light/Volume.snapshot/response index 4b0f52b2305..dc4036f599d 100644 --- a/ocaml/xapi-storage/rpc-light/Volume.snapshot/response +++ b/ocaml/xapi-storage/rpc-light/Volume.snapshot/response @@ -11,6 +11,8 @@ physical_utilisation0 uriuri1 keys + volume_typeData + cbt_enabledfalse diff --git a/ocaml/xapi-types/features.ml b/ocaml/xapi-types/features.ml index 37fafc0905a..d55d7d01c37 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 c2f1ed2a51b..0696b3ddb5e 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 4179cf7d930..dce55ca4d40 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 76ce076be7a..1c92b8e6017 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -76,6 +76,7 @@ http_lib httpsvr ipaddr + magic-mime message-switch-core message-switch-unix mirage-crypto @@ -149,6 +150,7 @@ xapi-stdext-unix xapi-stdext-zerocheck xapi-tracing + xapi-tracing.export xapi-xenopsd xenstore_transport.unix xml-light2 diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 49ccc7b0c57..c549fb74295 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,38 +77,40 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state then ( add vm ; let vm = Db.VM.get_record ~__context ~self:vm in - List.iter - (fun vif -> - if Db.is_valid_ref __context vif then ( - add vif ; - let vif = Db.VIF.get_record ~__context ~self:vif in - add vif.API.vIF_network + if not (List.mem Devicetype.VIF excluded_devices) then + List.iter + (fun vif -> + if Db.is_valid_ref __context vif then ( + add vif ; + let vif = Db.VIF.get_record ~__context ~self:vif in + add vif.API.vIF_network + ) ) - ) - vm.API.vM_VIFs ; - List.iter - (fun vbd -> - if Db.is_valid_ref __context vbd then ( - add vbd ; - let vbd = Db.VBD.get_record ~__context ~self:vbd in - if not vbd.API.vBD_empty then - add_vdi vbd.API.vBD_VDI + 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 ( + add vbd ; + let vbd = Db.VBD.get_record ~__context ~self:vbd in + if not vbd.API.vBD_empty then + add_vdi vbd.API.vBD_VDI + ) ) - ) - vm.API.vM_VBDs ; - List.iter - (fun vgpu -> - if Db.is_valid_ref __context vgpu then ( - add vgpu ; - let vgpu = Db.VGPU.get_record ~__context ~self:vgpu in - add vgpu.API.vGPU_type ; - add vgpu.API.vGPU_GPU_group + 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 ( + add vgpu ; + let vgpu = Db.VGPU.get_record ~__context ~self:vgpu in + add vgpu.API.vGPU_type ; + add vgpu.API.vGPU_GPU_group + ) ) - ) - vm.API.vM_VGPUs ; + 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,15 +120,16 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state ) ) ; (* add VTPMs that belong to this VM *) - vm.API.vM_VTPMs - |> List.iter (fun ref -> if Db.is_valid_ref __context ref then add ref) ; + 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) ; (* If we need to include snapshots, update the table for VMs in the 'snapshots' field *) if include_snapshots then 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 export_all_vms_from_request ~__context (req : Request.t) = - bool_from_request ~__context req false "all" +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 include_vhd_parents_from_request ~__context (req : Request.t) = - bool_from_request ~__context req false "include_vhd_parents" +let export_all_vms_from_request req = bool_from_request req false "all" -let export_snapshots_from_request ~__context (req : Request.t) = - bool_from_request ~__context req true "export_snapshots" +let include_vhd_parents_from_request req = + bool_from_request req false "include_vhd_parents" -let include_dom0_from_request ~__context (req : Request.t) = - bool_from_request ~__context req true "include_dom0" +let export_snapshots_from_request req = + bool_from_request req true "export_snapshots" + +let include_dom0_from_request req = bool_from_request 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 1c4cf9520e3..ed9ed334d66 100644 --- a/ocaml/xapi/fileserver.ml +++ b/ocaml/xapi/fileserver.ml @@ -42,40 +42,8 @@ let missing uri = ^ " was not found on this server.

Xapi \ Server
" -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 fd6d898b1e0..01e5ca25640 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -2158,11 +2158,18 @@ 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 = - List.filter - (fun vmref -> not (Db.VM.get_is_a_snapshot ~__context ~self:vmref)) + let non_snapshots = + List.filter + (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)) diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index a7354fce45e..f90a8da80ea 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/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index b2eb86c805d..5caa4609ec4 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -5867,7 +5867,31 @@ functor module Secret = Local.Secret - module PCI = struct end + module PCI = struct + let disable_dom0_access ~__context ~self = + info "PCI.disable_dom0_access: pci = '%s'" (pci_uuid ~__context self) ; + let host = Db.PCI.get_host ~__context ~self in + let local_fn = Local.PCI.disable_dom0_access ~self in + do_op_on ~__context ~local_fn ~host (fun session_id rpc -> + Client.PCI.disable_dom0_access ~rpc ~session_id ~self + ) + + let enable_dom0_access ~__context ~self = + info "PCI.enable_dom0_access: pci = '%s'" (pci_uuid ~__context self) ; + let host = Db.PCI.get_host ~__context ~self in + let local_fn = Local.PCI.enable_dom0_access ~self in + do_op_on ~__context ~local_fn ~host (fun session_id rpc -> + Client.PCI.enable_dom0_access ~rpc ~session_id ~self + ) + + let get_dom0_access_status ~__context ~self = + info "PCI.get_dom0_access_status: pci = '%s'" (pci_uuid ~__context self) ; + let host = Db.PCI.get_host ~__context ~self in + let local_fn = Local.PCI.get_dom0_access_status ~self in + do_op_on ~__context ~local_fn ~host (fun session_id rpc -> + Client.PCI.get_dom0_access_status ~rpc ~session_id ~self + ) + end module VTPM = struct let create ~__context ~vM ~is_unique = diff --git a/ocaml/xapi/stream_vdi.ml b/ocaml/xapi/stream_vdi.ml index 64b1da93eee..3c27d158af3 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.`, + 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 7e22dc86597..6fe4e40d70d 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 ; - None + (* 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 e9c1c53ad0c..bdbb4dee6c2 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 040f5782273..00f01d83ed2 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_observer.ml b/ocaml/xapi/xapi_observer.ml index eff01624156..b282f76bfe0 100644 --- a/ocaml/xapi/xapi_observer.ml +++ b/ocaml/xapi/xapi_observer.ml @@ -82,15 +82,15 @@ module Observer : ObserverInterface = struct let init ~__context = debug "Observer.init" ; - ignore @@ Tracing.main () + ignore @@ Tracing_export.main () let set_trace_log_dir ~__context ~dir = debug "Observer.set_trace_log_dir" ; - Tracing.Export.Destination.File.set_trace_log_dir dir + Tracing_export.Destination.File.set_trace_log_dir dir let set_export_interval ~__context ~interval = debug "Observer.set_export_interval" ; - Tracing.Export.set_export_interval interval + Tracing_export.set_export_interval interval let set_max_spans ~__context ~spans = debug "Observer.set_max_spans" ; @@ -102,15 +102,15 @@ module Observer : ObserverInterface = struct let set_max_file_size ~__context ~file_size = debug "Observer.set_max_file_size" ; - Tracing.Export.Destination.File.set_max_file_size file_size + Tracing_export.Destination.File.set_max_file_size file_size let set_host_id ~__context ~host_id = debug "Observer.set_host_id" ; - Tracing.Export.set_host_id host_id + Tracing_export.set_host_id host_id let set_compress_tracing_files ~__context ~enabled = debug "Observer.set_compress_tracing_files" ; - Tracing.Export.Destination.File.set_compress_tracing_files enabled + Tracing_export.Destination.File.set_compress_tracing_files enabled end module Xapi_cluster = struct @@ -248,7 +248,7 @@ module ObserverConfig = struct let rec bugtool_endpoint endpoints = match endpoints with | x :: _ when x = Tracing.bugtool_name -> - Some (Tracing.Export.Destination.File.get_trace_log_dir ()) + Some (Tracing_export.Destination.File.get_trace_log_dir ()) | _ :: t -> bugtool_endpoint t | [] -> @@ -570,7 +570,7 @@ let initialise ~__context = |> observed_components_of |> List.iter (initialise_observer_component ~__context) ) ; - Tracing.Export.set_service_name "xapi" + Tracing_export.set_service_name "xapi" let set_hosts ~__context ~self ~value = assert_valid_hosts ~__context value ; diff --git a/ocaml/xapi/xapi_pci.ml b/ocaml/xapi/xapi_pci.ml index 6e72c366ec7..6da3c4e220e 100644 --- a/ocaml/xapi/xapi_pci.ml +++ b/ocaml/xapi/xapi_pci.ml @@ -319,3 +319,12 @@ let get_system_display_device () = ) None items with _ -> None + +let disable_dom0_access ~__context ~self = + Xapi_pci_helpers.update_dom0_access ~__context ~self ~action:`disable + +let enable_dom0_access ~__context ~self = + Xapi_pci_helpers.update_dom0_access ~__context ~self ~action:`enable + +let get_dom0_access_status ~__context ~self = + Xapi_pci_helpers.determine_dom0_access_status ~__context ~self diff --git a/ocaml/xapi/xapi_pci.mli b/ocaml/xapi/xapi_pci.mli index dd71dfffcc2..366da0168b8 100644 --- a/ocaml/xapi/xapi_pci.mli +++ b/ocaml/xapi/xapi_pci.mli @@ -51,3 +51,21 @@ val disable_system_display_device : unit -> unit val dequarantine : __context:Context.t -> Xenops_interface.Pci.address -> unit (** dequarantine a PCI device. This is idempotent. *) + +val disable_dom0_access : + __context:Context.t + -> self:API.ref_PCI + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] +(** Hide a PCI device from the dom0 kernel. (Takes affect after next boot.) *) + +val enable_dom0_access : + __context:Context.t + -> self:API.ref_PCI + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] +(** Unhide a PCI device from the dom0 kernel. (Takes affect after next boot.) *) + +val get_dom0_access_status : + __context:Context.t + -> self:API.ref_PCI + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] +(** Return a PCI device dom0 access status. *) diff --git a/ocaml/xapi/xapi_pci_helpers.ml b/ocaml/xapi/xapi_pci_helpers.ml index 36caab3a606..873031c9f35 100644 --- a/ocaml/xapi/xapi_pci_helpers.ml +++ b/ocaml/xapi/xapi_pci_helpers.ml @@ -15,6 +15,7 @@ module D = Debug.Make (struct let name = "xapi_pci_helpers" end) open D +module Unixext = Xapi_stdext_unix.Unixext type pci_property = {id: int; name: string} @@ -172,3 +173,68 @@ let get_host_pcis () = let igd_is_whitelisted ~__context pci = let vendor_id = Db.PCI.get_vendor_id ~__context ~self:pci in List.mem vendor_id !Xapi_globs.igd_passthru_vendor_whitelist + +let is_pci_hidden_cmdline ~__context ~self = + let cmdline = + match Unixext.read_lines ~path:"/proc/cmdline" with + | [x] -> + x + | _ -> + failwith "Unable to read cmdline" + in + let device = Db.PCI.get_pci_id ~__context ~self in + let elems = String.split_on_char ' ' cmdline in + let xen_hide_param = "xen-pciback.hide=" in + let xen_hide_param_length = String.length xen_hide_param in + let pciback = + List.find_map + (fun s -> + if String.starts_with ~prefix:xen_hide_param s then + Some + (String.sub s xen_hide_param_length + (String.length s - xen_hide_param_length) + ) + else + None + ) + elems + in + (* Look for the device id in the list of hidden devices + * pciback looks like: "xen-pciback.hide=()()..." *) + let contains str substr = Astring.String.is_infix ~affix:substr str in + match pciback with None -> false | Some value -> contains value device + +let determine_dom0_access_status ~__context ~self = + (* Current hidden status *) + let is_hidden_cmdline = is_pci_hidden_cmdline ~__context ~self in + (* Hidden status after reboot *) + let is_hidden = Pciops.is_pci_hidden ~__context self in + match (is_hidden_cmdline, is_hidden) with + | true, true -> + `disabled + | false, true -> + `disable_on_reboot + | false, false -> + `enabled + | true, false -> + `enable_on_reboot + +let update_dom0_access ~__context ~self ~action = + ( match action with + | `enable -> + Pciops.unhide_pci ~__context self + | `disable -> + Pciops.hide_pci ~__context self + ) ; + + let new_access = determine_dom0_access_status ~__context ~self in + (* Keep up to date deprecated PGPU DB field, to be removed eventually. *) + let expr = Printf.sprintf {|field "PCI"="%s"|} (Ref.string_of self) in + let pgpus = Db.PGPU.get_all_records_where ~__context ~expr in + List.iter + (fun (pgpu_ref, _) -> + Db.PGPU.set_dom0_access ~__context ~self:pgpu_ref ~value:new_access + ) + pgpus ; + + new_access diff --git a/ocaml/xapi/xapi_pgpu.ml b/ocaml/xapi/xapi_pgpu.ml index 93193aca55e..a8ce14d7347 100644 --- a/ocaml/xapi/xapi_pgpu.ml +++ b/ocaml/xapi/xapi_pgpu.ml @@ -357,27 +357,8 @@ let assert_can_run_VGPU ~__context ~self ~vgpu = ~vgpu_type let update_dom0_access ~__context ~self ~action = - let db_current = Db.PGPU.get_dom0_access ~__context ~self in - let db_new = - match (db_current, action) with - | `enabled, `enable | `disable_on_reboot, `enable -> - `enabled - | `disabled, `enable | `enable_on_reboot, `enable -> - `enable_on_reboot - | `enabled, `disable | `disable_on_reboot, `disable -> - `disable_on_reboot - | `disabled, `disable | `enable_on_reboot, `disable -> - `disabled - in let pci = Db.PGPU.get_PCI ~__context ~self in - ( match db_new with - | `enabled | `enable_on_reboot -> - Pciops.unhide_pci ~__context pci - | `disabled | `disable_on_reboot -> - Pciops.hide_pci ~__context pci - ) ; - Db.PGPU.set_dom0_access ~__context ~self ~value:db_new ; - db_new + Xapi_pci_helpers.update_dom0_access ~__context ~self:pci ~action let enable_dom0_access ~__context ~self = update_dom0_access ~__context ~self ~action:`enable diff --git a/ocaml/xapi/xapi_pgpu.mli b/ocaml/xapi/xapi_pgpu.mli index cb1a935ea45..83ffcb39ef2 100644 --- a/ocaml/xapi/xapi_pgpu.mli +++ b/ocaml/xapi/xapi_pgpu.mli @@ -51,10 +51,14 @@ val assert_can_run_VGPU : (** Check whether a VGPU can run on a particular PGPU. *) val enable_dom0_access : - __context:Context.t -> self:API.ref_PGPU -> API.pgpu_dom0_access + __context:Context.t + -> self:API.ref_PGPU + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] val disable_dom0_access : - __context:Context.t -> self:API.ref_PGPU -> API.pgpu_dom0_access + __context:Context.t + -> self:API.ref_PGPU + -> [`disable_on_reboot | `disabled | `enable_on_reboot | `enabled] (* For AMD MxGPU. Acts on the local host only. * Ensures that the "gim" kernel module is loaded on localhost, diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index b44c8bf5916..8f7a7d8012a 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_helpers.ml b/ocaml/xapi/xapi_vdi_helpers.ml index 2e3355ef1f4..6b4366a80ce 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 d90da39619e..ccee66500cd 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/xcp-rrdd/bin/rrdp-dcmi/dune b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune new file mode 100644 index 00000000000..0f438a65861 --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune @@ -0,0 +1,16 @@ +(executable + (modes exe) + (name rrdp_dcmi) + (package rrdd-plugins) + (public_name xcp-rrdd-dcmi) + (libraries + dune-build-info + rrdd-plugin + rrdd-plugins.libs + xapi-idl.rrd + xapi-log + xapi-rrd + astring + ) +) + diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml b/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml new file mode 100644 index 00000000000..03afac48bc7 --- /dev/null +++ b/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.ml @@ -0,0 +1,80 @@ +(* + * Copyright (c) 2024 Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Read power measurements from IPMI DCMI where available. + There is also IPMI SDR entity 21 that returns the same information (power consumption in watts), + but isn't always available, and seems to be slower to read, especially when missing. + *) + +open Rrdd_plugin + +module Process = Process (struct let name = "xcp-rrdd-dcmi" end) + +open Process + +let ipmitool_bin = "/usr/bin/ipmitool" + +let ipmitool args = + (* we connect to the local /dev/ipmi0 if available to read measurements from local BMC *) + ipmitool_bin :: "-I" :: "open" :: args |> String.concat " " + +let discover () = + Utils.exec_cmd + (module Process.D) + ~cmdstring:(ipmitool ["dcmi"; "discover"]) + ~f:(fun line -> + (* this code runs once on startup, logging all the output here will be useful for debugging *) + D.debug "DCMI discover: %s" line ; + if String.trim line = "Power management available" then + Some () + else + None + ) + +let get_dcmi_power_reading () = + Utils.exec_cmd + (module Process.D) + ~cmdstring:(ipmitool ["dcmi"; "power"; "reading"]) + ~f:(fun line -> + (* example line: ' Instantaneous power reading: 34 Watts' *) + try + Scanf.sscanf line " Instantaneous power reading : %f Watts" Option.some + with Scanf.Scan_failure _ | End_of_file -> None + ) + +let gen_dcmi_power_reading value = + ( Rrd.Host + , Ds.ds_make ~name:"DCMI-power-reading" + ~description:"Host power usage reported by IPMI DCMI" + ~value:(Rrd.VT_Float value) ~ty:Rrd.Gauge ~default:true ~units:"W" + ~min:Float.min_float ~max:65534. () + ) + +let generate_dss () = + match get_dcmi_power_reading () with + | watts :: _ -> + [gen_dcmi_power_reading watts] + | _ -> + [] + +let _ = + initialise () ; + match discover () with + | [] -> + D.info "IPMI DCMI power reading is unavailable" ; + exit 1 + | _ -> + D.info "IPMI DCMI power reading is available" ; + main_loop ~neg_shift:0.5 ~target:(Reporter.Local 1) + ~protocol:Rrd_interface.V2 ~dss_f:generate_dss diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.mli b/ocaml/xcp-rrdd/bin/rrdp-dcmi/rrdp_dcmi.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins b/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins index 6998ad20c12..ced7c537254 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins +++ b/ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins @@ -1 +1 @@ -PLUGINS="xcp-rrdd-iostat xcp-rrdd-squeezed xcp-rrdd-xenpm" +PLUGINS="xcp-rrdd-iostat xcp-rrdd-squeezed xcp-rrdd-xenpm xcp-rrdd-dcmi" diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index ec883f3deed..0eb6ef5ac1b 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 [args] - send commands to the xenops daemon\n" Sys.argv.(0) ; - Printf.fprintf stderr "%s add - add a VM from \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 - forget about a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s start [paused] - start a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s pause - pause a VM\n" Sys.argv.(0) ; - Printf.fprintf stderr "%s unpause - unpause a VM\n" Sys.argv.(0) ; - Printf.fprintf stderr "%s shutdown - shutdown a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s reboot - reboot a VM\n" Sys.argv.(0) ; - Printf.fprintf stderr "%s suspend - suspend a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s resume - resume a VM\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s migrate - migrate a VM to \n" Sys.argv.(0) ; - Printf.fprintf stderr - "%s vbd-list - query the states of a VM's block devices\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s console-list - query the states of a VM's consoles\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s pci-add - associate the PCI device \ - with \n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s pci-remove - disassociate the PCI device \ - with \n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s pci-list - query the states of a VM's PCI devices\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s cd-insert - insert a CD into a VBD\n" - Sys.argv.(0) ; - Printf.fprintf stderr "%s cd-eject - eject a CD from a VBD\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s export-metadata - export metadata associated with \n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s export-metadata-xm - export metadata associated with in xm \ - format\n" - Sys.argv.(0) ; - Printf.fprintf stderr - "%s delay