diff --git a/.github/workflows/ocaml-ci.yml b/.github/workflows/ocaml-ci.yml new file mode 100644 index 00000000..b08cc575 --- /dev/null +++ b/.github/workflows/ocaml-ci.yml @@ -0,0 +1,40 @@ +name: Build and test + +on: + push: + pull_request: + +jobs: + ocaml-test: + name: Ocaml tests + runs-on: ubuntu-20.04 + env: + package: "xapi-idl" + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - name: Pull configuration from xs-opam + run: | + curl --fail --silent https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env | cut -f2 -d " " > .env + - name: Load environment file + id: dotenv + uses: falti/dotenv-action@v0.2.4 + + - name: Use ocaml + uses: avsm/setup-ocaml@v1 + with: + ocaml-version: ${{ steps.dotenv.outputs.ocaml_version_full }} + opam-repository: ${{ steps.dotenv.outputs.repository }} + + - name: Install dependencies + run: | + opam pin add . --no-action + opam depext -u ${{ env.package }} + opam install ${{ env.package }} --deps-only --with-test -v + - name: Build + run: | + opam exec -- make all + - name: Run tests + run: opam exec -- make test diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 00000000..ea8e56a8 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,8 @@ +profile=ocamlformat +indicate-multiline-delimiters=closing-on-separate-line +if-then-else=fit-or-vertical +dock-collection-brackets=true +break-struct=natural +break-separators=before +break-infix=fit-or-vertical +break-infix-before-func=false diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 11fbae1d..00000000 --- a/.travis.yml +++ /dev/null @@ -1,12 +0,0 @@ -language: c -sudo: required -service: docker -install: - - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh - - wget https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env - - source xs-opam-ci.env -script: bash -ex .travis-docker.sh -env: - global: - - PACKAGE=xapi-idl - - PINS="xapi-idl:." diff --git a/Makefile b/Makefile index b92b3bd0..b59de680 100644 --- a/Makefile +++ b/Makefile @@ -34,6 +34,10 @@ doc: gh-pages: bash .docgen.sh +# requires ocamlformat +format: + dune build @fmt --auto-promote + reindent: git ls-files '*.ml' '*.mli' | xargs ocp-indent --syntax cstruct -i diff --git a/README.md b/README.md index c320914a..c33cf6e0 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,5 @@ # xapi-idl -[![Build Status](https://travis-ci.org/xapi-project/xcp-idl.svg?branch=master)](https://travis-ci.org/xapi-project/xcp-idl) [![Coverage Status](https://coveralls.io/repos/github/xapi-project/xcp-idl/badge.svg)](https://coveralls.io/github/xapi-project/xcp-idl) This repository contains diff --git a/cluster/cluster_cli.ml b/cluster/cluster_cli.ml index 2066de98..1dede1e3 100644 --- a/cluster/cluster_cli.ml +++ b/cluster/cluster_cli.ml @@ -2,21 +2,28 @@ open Cluster_interface -module Cmds = LocalAPI(Cmdlinergen.Gen ()) +module Cmds = LocalAPI (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the cluster API. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "cluster_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the cluster API. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "cluster_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli () = let rpc = Cluster_client.rpc_internal Cluster_client.json_url in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) let _ = cli () diff --git a/cluster/cluster_client.ml b/cluster/cluster_client.ml index 8d0f056f..1ff675c4 100644 --- a/cluster/cluster_client.ml +++ b/cluster/cluster_client.ml @@ -1,17 +1,18 @@ let json_url () = "file:" ^ Cluster_interface.json_path -let json_http_rpc = Xcp_client.http_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string +let json_http_rpc = + Xcp_client.http_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string -module IDL = Idl.Make(Idl.IdM) +module IDL = Idl.Make (Idl.IdM) let rpc_internal url call = - if !Xcp_client.use_switch - then Xcp_client.json_switch_rpc Cluster_interface.queue_name call - else json_http_rpc ~srcstr:"clusterd" ~dststr:"clusterd" url call + if !Xcp_client.use_switch then + Xcp_client.json_switch_rpc Cluster_interface.queue_name call + else + json_http_rpc ~srcstr:"clusterd" ~dststr:"clusterd" url call -let rpc url call = - rpc_internal url call |> Idl.IdM.return +let rpc url call = rpc_internal url call |> Idl.IdM.return (* There is also a Remote API between clustering daemons on different hosts. - * Call this a Local API because it is an API inside a host *) -module LocalClient = Cluster_interface.LocalAPI(IDL.GenClient ()) + Call this a Local API because it is an API inside a host *) +module LocalClient = Cluster_interface.LocalAPI (IDL.GenClient ()) diff --git a/cluster/cluster_interface.ml b/cluster/cluster_interface.ml index 383176d9..194bc67e 100644 --- a/cluster/cluster_interface.ml +++ b/cluster/cluster_interface.ml @@ -3,209 +3,262 @@ open Idl let service_name = "cluster" + let queue_name = Xcp_service.common_prefix ^ service_name + let json_path = "/var/xapi/cluster.json" (** An uninterpreted string associated with the operation. *) -type debug_info = string -[@@deriving rpcty] +type debug_info = string [@@deriving rpcty] (** Name of the cluster *) -type cluster_name = string -[@@deriving rpcty] +type cluster_name = string [@@deriving rpcty] (** An IPv4 address (a.b.c.d) *) -type address = IPv4 of string -[@@deriving rpcty] -let printaddr () = function | IPv4 s -> Printf.sprintf "IPv4(%s)" s +type address = IPv4 of string [@@deriving rpcty] + +let printaddr () = function IPv4 s -> Printf.sprintf "IPv4(%s)" s + let str_of_address address = match address with IPv4 a -> a type addresslist = address list [@@deriving rpcty] type nodeid = int32 [@@deriving rpcty] + type start = bool [@@deriving rpcty] let string_of_nodeid = Int32.to_string -(** This type describes an individual node in the cluster. It must have - a unique identity (an int32), and may have multiple IPv4 addresses on - which it can be contacted. *) -type node = { - addr: address; - id: nodeid; -} -[@@deriving rpcty] +(** This type describes an individual node in the cluster. It must have a unique + identity (an int32), and may have multiple IPv4 addresses on which it can be + contacted. *) +type node = {addr: address; id: nodeid} [@@deriving rpcty] type all_members = node list [@@deriving rpcty] -(** This type contains all of the information required to initialise - the cluster. All optional params will have the recommended defaults - if None. *) +type pems = {cn: string; blobs: string list} [@@deriving rpcty] + +type pems_opt = pems option [@@deriving rpcty] + +(** This type contains all of the information required to initialise the + cluster. All optional params will have the recommended defaults if None. *) type init_config = { - local_ip : address; - token_timeout_ms : int64 option; - token_coefficient_ms : int64 option; - name : string option; + local_ip: address + ; token_timeout_ms: int64 option + ; token_coefficient_ms: int64 option + ; name: string option + ; pems: pems option } [@@deriving rpcty] -(** This type contains all of the information required to configure - the cluster. This includes all details required for the corosync - configuration as well as anything else required for pacemaker and - SBD. All nodes have a local copy of this and we take pains to - ensure it is kept in sync. *) +(** This type contains all of the information required to configure the cluster. + This includes all details required for the corosync configuration as well as + anything else required for pacemaker and SBD. All nodes have a local copy of + this and we take pains to ensure it is kept in sync. *) type cluster_config = { - cluster_name : string; - enabled_members : node list; - authkey: string; - config_version: int64; - cluster_token_timeout_ms : int64; - cluster_token_coefficient_ms : int64; + cluster_name: string + ; enabled_members: node list + ; authkey: string + ; config_version: int64 + ; cluster_token_timeout_ms: int64 + ; cluster_token_coefficient_ms: int64 + ; pems: pems option } [@@deriving rpcty] -type cluster_config_and_all_members = cluster_config * all_members [@@deriving rpcty] +let encode_cluster_config x = + Rpcmarshal.marshal cluster_config.Rpc.Types.ty x |> Jsonrpc.to_string -(** This type contains diagnostic information about the current state - of the cluster daemon. All state required for test purposes should - be in this type. *) +let decode_cluster_config x = + Jsonrpc.of_string x |> Rpcmarshal.unmarshal cluster_config.Rpc.Types.ty + +type cluster_config_and_all_members = cluster_config * all_members +[@@deriving rpcty] + +(** This type contains diagnostic information about the current state of the + cluster daemon. All state required for test purposes should be in this type. *) type diagnostics = { - config_valid : bool; - live_cluster_config : cluster_config option; (* live corosync config *) - next_cluster_config : cluster_config option; (* next corosync config *) - saved_cluster_config : cluster_config option; (* xapi-clusterd DB *) - is_enabled : bool; - all_members : all_members option; - node_id : nodeid option; - token : string option; - num_times_booted : int; - is_quorate : bool; - is_running : bool; - startup_finished : bool; + config_valid: bool + ; live_cluster_config: cluster_config option (** live corosync config *) + ; next_cluster_config: cluster_config option (** next corosync config *) + ; saved_cluster_config: cluster_config option (** xapi-clusterd DB *) + ; is_enabled: bool + ; all_members: all_members option + ; node_id: nodeid option + ; token: string option + ; num_times_booted: int + ; is_quorate: bool + ; is_running: bool + ; startup_finished: bool } [@@deriving rpcty] (** This secret token is used to authenticate remote API calls on a cluster *) -type token = string -[@@deriving rpcty] +type token = string [@@deriving rpcty] let token_p = Param.mk ~name:"token" token -type error = - | InternalError of string - | Unix_error of string -[@@deriving rpcty] +type error = InternalError of string | Unix_error of string [@@deriving rpcty] -module E = Error.Make(struct +module E = Error.Make (struct type t = error [@@deriving rpcty] + let internal_error_of _ = None - end) +end) + let err = E.error type named_unit = unit [@@deriving rpcty] + type my_string = string [@@deriving rpcty] +let unit_p = Param.mk ~name:"unit" ~description:["unit"] named_unit + +let string_p = Param.mk ~name:"string" ~description:["string"] my_string -let unit_p = Param.mk ~name:"unit" ~description:["unit"] named_unit -let string_p = Param.mk ~name:"string" ~description:["string"] my_string -let address_p = Param.mk ~name:"address" ~description:[ - "IPv4 address of a cluster member"; - ] address -let init_config_p = Param.mk ~name:"init_config" ~description:[ - "The initial config of the cluster member"; - ] init_config +let address_p = + Param.mk ~name:"address" + ~description:["IPv4 address of a cluster member"] + address -let debug_info_p = Param.mk ~name:"dbg" ~description:[ - "An uninterpreted string to associate with the operation." - ] debug_info +let init_config_p = + Param.mk ~name:"init_config" + ~description:["The initial config of the cluster member"] + init_config + +let debug_info_p = + Param.mk ~name:"dbg" + ~description:["An uninterpreted string to associate with the operation."] + debug_info + +let pems_opt_p = + Param.mk ~name:"pems" + ~description:["keys and certs cluster node should use"] + pems_opt type remove = bool [@@deriving rpcty] -module LocalAPI(R:RPC) = struct +module LocalAPI (R : RPC) = struct open R - let description = Interface.{ - name = "Local"; - namespace = None; - description = [ - "Local Cluster APIs. These are intended to be used to control the xapi-clusterd service"; - "There is no authentication on these, but they are only available on the local machine."; - ]; - version = (1,0,0); - } + let description = + Interface. + { + name= "Local" + ; namespace= None + ; description= + [ + "Local Cluster APIs. These are intended to be used to control the \ + xapi-clusterd service" + ; "There is no authentication on these, but they are only available \ + on the local machine." + ] + ; version= (1, 0, 0) + } let implementation = implement description - let create = declare - "create" - ["Creates the cluster. The call takes the initial config of"; - "the initial host to add to the cluster. This will be the"; - "address on which the rings will be created."] + let create = + declare "create" + [ + "Creates the cluster. The call takes the initial config of" + ; "the initial host to add to the cluster. This will be the" + ; "address on which the rings will be created." + ] (debug_info_p @-> init_config_p @-> returning token_p err) - let destroy = declare - "destroy" + let destroy = + declare "destroy" ["Destroys a created cluster"] (debug_info_p @-> returning unit_p err) - let leave = declare - "leave" - ["Causes this host to permanently leave the cluster, but leaves the rest of the cluster"; - "enabled. This is not a temporary removal - if the admin wants the hosts to rejoin the cluster again,"; - "he will have to call `join` rather than `enable`."] + let leave = + declare "leave" + [ + "Causes this host to permanently leave the cluster, but leaves the \ + rest of the cluster" + ; "enabled. This is not a temporary removal - if the admin wants the \ + hosts to rejoin the cluster again," + ; "he will have to call `join` rather than `enable`." + ] (debug_info_p @-> returning unit_p err) - let disable = declare - "disable" - ["Stop the cluster on this host; leave the rest of the cluster"; - "enabled. The cluster can be reenabled either by restarting the"; - "host, or by calling the `enable` API call."] + let disable = + declare "disable" + [ + "Stop the cluster on this host; leave the rest of the cluster" + ; "enabled. The cluster can be reenabled either by restarting the" + ; "host, or by calling the `enable` API call." + ] (debug_info_p @-> returning unit_p err) let enable = - declare - "enable" - ["Rejoins the cluster following a call to `disable`. The parameter"; - "passed is the cluster config to use (optional fields set to None"; - "unless updated) in case it changed while the host was disabled."; - "(Note that changing optional fields isn't yet supported, TODO)"] + declare "enable" + [ + "Rejoins the cluster following a call to `disable`. The parameter" + ; "passed is the cluster config to use (optional fields set to None" + ; "unless updated) in case it changed while the host was disabled." + ; "(Note that changing optional fields isn't yet supported, TODO)" + ] (debug_info_p @-> init_config_p @-> returning unit_p err) let join = let new_p = Param.mk ~name:"new_member" address in let existing_p = Param.mk ~name:"existing_members" addresslist in - declare - "join" - ["Adds a node to an initialised cluster. Takes the IPv4 address of"; - "the new member and a list of the addresses of all the existing"; - "members."] - (debug_info_p @-> token_p @-> new_p @-> existing_p @-> returning unit_p err) + declare "join" + [ + "Adds a node to an initialised cluster. Takes the IPv4 address of" + ; "the new member and a list of the addresses of all the existing" + ; "members." + ] + (debug_info_p + @-> token_p + @-> new_p + @-> existing_p + @-> pems_opt_p + @-> returning unit_p err + ) let declare_changed_addrs = let changed_members_p = Param.mk ~name:"changed_members" addresslist in - declare - "declare-changed-addrs" - ["Declare that one or more hosts in the cluster have changed address."; - "Only use this command if unable to rejoin the cluster using `enable`"; - "because the IPv4 addresses of all nodes this node previously saw are now"; - "invalid. If any one of these addresses remains valid on an enabled node"; - "then this action is unnecessary."] + declare "declare-changed-addrs" + [ + "Declare that one or more hosts in the cluster have changed address." + ; "Only use this command if unable to rejoin the cluster using `enable`" + ; "because the IPv4 addresses of all nodes this node previously saw are \ + now" + ; "invalid. If any one of these addresses remains valid on an enabled \ + node" + ; "then this action is unnecessary." + ] (debug_info_p @-> changed_members_p @-> returning unit_p err) let declare_dead = let dead_members_p = Param.mk ~name:"dead_members" addresslist in - declare - "declare-dead" - ["Declare that some hosts in the cluster are permanently dead. Removes"; - "the hosts from the cluster. If the hosts do attempt to rejoin the"; - "cluster in future, this may lead to fencing of other hosts and/or"; - "data loss or data corruption."] + declare "declare-dead" + [ + "Declare that some hosts in the cluster are permanently dead. Removes" + ; "the hosts from the cluster. If the hosts do attempt to rejoin the" + ; "cluster in future, this may lead to fencing of other hosts and/or" + ; "data loss or data corruption." + ] (debug_info_p @-> dead_members_p @-> returning unit_p err) let diagnostics = let diagnostics_p = Param.mk ~name:"diagnostics" diagnostics in - declare - "diagnostics" + declare "diagnostics" ["Returns diagnostic information about the cluster"] (debug_info_p @-> returning diagnostics_p err) + + let get_config = + let cluster_config_p = Param.mk ~name:"cluster_config" cluster_config in + declare "get-config" + ["Returns local cluster config"] + (debug_info_p @-> returning cluster_config_p err) + + let write_pems = + let pems_p = Param.mk ~name:"pems" pems in + declare "write-pems" + ["Distribute pems to existing cluster"] + (debug_info_p @-> pems_p @-> returning unit_p err) end diff --git a/cluster/dune b/cluster/dune index 42bb0132..ac4d09be 100644 --- a/cluster/dune +++ b/cluster/dune @@ -1,36 +1,27 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (library - (name xcp_cluster) - (public_name xapi-idl.cluster) - (modules (:standard \ cluster_cli)) - (flags (:standard -w -39)) - (libraries xapi-idl threads rpclib.core) - (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) -) + (name xcp_cluster) + (public_name xapi-idl.cluster) + (modules (:standard \ cluster_cli)) + (flags (:standard -w -39)) + (libraries + xapi-idl + threads + rpclib.core + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name cluster_cli) - (modules cluster_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.cluster - ) -) + (name cluster_cli) + (modules cluster_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.cluster)) -(alias - (name runtest) - (deps (:x cluster_cli.exe)) - (action (run %%{x})) -) -|} coverage_rewriter +(rule + (alias runtest) + (deps (:x cluster_cli.exe)) + (action (run %{x}))) diff --git a/dune-project b/dune-project index 42bd9c40..50497862 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,5 @@ -(lang dune 1.9) +(lang dune 2.0) + (allow_approximate_merlin) + +(formatting (enabled_for ocaml)) diff --git a/example/dune b/example/dune index c40c5cdc..edd4cb64 100644 --- a/example/dune +++ b/example/dune @@ -1,25 +1,13 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - (executable - (name example) - (flags (:standard -w -39)) - (libraries - rpclib.core - xapi-idl - ) - (preprocess (pps ppx_deriving_rpc %s)) -) + (name example) + (flags (:standard -w -39)) + (libraries + rpclib.core + xapi-idl + ) + (preprocess (pps ppx_deriving_rpc))) -(alias - (name runtest) - (deps (:x example.exe)) - (action (run %%{x})) -) -|} coverage_rewriter +(rule + (alias runtest) + (deps (:x example.exe)) + (action (run %{x}))) diff --git a/example/example.ml b/example/example.ml index 4619ec25..1e496c19 100644 --- a/example/example.ml +++ b/example/example.ml @@ -15,54 +15,72 @@ open Xcp_service let ls = ref "/bin/ls" + let sh = ref "/bin/sh" -let resources = [ - { Xcp_service.name = "ls"; - description = "program used to list things"; - essential = true; - path = ls; - perms = [ Unix.X_OK ]; - }; { - Xcp_service.name = "sh"; - description = "interpreter for arcane programming language"; - essential = false; - path = sh; - perms = [ Unix.X_OK ]; - } -] +let resources = + [ + { + Xcp_service.name= "ls" + ; description= "program used to list things" + ; essential= true + ; path= ls + ; perms= [Unix.X_OK] + } + ; { + Xcp_service.name= "sh" + ; description= "interpreter for arcane programming language" + ; essential= false + ; path= sh + ; perms= [Unix.X_OK] + } + ] let socket_path = ref "/var/xapi/socket" let comma = Re.Str.regexp_string "," + let csv = Re.Str.split_delim comma -let queues : string list ref = ref [ - "org.xen.xapi.ffs"; -] +let queues : string list ref = ref ["org.xen.xapi.ffs"] let set_default_format _ = () + let get_default_format () = "vhd" let mount_path = ref "/mnt" -let options = [ - "socket-path", Arg.Set_string socket_path, (fun () -> !socket_path), "Path of listening socket"; - "queue-name", Arg.String (fun x -> queues := csv x), (fun () -> String.concat "," !queues), "Comma-separated list of queue names to listen on"; - "default-format", Arg.String set_default_format, get_default_format, "Default format for disk files"; - "sr-mount-path", Arg.Set_string mount_path, (fun () -> !mount_path), "Default mountpoint for mounting remote filesystems"; -] +let options = + [ + ( "socket-path" + , Arg.Set_string socket_path + , (fun () -> !socket_path) + , "Path of listening socket" ) + ; ( "queue-name" + , Arg.String (fun x -> queues := csv x) + , (fun () -> String.concat "," !queues) + , "Comma-separated list of queue names to listen on" ) + ; ( "default-format" + , Arg.String set_default_format + , get_default_format + , "Default format for disk files" ) + ; ( "sr-mount-path" + , Arg.Set_string mount_path + , (fun () -> !mount_path) + , "Default mountpoint for mounting remote filesystems" ) + ] let _ = - Debug.log_to_stdout (); - match configure2 - ~name:"Example-service" - ~version:"1.0" - ~doc:"This is an example service which demonstrates the configuration mechanism." - ~options - ~resources - () with - | `Ok () -> exit 0 + Debug.log_to_stdout () ; + match + configure2 ~name:"Example-service" ~version:"1.0" + ~doc: + "This is an example service which demonstrates the configuration \ + mechanism." + ~options ~resources () + with + | `Ok () -> + exit 0 | `Error m -> - Printf.fprintf stderr "Error: %s\n%!" m; - exit 1 + Printf.fprintf stderr "Error: %s\n%!" m ; + exit 1 diff --git a/gpumon/dune b/gpumon/dune index 26c5877b..5a7d2672 100644 --- a/gpumon/dune +++ b/gpumon/dune @@ -1,40 +1,26 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - (library - (name xapi_gpumon) - (public_name xapi-idl.gpumon) - (flags (:standard -w -39-33)) - (modules (:standard \ gpumon_cli )) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) -) + (name xapi_gpumon) + (public_name xapi-idl.gpumon) + (flags (:standard -w -39-33)) + (modules (:standard \ gpumon_cli)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name gpumon_cli) - (modules gpumon_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.gpumon - ) -) + (name gpumon_cli) + (modules gpumon_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.gpumon)) -(alias - (name runtest) - (deps (:x gpumon_cli.exe)) - (action (run %%{x})) -) -|} coverage_rewriter +(rule + (alias runtest) + (deps (:x gpumon_cli.exe)) + (action (run %{x}))) diff --git a/gpumon/gpumon_cli.ml b/gpumon/gpumon_cli.ml index 0bc3792f..5c5b06e1 100644 --- a/gpumon/gpumon_cli.ml +++ b/gpumon/gpumon_cli.ml @@ -1,26 +1,28 @@ - (* Gpumon CLI *) -module Cmds = Gpumon_interface.RPC_API(Cmdlinergen.Gen ()) +module Cmds = Gpumon_interface.RPC_API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the GPU monitoring API. This allows scripting of the gpumon daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "gpumon_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the GPU monitoring API. This allows scripting of the gpumon \ + daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "gpumon_cli" ~version:(version_str Cmds.description) ~doc + ) let cli () = let rpc = Gpumon_client.rpc in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) - -let _ = - match cli () with - | `Ok f -> f () - | _ -> () + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) +let _ = match cli () with `Ok f -> f () | _ -> () diff --git a/gpumon/gpumon_client.ml b/gpumon/gpumon_client.ml index 7fe18ae8..d6605ff7 100644 --- a/gpumon/gpumon_client.ml +++ b/gpumon/gpumon_client.ml @@ -15,11 +15,13 @@ let xml_url () = "file:" ^ Gpumon_interface.xml_path let rpc call = - if !Xcp_client.use_switch - then Xcp_client.json_switch_rpc Gpumon_interface.queue_name call - else Xcp_client.xml_http_rpc + if !Xcp_client.use_switch then + Xcp_client.json_switch_rpc Gpumon_interface.queue_name call + else + Xcp_client.xml_http_rpc ~srcstr:(Xcp_client.get_user_agent ()) - ~dststr:"gpumon" - xml_url - call -module Client = Gpumon_interface.RPC_API(Idl.Exn.GenClient(struct let rpc=rpc end)) + ~dststr:"gpumon" xml_url call + +module Client = Gpumon_interface.RPC_API (Idl.Exn.GenClient (struct + let rpc = rpc +end)) diff --git a/gpumon/gpumon_interface.ml b/gpumon/gpumon_interface.ml index 0b2f1a5a..aec410a2 100644 --- a/gpumon/gpumon_interface.ml +++ b/gpumon/gpumon_interface.ml @@ -15,192 +15,204 @@ open Rpc open Idl -module D = Debug.Make(struct let name = "gpumon_interface" end) +module D = Debug.Make (struct let name = "gpumon_interface" end) + open D let service_name = "gpumon" + let queue_name = Xcp_service.common_prefix ^ service_name + let xml_path = "/var/xapi/" ^ service_name (** Uninterpreted string associated with the operation *) -type debug_info = string -[@@deriving rpcty] +type debug_info = string [@@deriving rpcty] (* Domain ID of VM *) -type domid = int -[@@deriving rpcty] +type domid = int [@@deriving rpcty] (** UUID of Nvidia Virtual GPU *) -type vgpu_uuid = string -[@@deriving rpcty] +type vgpu_uuid = string [@@deriving rpcty] (** Reason for incompatibility *) -type incompatibility_reason = - | Host_driver - | Guest_driver - | GPU - | Other +type incompatibility_reason = Host_driver | Guest_driver | GPU | Other [@@deriving rpcty] (** Compatibility between virtual and physical GPU *) -type compatibility = - | Compatible - | Incompatible of incompatibility_reason list +type compatibility = Compatible | Incompatible of incompatibility_reason list [@@deriving rpcty] (** PCI identifier of physical GPU *) -type pgpu_address = string -[@@deriving rpcty] +type pgpu_address = string [@@deriving rpcty] (** Metadata of Nvidia physical GPU *) -type nvidia_pgpu_metadata = string -[@@deriving rpcty] +type nvidia_pgpu_metadata = string [@@deriving rpcty] (** Metadata of Nvidia virtual GPU *) -type nvidia_vgpu_metadata = string -[@@deriving rpcty] +type nvidia_vgpu_metadata = string [@@deriving rpcty] (** List of Nvidia virtual GPU metadata records *) -type nvidia_vgpu_metadata_list = nvidia_vgpu_metadata list -[@@deriving rpcty] - +type nvidia_vgpu_metadata_list = nvidia_vgpu_metadata list [@@deriving rpcty] (** Error wrapper *) type gpu_errors = | NvmlInterfaceNotAvailable - (** Exception raised when gpumon is unable to load the nvml nvidia library *) + (** Exception raised when gpumon is unable to load the nvml nvidia library *) | NvmlFailure of string - (** Exception raised by the c bindings to the nvml nvidia library*) + (** Exception raised by the c bindings to the nvml nvidia library*) | Internal_error of string - (** Exception raised if an unexpected error is triggered by the library *) - | Gpumon_failure - (** Default exception raised upon daemon failure *) -[@@default Gpumon_failure] -[@@deriving rpcty] + (** Exception raised if an unexpected error is triggered by the library *) + | Gpumon_failure (** Default exception raised upon daemon failure *) +[@@default Gpumon_failure] [@@deriving rpcty] exception Gpumon_error of gpu_errors -let () = (* register printer *) +let () = + (* register printer *) let sprintf = Printf.sprintf in let string_of_error e = - Rpcmarshal.marshal gpu_errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal gpu_errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | Gpumon_error e -> Some (sprintf "Gpumon_interface.Gpumon_error(%s)" (string_of_error e)) - | _ -> None in + | _ -> + None + in Printexc.register_printer printer (** Error handler *) -let gpu_err = Error. - { def = gpu_errors - ; raiser = (fun e -> - log_backtrace (); - let exn = Gpumon_error e in - error "%s (%s)" (Printexc.to_string exn) __LOC__; - raise exn) - ; matcher = (function - | Gpumon_error e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; +let gpu_err = + Error. + { + def= gpu_errors + ; raiser= + (fun e -> + log_backtrace () ; + let exn = Gpumon_error e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) + ; matcher= + (function + | Gpumon_error e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some (Internal_error (Printexc.to_string exn))) } (** Functor to autogenerate API calls *) -module RPC_API(R : RPC) = struct +module RPC_API (R : RPC) = struct open R let param = Param.mk let description = - Interface.{ name = "Gpumon" - ; namespace = None - ; description = - [ "This interface is used by Xapi and Gpumon to monitor " - ; "physical and virtual GPUs."] - ; version=(1,0,0) - } + Interface. + { + name= "Gpumon" + ; namespace= None + ; description= + [ + "This interface is used by Xapi and Gpumon to monitor " + ; "physical and virtual GPUs." + ] + ; version= (1, 0, 0) + } let implementation = implement description (** Compatibility checking interface for Nvidia vGPUs *) module Nvidia = struct - (** common API call parameters *) - let debug_info_p = param ~description: - ["Uninterpreted string used for debugging."] - debug_info + let debug_info_p = + param ~description:["Uninterpreted string used for debugging."] debug_info - let domid_p = param ~description: - ["Domain ID of the VM in which the vGPU(s) is running."] + let domid_p = + param + ~description:["Domain ID of the VM in which the vGPU(s) is running."] domid - let vgpu_uuid_p = param ~description: - ["UUID of Nvidia virtual GPU."] - vgpu_uuid + let vgpu_uuid_p = + param ~description:["UUID of Nvidia virtual GPU."] vgpu_uuid - let pgpu_address_p = param ~description: - ["PCI bus ID of the pGPU in which the VM is currently running" - ;"in the form `domain:bus:device.function` PCI identifier."] + let pgpu_address_p = + param + ~description: + [ + "PCI bus ID of the pGPU in which the VM is currently running" + ; "in the form `domain:bus:device.function` PCI identifier." + ] pgpu_address - let nvidia_pgpu_metadata_p = param ~description: - ["Metadata of Nvidia physical GPU."] + let nvidia_pgpu_metadata_p = + param + ~description:["Metadata of Nvidia physical GPU."] nvidia_pgpu_metadata - let nvidia_vgpu_metadata_p = param ~description: - ["Metadata of Nvidia virtual GPU."] + let nvidia_vgpu_metadata_p = + param + ~description:["Metadata of Nvidia virtual GPU."] nvidia_vgpu_metadata - let nvidia_vgpu_metadata_list_p = param ~description: - ["Metadata list of Nvidia virtual GPU."] + let nvidia_vgpu_metadata_list_p = + param + ~description:["Metadata list of Nvidia virtual GPU."] nvidia_vgpu_metadata_list - let compatibility_p = param ~description: - [ "Value indicating whether two or more GPUs are compatible with each other." ] + let compatibility_p = + param + ~description: + [ + "Value indicating whether two or more GPUs are compatible with \ + each other." + ] compatibility let get_pgpu_metadata = declare "get_pgpu_metadata" - [ "Gets the metadata for a pGPU, given its address (PCI bus ID)." ] + ["Gets the metadata for a pGPU, given its address (PCI bus ID)."] (debug_info_p - @-> pgpu_address_p - @-> returning nvidia_pgpu_metadata_p gpu_err + @-> pgpu_address_p + @-> returning nvidia_pgpu_metadata_p gpu_err ) let get_pgpu_vm_compatibility = declare "get_pgpu_vm_compatibility" - [ "Checks compatibility between a VM's vGPU(s) and another pGPU." ] + ["Checks compatibility between a VM's vGPU(s) and another pGPU."] (debug_info_p - @-> pgpu_address_p - @-> domid_p - @-> nvidia_pgpu_metadata_p - @-> returning compatibility_p gpu_err + @-> pgpu_address_p + @-> domid_p + @-> nvidia_pgpu_metadata_p + @-> returning compatibility_p gpu_err ) let get_vgpu_metadata = declare "get_vgpu_metadata" - [ "Obtains metadata for all vGPUs running in a domain." ] - ( debug_info_p - @-> domid_p - @-> pgpu_address_p - @-> vgpu_uuid_p - @-> returning nvidia_vgpu_metadata_list_p gpu_err + ["Obtains metadata for all vGPUs running in a domain."] + (debug_info_p + @-> domid_p + @-> pgpu_address_p + @-> vgpu_uuid_p + @-> returning nvidia_vgpu_metadata_list_p gpu_err ) let get_pgpu_vgpu_compatibility = declare "get_pgpu_vgpu_compatibility" - [ "Checks compatibility between a pGPU (on a host) and a list of vGPUs " + [ + "Checks compatibility between a pGPU (on a host) and a list of vGPUs " ; "(assigned to a VM). Note: A VM may use several vGPUs." ; "The use case is VM.suspend/VM.resume:" ; "before VM.resume [nvidia_vgpu_metadata] of the suspended VM is " ; "checked against the [nvidia_pgpu_metadata] on the host where the VM " - ; "is resumed." ] - ( debug_info_p - @-> nvidia_pgpu_metadata_p - @-> nvidia_vgpu_metadata_list_p - @-> returning compatibility_p gpu_err) + ; "is resumed." + ] + (debug_info_p + @-> nvidia_pgpu_metadata_p + @-> nvidia_vgpu_metadata_list_p + @-> returning compatibility_p gpu_err + ) end end diff --git a/lib/cohttp_posix_io.ml b/lib/cohttp_posix_io.ml index 16e140ec..a24e5155 100644 --- a/lib/cohttp_posix_io.ml +++ b/lib/cohttp_posix_io.ml @@ -17,23 +17,25 @@ module Unbuffered_IO = struct (** Use as few Unix.\{read,write\} calls as we can (for efficiency) without - explicitly buffering the stream beyond the HTTP headers. This will - allow us to consume the headers and then pass the file descriptor - safely to another process *) + explicitly buffering the stream beyond the HTTP headers. This will allow + us to consume the headers and then pass the file descriptor safely to + another process *) type 'a t = 'a - let (>>=) x f = f x - let (>>) m n = m >>= fun _ -> n + let ( >>= ) x f = f x + + let ( >> ) m n = m >>= fun _ -> n let return x = x let iter = List.iter type ic = { - mutable header_buffer: string option; (** buffered headers *) - mutable header_buffer_idx: int; (** next char within the buffered headers *) - fd: Unix.file_descr; (** the underlying file descriptor *) + mutable header_buffer: string option (** buffered headers *) + ; mutable header_buffer_idx: int + (** next char within the buffered headers *) + ; fd: Unix.file_descr (** the underlying file descriptor *) } type oc = Unix.file_descr @@ -46,79 +48,77 @@ module Unbuffered_IO = struct let end_of_headers = "\r\n\r\n" in let tmp = Bytes.make (String.length end_of_headers) '\000' in let module Scanner = struct - type t = { - marker: string; - mutable i: int; - } - let make x = { marker = x; i = 0 } - let input x c = - if c = String.get x.marker x.i then x.i <- x.i + 1 else x.i <- 0 + type t = {marker: string; mutable i: int} + + let make x = {marker= x; i= 0} + + let input x c = if c = x.marker.[x.i] then x.i <- x.i + 1 else x.i <- 0 + let remaining x = String.length x.marker - x.i + let matched x = x.i = String.length x.marker end in let marker = Scanner.make end_of_headers in - - while not(Scanner.matched marker) do - (* We may be part way through reading the end of header marker, so - be pessimistic and only read enough bytes to read until the end of - the marker. *) + while not (Scanner.matched marker) do + (* We may be part way through reading the end of header marker, so be + pessimistic and only read enough bytes to read until the end of the + marker. *) let safe_to_read = Scanner.remaining marker in - let n = Unix.read fd tmp 0 safe_to_read in - if n = 0 then raise End_of_file; - + if n = 0 then raise End_of_file ; for j = 0 to n - 1 do - Scanner.input marker (Bytes.get tmp j); + Scanner.input marker (Bytes.get tmp j) ; Buffer.add_char buf (Bytes.get tmp j) - done; - done; + done + done ; Buffer.contents buf - (* Raises Not_found if there's no crlf *) let rec find_crlf str from = let cr = String.index_from str from '\r' in let lf = String.index_from str cr '\n' in - if lf=cr+1 then cr else find_crlf str cr + if lf = cr + 1 then cr else find_crlf str cr (* We assume read_line is only used to read the HTTP header *) - let rec read_line ic = match ic.header_buffer, ic.header_buffer_idx with - | None, _ -> - ic.header_buffer <- Some (read_http_headers ic.fd); - read_line ic - | Some buf, i when i < (String.length buf) -> - begin + let rec read_line ic = + match (ic.header_buffer, ic.header_buffer_idx) with + | None, _ -> + ic.header_buffer <- Some (read_http_headers ic.fd) ; + read_line ic + | Some buf, i when i < String.length buf -> ( try let eol = find_crlf buf i in let line = String.sub buf i (eol - i) in - ic.header_buffer_idx <- eol + 2; + ic.header_buffer_idx <- eol + 2 ; Some line with Not_found -> Some "" - end - | Some _, _ -> - Some "" + ) + | Some _, _ -> + Some "" let rec read_into_exactly ic buf ofs len = let n = Unix.read ic.fd buf ofs len in let remaining = len - n in - remaining = 0 || (n > 0 && (read_into_exactly ic buf (ofs + n) (len - n))) + remaining = 0 || (n > 0 && read_into_exactly ic buf (ofs + n) (len - n)) let read_exactly ic len = let buf = Bytes.create len in read_into_exactly ic buf 0 len >>= function - | true -> return (Some buf) - | false -> return None + | true -> + return (Some buf) + | false -> + return None let read ic n = let buf = Bytes.make n '\000' in let actually_read = Unix.read ic.fd buf 0 n in - if actually_read = n - then Bytes.unsafe_to_string buf - else Bytes.sub_string buf 0 actually_read + if actually_read = n then + Bytes.unsafe_to_string buf + else + Bytes.sub_string buf 0 actually_read let write oc x = - Unix.write oc (Bytes.unsafe_of_string x) 0 (String.length x) - |> ignore + Unix.write oc (Bytes.unsafe_of_string x) 0 (String.length x) |> ignore let flush _oc = () end @@ -126,41 +126,56 @@ end module Buffered_IO = struct type 'a t = 'a - let (>>=) x f = f x - let (>>) m n = m >>= fun _ -> n + let ( >>= ) x f = f x + + let ( >> ) m n = m >>= fun _ -> n let return x = x let iter = List.iter type ic = in_channel + type oc = out_channel + type conn = unit let read_line ic = try - Some (match input_line ic with - | "" -> "" - | x when x.[String.length x - 1] = '\r' -> String.sub x 0 (String.length x - 1) - | x -> x) + Some + ( match input_line ic with + | "" -> + "" + | x when x.[String.length x - 1] = '\r' -> + String.sub x 0 (String.length x - 1) + | x -> + x + ) with End_of_file -> None - let read_into_exactly ic buf ofs len = try really_input ic buf ofs len; true with _ -> false + let read_into_exactly ic buf ofs len = + try + really_input ic buf ofs len ; + true + with _ -> false let read_exactly ic len = let buf = Bytes.create len in read_into_exactly ic buf 0 len >>= function - | true -> return (Some buf) - | false -> return None + | true -> + return (Some buf) + | false -> + return None let read ic n = let buf = Bytes.make n '\000' in let actually_read = input ic buf 0 n in - if actually_read = n - then Bytes.unsafe_to_string buf - else Bytes.sub_string buf 0 actually_read + if actually_read = n then + Bytes.unsafe_to_string buf + else + Bytes.sub_string buf 0 actually_read - let write oc x = output_string oc x; flush oc + let write oc x = output_string oc x ; flush oc let flush oc = flush oc end diff --git a/lib/coverage/disabled.ml b/lib/coverage/disabled.ml index 65404608..ca9ae41a 100644 --- a/lib/coverage/disabled.ml +++ b/lib/coverage/disabled.ml @@ -1,2 +1,3 @@ let init _ = () + let dispatcher_init _ = () diff --git a/lib/coverage/enabled.ml b/lib/coverage/enabled.ml index fff55d7d..4d36e40d 100644 --- a/lib/coverage/enabled.ml +++ b/lib/coverage/enabled.ml @@ -1,117 +1,133 @@ -(** This module sets up the env variable for bisect_ppx which describes - * where log files are written. - *) +(** This module sets up the env variable for bisect_ppx which describes where + log files are written. *) + +module D = Debug.Make (struct let name = "coverage" end) -module D=Debug.Make(struct let name="coverage" end) let prefix = "org.xen.xapi.coverage" module Bisect = struct let bisect_file = "BISECT_FILE" + let dump jobid = let bisect_prefix = Unix.getenv bisect_file in - (* dump coverage information in same location as it would normally - get dumped on exit, except also embed the jobid to make it easier to group. - Relies on [open_temp_file] generating a unique filename given a prefix/suffix to - avoid clashes with filenames created at exit by bisect itself. *) - let tmp, ch = Filename.open_temp_file - ~temp_dir:(Filename.dirname bisect_prefix) - (Filename.basename bisect_prefix) - (Printf.sprintf ".%Ld.out" jobid) in + (* dump coverage information in same location as it would normally get + dumped on exit, except also embed the jobid to make it easier to group. + Relies on [open_temp_file] generating a unique filename given a + prefix/suffix to avoid clashes with filenames created at exit by bisect + itself. *) + let tmp, ch = + Filename.open_temp_file + ~temp_dir:(Filename.dirname bisect_prefix) + (Filename.basename bisect_prefix) + (Printf.sprintf ".%Ld.out" jobid) + in try - Bisect.Runtime.dump_counters_exn ch; - D.debug "Saved coverage data to %s" tmp; - close_out_noerr ch; + Bisect.Runtime.dump_counters_exn ch ; + D.debug "Saved coverage data to %s" tmp ; + close_out_noerr ch ; (* Keep file - will be collected by XenRT *) tmp with e -> - Sys.remove tmp; - D.warn "Failed to save coverage: %s" (Printexc.to_string e); + Sys.remove tmp ; + D.warn "Failed to save coverage: %s" (Printexc.to_string e) ; raise e let reset () = - Bisect.Runtime.reset_counters (); + Bisect.Runtime.reset_counters () ; D.debug "Coverage counters reset" let init_env name = - let (//) = Filename.concat in - let tmpdir = Filename.get_temp_dir_name () in - try - ignore (Sys.getenv bisect_file) + let ( // ) = Filename.concat in + let tmpdir = Filename.get_temp_dir_name () in + try ignore (Sys.getenv bisect_file) with Not_found -> Unix.putenv bisect_file (tmpdir // Printf.sprintf "bisect-%s-" name) let process body = match Stringext.split ~on:' ' body with - | ["reset"] -> reset (); "" - | ["dump"; jobid] -> jobid |> Int64.of_string |> dump - | _ -> failwith body + | ["reset"] -> + reset () ; "" + | ["dump"; jobid] -> + jobid |> Int64.of_string |> dump + | _ -> + failwith body let init name = - init_env name; + init_env name ; let queue_name = prefix ^ "." ^ name in - let (_:Thread.t) = - Thread.create (Message_switch_unix.Protocol_unix.Server.listen ~process - ~switch:!Xcp_client.switch_path ~queue:queue_name) () in - D.debug "Started coverage API thread on %s" queue_name; + let (_ : Thread.t) = + Thread.create + (Message_switch_unix.Protocol_unix.Server.listen ~process + ~switch:!Xcp_client.switch_path ~queue:queue_name) + () + in + D.debug "Started coverage API thread on %s" queue_name ; () end module Dispatcher = struct let self = prefix ^ ".dispatch" + open Message_switch_unix.Protocol_unix let rpc_ignore_err ~t ~body queue = - D.debug "Dispatching %s to %s" body queue; + D.debug "Dispatching %s to %s" body queue ; match Client.(rpc ~t ~queue ~body () |> error_to_msg) with - | `Ok x -> x + | `Ok x -> + x | `Error (`Msg e) -> - D.info "Failed to get coverage data from %s: %s" queue e; - "" + D.info "Failed to get coverage data from %s: %s" queue e ; + "" let string_of_result = function - | `Ok s -> s + | `Ok s -> + s | `Error (`Msg e) -> - D.info "Failed to get coverage data: %s" e; - "ERROR" + D.info "Failed to get coverage data: %s" e ; + "ERROR" - let process = fun body -> + let process body = let open Message_switch_core.Mresult in - D.debug "Coverage dispatcher received %s" body; - let result = begin - Client.connect ~switch:!Xcp_client.switch_path () >>= fun t -> - Client.list ~t ~prefix ~filter:`Alive () >>= fun queues -> - queues |> - (* filter out ourselves *) - List.filter (fun q -> self <> q) |> - - (* best-effort: collect and return all non-failed results, log errors *) - List.rev_map (rpc_ignore_err ~t ~body) |> - - (* multiple return values converted to a single string, suitable for use in a command like: - mv $(message-cli call org.xen.xapi.coverage.dispatch --timeout 60 --body 'dump {jobid}') /tmp/coverage/ - *) - String.concat " " |> - ok - end |> Client.error_to_msg |> string_of_result in - D.debug "Coverage dispatcher replying to '%s': %s" body result; + D.debug "Coverage dispatcher received %s" body ; + let result = + Client.connect ~switch:!Xcp_client.switch_path () + >>= (fun t -> + Client.list ~t ~prefix ~filter:`Alive () >>= fun queues -> + queues + |> (* filter out ourselves *) + List.filter (fun q -> self <> q) + |> (* best-effort: collect and return all non-failed results, log + errors *) + List.rev_map (rpc_ignore_err ~t ~body) + |> (* multiple return values converted to a single string, suitable + for use in a command like: mv $(message-cli call + org.xen.xapi.coverage.dispatch --timeout 60 --body 'dump + {jobid}') /tmp/coverage/ *) + String.concat " " + |> ok) + |> Client.error_to_msg + |> string_of_result + in + D.debug "Coverage dispatcher replying to '%s': %s" body result ; result let init () = (* receives command and dispatches to all other coverage message queues *) - let (_:Thread.t) = - Thread.create (Message_switch_unix.Protocol_unix.Server.listen ~process - ~switch:!Xcp_client.switch_path ~queue:self) () in - D.debug "Started coverage API dispatcher on %s" self; + let (_ : Thread.t) = + Thread.create + (Message_switch_unix.Protocol_unix.Server.listen ~process + ~switch:!Xcp_client.switch_path ~queue:self) + () + in + D.debug "Started coverage API dispatcher on %s" self ; () end -(** [init name] sets up coverage profiling for binary [name]. You could - * use [Sys.argv.(0)] for [name]. - *) +(** [init name] sets up coverage profiling for binary [name]. You could use + [Sys.argv.(0)] for [name]. *) let init name = - D.info "About to initialize coverage runtime"; - Bisect.init name; + D.info "About to initialize coverage runtime" ; + Bisect.init name ; D.info "Coverage runtime initialized" -let dispatcher_init _name = - Dispatcher.init () +let dispatcher_init _name = Dispatcher.init () diff --git a/lib/debug.ml b/lib/debug.ml index 6bcdf775..895d48a1 100644 --- a/lib/debug.ml +++ b/lib/debug.ml @@ -12,222 +12,263 @@ * GNU Lesser General Public License for more details. *) - module Mutex = struct include Mutex (** execute the function f with the mutex hold *) let execute lock f = - Mutex.lock lock; - let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in - Mutex.unlock lock; - r + Mutex.lock lock ; + let r = try f () with exn -> Mutex.unlock lock ; raise exn in + Mutex.unlock lock ; r end -let get_thread_id () = - try Thread.id (Thread.self ()) with _ -> -1 +let get_thread_id () = try Thread.id (Thread.self ()) with _ -> -1 -module IntMap = Map.Make(Int) +module IntMap = Map.Make (Int) module ThreadLocalTable = struct - type 'a t = { - mutable tbl: 'a IntMap.t; - m: Mutex.t; - } + type 'a t = {mutable tbl: 'a IntMap.t; m: Mutex.t} let make () = let tbl = IntMap.empty in let m = Mutex.create () in - { tbl; m } + {tbl; m} let add t v = let id = get_thread_id () in - Mutex.execute t.m (fun () -> - t.tbl <- IntMap.add id v t.tbl) + Mutex.execute t.m (fun () -> t.tbl <- IntMap.add id v t.tbl) let remove t = let id = get_thread_id () in - Mutex.execute t.m (fun () -> - t.tbl <- IntMap.remove id t.tbl) + Mutex.execute t.m (fun () -> t.tbl <- IntMap.remove id t.tbl) let find t = let id = get_thread_id () in IntMap.find_opt id t.tbl end -let names = ThreadLocalTable.make () +type task = {desc: string; client: string option} + +let tasks : task ThreadLocalTable.t = ThreadLocalTable.make () -let tasks = ThreadLocalTable.make () +let names : string ThreadLocalTable.t = ThreadLocalTable.make () let gettimestring () = let time = Unix.gettimeofday () in let tm = Unix.gmtime time in - let msec = time -. (floor time) in - Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" - (1900 + tm.Unix.tm_year) - (tm.Unix.tm_mon + 1) tm.Unix.tm_mday - tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + let msec = time -. floor time in + Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" (1900 + tm.Unix.tm_year) + (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min + tm.Unix.tm_sec (int_of_float (1000.0 *. msec)) +(** [escape str] efficiently escapes non-printable characters and in addition + the backslash character. The function is efficient in the sense that it will + allocate a new string only when necessary *) +let escape = Astring.String.Ascii.escape + let format include_time brand priority message = let id = get_thread_id () in - let name = match ThreadLocalTable.find names with Some x -> x | None -> "" in - let task = match ThreadLocalTable.find tasks with Some x -> x | None -> "" in - + let task, name = + (* if the task's client is known, attach it to the task's name *) + let name = + match ThreadLocalTable.find names with Some x -> x | None -> "" + in + match ThreadLocalTable.find tasks with + | None -> + ("", name) + | Some {desc; client= None} -> + (desc, name) + | Some {desc; client= Some client} -> + (desc, Printf.sprintf "%s->%s" client name) + in Printf.sprintf "[%s%5s||%d %s|%s|%s] %s" (if include_time then gettimestring () else "") priority id name task brand message let print_debug = ref false + let log_to_stdout () = print_debug := true module BrandLevelPair = struct type t = string * Syslog.level + let compare = Stdlib.compare end -module BrandLevelPairSet = Set.Make(BrandLevelPair) + +module BrandLevelPairSet = Set.Make (BrandLevelPair) let loglevel_m = Mutex.create () + let logging_disabled_for = ref BrandLevelPairSet.empty + let default_loglevel = Syslog.Debug + let loglevel = ref default_loglevel -let disabled_modules () = - BrandLevelPairSet.elements !logging_disabled_for +let disabled_modules () = BrandLevelPairSet.elements !logging_disabled_for let is_disabled brand level = - Syslog.is_masked ~threshold:!loglevel level || - BrandLevelPairSet.mem (brand, level) !logging_disabled_for - + Syslog.is_masked ~threshold:!loglevel level + || BrandLevelPairSet.mem (brand, level) !logging_disabled_for let facility = ref Syslog.Daemon + let set_facility f = facility := f + let get_facility () = !facility let output_log brand level priority s = - if not(is_disabled brand level) then begin + if not (is_disabled brand level) then ( let msg = format false brand priority s in - if !print_debug - then Printf.printf "%s\n%!" (format true brand priority s); - - Syslog.log (get_facility ()) level msg - end + if !print_debug then + Printf.printf "%s\n%!" (format true brand priority s) ; + Syslog.log (get_facility ()) level (escape msg) + ) let logs_reporter = (* We convert Logs level to our own type to allow output_log to correctly filter logs coming from libraries using Logs *) let logs_to_syslog_level = function - (* In practice we only care about Syslog.Debug,Warning,Info,Err, - because these are the ones we use in the log functions in Debug.Make *) - | Logs.Debug -> Syslog.Debug - | Logs.Info -> Syslog.Info - | Logs.Warning -> Syslog.Warning - | Logs.Error -> Syslog.Err - (* This is used by applications, not libraries - we should not get this in practice *) - | Logs.App -> Syslog.Info + (* In practice we only care about Syslog.Debug,Warning,Info,Err, because + these are the ones we use in the log functions in Debug.Make *) + | Logs.Debug -> + Syslog.Debug + | Logs.Info -> + Syslog.Info + | Logs.Warning -> + Syslog.Warning + | Logs.Error -> + Syslog.Err + (* This is used by applications, not libraries - we should not get this in + practice *) + | Logs.App -> + Syslog.Info in - (* Ensure that logs from libraries will be displayed with the correct - priority *) + (* Ensure that logs from libraries will be displayed with the correct priority *) let logs_level_to_priority = function (* These string match the ones used by the logging functions in Debug.Make *) - | Logs.Debug -> "debug" - | Logs.Info -> "info" - | Logs.Warning -> "warn" - | Logs.Error -> "error" - (* This is used by applications, not libraries - we should not get this in practice *) - | Logs.App -> "app" + | Logs.Debug -> + "debug" + | Logs.Info -> + "info" + | Logs.Warning -> + "warn" + | Logs.Error -> + "error" + (* This is used by applications, not libraries - we should not get this in + practice *) + | Logs.App -> + "app" in let report src level ~over k msgf = let formatter ?header ?tags fmt = - ignore(header); - ignore(tags); + ignore header ; + ignore tags ; let buf = Buffer.create 80 in let buf_fmt = Format.formatter_of_buffer buf in let k _ = - Format.pp_print_flush buf_fmt (); + Format.pp_print_flush buf_fmt () ; let msg = Buffer.contents buf in (* We map the Logs source name to the "brand", so we have to use the name of the Logs source when enabling/disabling it *) let brand = Logs.Src.name src in - output_log brand (logs_to_syslog_level level) (logs_level_to_priority level) msg; - over (); + output_log brand + (logs_to_syslog_level level) + (logs_level_to_priority level) + msg ; + over () ; k () in Format.kfprintf k buf_fmt fmt in msgf formatter in - { Logs.report = report } + {Logs.report} let init_logs () = - Logs.set_reporter logs_reporter; - (* [output_log] will do the actual filtering based on levels, - but we only consider messages of level warning and above from libraries, - to avoid calling [output_log] too often. *) + Logs.set_reporter logs_reporter ; + (* [output_log] will do the actual filtering based on levels, but we only + consider messages of level warning and above from libraries, to avoid + calling [output_log] too often. *) Logs.set_level (Some Logs.Warning) let rec split_c c str = try let i = String.index str c in - String.sub str 0 i :: (split_c c (String.sub str (i+1) (String.length str - i - 1))) + String.sub str 0 i + :: split_c c (String.sub str (i + 1) (String.length str - i - 1)) with Not_found -> [str] -let log_backtrace_exn ?(level=Syslog.Err) ?(msg="error") exn _bt = - Backtrace.is_important exn; - let all = split_c '\n' (Backtrace.(to_string_hum (remove exn))) in +let log_backtrace_exn ?(level = Syslog.Err) ?(msg = "error") exn bt = + (* We already got the backtrace in the `bt` argument when called from with_thread_associated. + Log that, and remove `exn` from the backtraces table. + If with_backtraces was not nested then looking at `bt` is the only way to get + a proper backtrace, otherwise exiting from `with_backtraces` would've removed the backtrace + from the thread-local backtraces table, and we'd always just log a message complaining about + with_backtraces not being called, which is not true because it was. + *) + let bt' = Backtrace.remove exn in + (* bt could be empty, but bt' would contain a non-empty warning, so compare 'bt' here *) + let bt = if bt = Backtrace.empty then bt' else bt in + let all = split_c '\n' Backtrace.(to_string_hum bt) in (* Write to the log line at a time *) - output_log "backtrace" level msg (Printf.sprintf "Raised %s" (Printexc.to_string exn)); + output_log "backtrace" level msg + (Printf.sprintf "Raised %s" (Printexc.to_string exn)) ; List.iter (output_log "backtrace" level msg) all -let log_backtrace e bt = log_backtrace_exn e bt +let log_backtrace_internal ?level ?msg e _bt = + Backtrace.is_important e ; + log_backtrace_exn ?level ?msg e (Backtrace.remove e) -let with_thread_associated task f x = - ThreadLocalTable.add tasks task; - let result = Backtrace.with_backtraces (fun () -> f x) in - ThreadLocalTable.remove tasks; +let log_backtrace e bt = log_backtrace_internal e bt + +let with_thread_associated ?client desc f x = + ThreadLocalTable.add tasks {desc; client} ; + let result = + Backtrace.with_backtraces (fun () -> + try f x with e -> Backtrace.is_important e ; raise e) + in + ThreadLocalTable.remove tasks ; match result with | `Ok result -> - result + result | `Error (exn, bt) -> - (* This function is a top-level exception handler typically used on fresh - threads. This is the last chance to do something with the backtrace *) - output_log "backtrace" Syslog.Err "error" (Printf.sprintf "%s failed with exception %s" task (Printexc.to_string exn)); - log_backtrace exn bt; - raise exn + (* This function is a top-level exception handler typically used on fresh + threads. This is the last chance to do something with the backtrace *) + output_log "backtrace" Syslog.Err "error" + (Printf.sprintf "%s failed with exception %s" desc + (Printexc.to_string exn)) ; + log_backtrace_exn exn bt ; + raise exn let with_thread_named name f x = - ThreadLocalTable.add names name; + ThreadLocalTable.add names name ; try let result = f x in - ThreadLocalTable.remove names; + ThreadLocalTable.remove names ; result with e -> - Backtrace.is_important e; - ThreadLocalTable.remove names; + Backtrace.is_important e ; + ThreadLocalTable.remove names ; raise e module type BRAND = sig - val name: string + val name : string end -let all_levels = [Syslog.Debug; Syslog.Info; Syslog.Warning; Syslog.Err; Syslog.Crit] +let all_levels = + [Syslog.Debug; Syslog.Info; Syslog.Warning; Syslog.Err; Syslog.Crit] let add_to_stoplist brand level = - logging_disabled_for := BrandLevelPairSet.add (brand, level) !logging_disabled_for + logging_disabled_for := + BrandLevelPairSet.add (brand, level) !logging_disabled_for let disable ?level brand = - let levels = match level with - | None -> all_levels - | Some l -> [l] - in - Mutex.execute loglevel_m (fun () -> - List.iter (add_to_stoplist brand) levels - ) + let levels = match level with None -> all_levels | Some l -> [l] in + Mutex.execute loglevel_m (fun () -> List.iter (add_to_stoplist brand) levels) -let set_level level = - Mutex.execute loglevel_m (fun () -> - loglevel := level - ) +let set_level level = Mutex.execute loglevel_m (fun () -> loglevel := level) module type DEBUG = sig val debug : ('a, unit, string, unit) format4 -> 'a @@ -247,34 +288,41 @@ module type DEBUG = sig val log_and_ignore_exn : (unit -> unit) -> unit end -module Make = functor(Brand: BRAND) -> struct - - let output level priority (fmt: ('a, unit, string, 'b) format4) = - Printf.kprintf - (fun s -> - if not(is_disabled Brand.name level) - then output_log Brand.name level priority s - ) fmt - - let debug fmt = output Syslog.Debug "debug" fmt - let warn fmt = output Syslog.Warning "warn" fmt - let info fmt = output Syslog.Info "info" fmt - let error fmt = output Syslog.Err "error" fmt - let critical fmt = output Syslog.Crit "critical" fmt - let audit ?(raw=false) (fmt: ('a, unit, string, 'b) format4) = - Printf.kprintf - (fun s -> - let msg = if raw then s else format true Brand.name "audit" s in - Syslog.log Syslog.Local6 Syslog.Info msg; - msg - ) fmt - - let log_backtrace () = - let backtrace = Printexc.get_backtrace () in - debug "%s" (String.escaped backtrace) - - let log_and_ignore_exn f = - try f () - with e -> log_backtrace_exn ~level:Syslog.Debug ~msg:"debug" e () -end +module Make = +functor + (Brand : BRAND) + -> + struct + let output level priority (fmt : ('a, unit, string, 'b) format4) = + Printf.kprintf + (fun s -> + if not (is_disabled Brand.name level) then + output_log Brand.name level priority s) + fmt + + let debug fmt = output Syslog.Debug "debug" fmt + let warn fmt = output Syslog.Warning "warn" fmt + + let info fmt = output Syslog.Info "info" fmt + + let error fmt = output Syslog.Err "error" fmt + + let critical fmt = output Syslog.Crit "critical" fmt + + let audit ?(raw = false) (fmt : ('a, unit, string, 'b) format4) = + Printf.kprintf + (fun s -> + let msg = if raw then s else format true Brand.name "audit" s in + Syslog.log Syslog.Local6 Syslog.Info (escape msg) ; + msg) + fmt + + let log_backtrace () = + let backtrace = Printexc.get_backtrace () in + debug "%s" (String.escaped backtrace) + + let log_and_ignore_exn f = + try f () + with e -> log_backtrace_internal ~level:Syslog.Debug ~msg:"debug" e () + end diff --git a/lib/debug.mli b/lib/debug.mli index 3b462ce1..78b17cd5 100644 --- a/lib/debug.mli +++ b/lib/debug.mli @@ -20,15 +20,17 @@ val init_logs : unit -> unit (** {2 Associate a task to the current actions} *) +val with_thread_associated : ?client:string -> string -> ('a -> 'b) -> 'a -> 'b (** Do an action with a task name associated with the current thread *) -val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b (** {2 Associate a name to the current thread} *) -(** Do an action with a name associated with the current thread *) val with_thread_named : string -> ('a -> 'b) -> 'a -> 'b +(** Do an action with a name associated with the current thread *) -module type BRAND = sig val name : string end +module type BRAND = sig + val name : string +end val gettimestring : unit -> string (** The current time of day in a format suitable for logging *) @@ -37,13 +39,13 @@ val set_facility : Syslog.facility -> unit (** Set the syslog facility that will be used by this program. *) val disable : ?level:Syslog.level -> string -> unit -(** [disable brand] Suppress all log output from the given [brand]. Specifying a [level] disables - * only this log level, otherwise all levels for the given [brand] are disabled. - * This function is idempotent. *) +(** [disable brand] Suppress all log output from the given [brand]. Specifying a + [level] disables * only this log level, otherwise all levels for the given + [brand] are disabled. * This function is idempotent. *) val set_level : Syslog.level -> unit -(** [set_level level] Disable all log output below [level]. - * This function is idempotent. *) +(** [set_level level] Disable all log output below [level]. * This function is + idempotent. *) val disabled_modules : unit -> (string * Syslog.level) list (** List describing which modules have logging currently disabled *) @@ -51,31 +53,31 @@ val disabled_modules : unit -> (string * Syslog.level) list val log_to_stdout : unit -> unit (** [log_to_stdout ()] will echo all log output to stdout (not the default) *) -val log_backtrace: exn -> Backtrace.t -> unit +val log_backtrace : exn -> Backtrace.t -> unit (** Write the backtrace associated with [exn] to the log *) module type DEBUG = sig - (** Debug function *) - val debug : ('a, unit, string, unit) format4 -> 'a + val debug : ('a, unit, string, unit) format4 -> 'a + (** Debug function *) - (** Warn function *) - val warn : ('a, unit, string, unit) format4 -> 'a + val warn : ('a, unit, string, unit) format4 -> 'a + (** Warn function *) - (** Info function *) - val info : ('a, unit, string, unit) format4 -> 'a + val info : ('a, unit, string, unit) format4 -> 'a + (** Info function *) - (** Error function *) - val error : ('a, unit, string, unit) format4 -> 'a + val error : ('a, unit, string, unit) format4 -> 'a + (** Error function *) - (** Critical function *) - val critical : ('a, unit, string, unit) format4 -> 'a + val critical : ('a, unit, string, unit) format4 -> 'a + (** Critical function *) - (** Audit function *) - val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a + val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a + (** Audit function *) - val log_backtrace : unit -> unit + val log_backtrace : unit -> unit - val log_and_ignore_exn : (unit -> unit) -> unit + val log_and_ignore_exn : (unit -> unit) -> unit end module Make : functor (Brand : BRAND) -> DEBUG @@ -83,5 +85,5 @@ module Make : functor (Brand : BRAND) -> DEBUG (** {3 Utility functions for the test code} *) val is_disabled : string -> Syslog.level -> bool -(** [is_disabled brand level] returns [true] if logging for [brand] at [level] is disabled, - * otherwise returns [false]. *) \ No newline at end of file +(** [is_disabled brand level] returns [true] if logging for [brand] at [level] + is disabled, * otherwise returns [false]. *) diff --git a/lib/dune b/lib/dune index bb5a078c..c846f047 100644 --- a/lib/dune +++ b/lib/dune @@ -1,68 +1,44 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let runtime_coverage_enabled, coverage_dep = - let use_bisect_runtime = - match Sys.getenv "BISECT_RUNTIME" with - | "YES" -> true - | _ -> false - | exception Not_found -> false in - if use_bisect_runtime then - "enabled.ml", "bisect_ppx.runtime" - else - "disabled.ml", "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - -(rule - (targets xcp_coverage.ml) - (action (copy coverage/%s %%{targets})) -) - (library - (name xcp) - (public_name xapi-idl) - (flags (:standard -w -39 -warn-error -3)) - (modules (:standard \ scheduler task_server updates)) - (c_names syslog_stubs) - (libraries - %s - cmdliner - cohttp - fd-send-recv - logs - message-switch-core - message-switch-unix - ppx_sexp_conv.runtime-lib - re - rpclib.core - rpclib.xml - sexplib - threads - unix - uri - xapi-backtrace - xapi-stdext-monadic - xapi-stdext-pervasives - xapi-stdext-threads - xapi-inventory - xmlm - ) - (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc %s)) -) + (name xcp) + (public_name xapi-idl) + (flags (:standard -w -39 -warn-error -3)) + (modules (:standard \ scheduler task_server updates)) + (foreign_stubs + (language c) + (names syslog_stubs)) + (libraries + astring + cmdliner + cohttp + fd-send-recv + logs + message-switch-core + message-switch-unix + mtime + mtime.clock.os + ppx_sexp_conv.runtime-lib + re + rpclib.core + rpclib.json + rpclib.xml + sexplib + threads + unix + uri + xapi-backtrace + xapi-stdext-pervasives + xapi-stdext-threads + xapi-inventory + xmlm + ) + (wrapped false) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) (library - (name xcp_updates) - (public_name xapi-idl.updates) - (flags (:standard -w -39)) - (modules updates task_server scheduler) - (libraries xapi-idl) - (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) -) -|} runtime_coverage_enabled coverage_dep coverage_rewriter coverage_rewriter + (name xcp_updates) + (public_name xapi-idl.updates) + (flags (:standard -w -39)) + (modules updates task_server scheduler) + (libraries xapi-idl) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) diff --git a/lib/open_uri.ml b/lib/open_uri.ml index eed2cacf..b63df639 100644 --- a/lib/open_uri.ml +++ b/lib/open_uri.ml @@ -17,41 +17,37 @@ open Xapi_stdext_pervasives.Pervasiveext -let handle_socket f s = - try - f s - with e -> - Backtrace.is_important e; - raise e +let handle_socket f s = try f s with e -> Backtrace.is_important e ; raise e let open_tcp f host port = let host_entry = Unix.gethostbyname host in - let sockaddr = Unix.ADDR_INET(host_entry.Unix.h_addr_list.(0), port) in + let sockaddr = Unix.ADDR_INET (host_entry.Unix.h_addr_list.(0), port) in let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - finally (fun () -> - Unix.connect s sockaddr; - handle_socket f s - ) (fun () -> - Unix.close s - ) + finally + (fun () -> Unix.connect s sockaddr ; handle_socket f s) + (fun () -> Unix.close s) let with_open_uri uri f = match Uri.scheme uri with - | Some "http" -> - begin match Uri.host uri, Uri.port uri with - | Some host, Some port -> open_tcp f host port - | Some host, None -> open_tcp f host 80 - | _, _ -> failwith (Printf.sprintf "Failed to parse host and port from URI: %s" (Uri.to_string uri)) - end + | Some "http" -> ( + match (Uri.host uri, Uri.port uri) with + | Some host, Some port -> + open_tcp f host port + | Some host, None -> + open_tcp f host 80 + | _, _ -> + failwith + (Printf.sprintf "Failed to parse host and port from URI: %s" + (Uri.to_string uri)) + ) | Some "file" -> - let filename = Uri.path_and_query uri in - let sockaddr = Unix.ADDR_UNIX filename in - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - finally (fun () -> - Unix.connect s sockaddr; - handle_socket f s - ) (fun () -> - Unix.close s - ) - | Some x -> failwith (Printf.sprintf "Unsupported URI scheme: %s" x) - | None -> failwith (Printf.sprintf "Failed to parse URI: %s" (Uri.to_string uri)) + let filename = Uri.path_and_query uri in + let sockaddr = Unix.ADDR_UNIX filename in + let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + finally + (fun () -> Unix.connect s sockaddr ; handle_socket f s) + (fun () -> Unix.close s) + | Some x -> + failwith (Printf.sprintf "Unsupported URI scheme: %s" x) + | None -> + failwith (Printf.sprintf "Failed to parse URI: %s" (Uri.to_string uri)) diff --git a/lib/posix_channel.ml b/lib/posix_channel.ml index c7e3e8d5..da9dda04 100644 --- a/lib/posix_channel.ml +++ b/lib/posix_channel.ml @@ -1,211 +1,227 @@ let my_domid = 0 (* TODO: figure this out *) exception End_of_file + exception Channel_setup_failed module CBuf = struct (** A circular buffer constructed from a string *) type t = { - mutable buffer: bytes; - mutable len: int; (** bytes of valid data in [buffer] *) - mutable start: int; (** index of first valid byte in [buffer] *) - mutable r_closed: bool; (** true if no more data can be read due to EOF *) - mutable w_closed: bool; (** true if no more data can be written due to EOF *) - } - - let empty length = { - buffer = Bytes.create length; - len = 0; - start = 0; - r_closed = false; - w_closed = false; + mutable buffer: bytes + ; mutable len: int (** bytes of valid data in [buffer] *) + ; mutable start: int (** index of first valid byte in [buffer] *) + ; mutable r_closed: bool (** true if no more data can be read due to EOF *) + ; mutable w_closed: bool + (** true if no more data can be written due to EOF *) } - let drop (x: t) n = - if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len); - x.start <- (x.start + n) mod (Bytes.length x.buffer); + let empty length = + { + buffer= Bytes.create length + ; len= 0 + ; start= 0 + ; r_closed= false + ; w_closed= false + } + + let drop (x : t) n = + if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len) ; + x.start <- (x.start + n) mod Bytes.length x.buffer ; x.len <- x.len - n - let should_read (x: t) = - not x.r_closed && (x.len < (Bytes.length x.buffer - 1)) - let should_write (x: t) = - not x.w_closed && (x.len > 0) + let should_read (x : t) = + (not x.r_closed) && x.len < Bytes.length x.buffer - 1 + + let should_write (x : t) = (not x.w_closed) && x.len > 0 - let end_of_reads (x: t) = x.r_closed && x.len = 0 - let end_of_writes (x: t) = x.w_closed + let end_of_reads (x : t) = x.r_closed && x.len = 0 - let write (x: t) fd = + let end_of_writes (x : t) = x.w_closed + + let write (x : t) fd = (* Offset of the character after the substring *) let next = min (Bytes.length x.buffer) (x.start + x.len) in let len = next - x.start in - let written = try Unix.single_write fd x.buffer x.start len with _e -> x.w_closed <- true; len in + let written = + try Unix.single_write fd x.buffer x.start len + with _e -> + x.w_closed <- true ; + len + in drop x written - let read (x: t) fd = + let read (x : t) fd = (* Offset of the next empty character *) - let next = (x.start + x.len) mod (Bytes.length x.buffer) in - let len = min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) in + let next = (x.start + x.len) mod Bytes.length x.buffer in + let len = + min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) + in let read = Unix.read fd x.buffer next len in - if read = 0 then x.r_closed <- true; + if read = 0 then x.r_closed <- true ; x.len <- x.len + read end -let proxy (a: Unix.file_descr) (b: Unix.file_descr) = +let proxy (a : Unix.file_descr) (b : Unix.file_descr) = let size = 64 * 1024 in (* [a'] is read from [a] and will be written to [b] *) (* [b'] is read from [b] and will be written to [a] *) let a' = CBuf.empty size and b' = CBuf.empty size in - Unix.set_nonblock a; - Unix.set_nonblock b; - + Unix.set_nonblock a ; + Unix.set_nonblock b ; try while true do - let r = (if CBuf.should_read a' then [ a ] else []) @ (if CBuf.should_read b' then [ b ] else []) in - let w = (if CBuf.should_write a' then [ b ] else []) @ (if CBuf.should_write b' then [ a ] else []) in - + let r = + (if CBuf.should_read a' then [a] else []) + @ if CBuf.should_read b' then [b] else [] + in + let w = + (if CBuf.should_write a' then [b] else []) + @ if CBuf.should_write b' then [a] else [] + in (* If we can't make any progress (because fds have been closed), then stop *) - if r = [] && w = [] then raise End_of_file; - + if r = [] && w = [] then raise End_of_file ; let r, w, _ = Unix.select r w [] (-1.0) in (* Do the writing before the reading *) - List.iter (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) w; - List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r; + List.iter + (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) + w ; + List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r ; (* If there's nothing else to read or write then signal the other end *) List.iter (fun (buf, fd) -> - if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND; - if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE - ) [ a', b; b', a ] + if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND ; + if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE) + [(a', b); (b', a)] done - with _ -> - (try Unix.clear_nonblock a with _ -> ()); - (try Unix.clear_nonblock b with _ -> ()) + with _ -> ( + (try Unix.clear_nonblock a with _ -> ()) ; + try Unix.clear_nonblock b with _ -> () + ) let finally f g = try let result = f () in - g (); - result - with e -> - g (); - raise e + g () ; result + with e -> g () ; raise e let ip = ref "127.0.0.1" let send proxy_socket = let to_close = ref [] in let to_unlink = ref [] in - finally (fun () -> let s_ip = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - to_close := s_ip :: !to_close; - Unix.bind s_ip (Unix.ADDR_INET(Unix.inet_addr_of_string !ip, 0)); - Unix.listen s_ip 5; - let port = match Unix.getsockname s_ip with - | Unix.ADDR_INET(_, port) -> port - | _ -> assert false in - + to_close := s_ip :: !to_close ; + Unix.bind s_ip (Unix.ADDR_INET (Unix.inet_addr_of_string !ip, 0)) ; + Unix.listen s_ip 5 ; + let port = + match Unix.getsockname s_ip with + | Unix.ADDR_INET (_, port) -> + port + | _ -> + assert false + in let s_unix = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - to_close := s_unix :: !to_close; + to_close := s_unix :: !to_close ; let path = Filename.temp_file "channel" "" in - to_unlink := path :: !to_unlink; - if Sys.file_exists path then Unix.unlink path; - Unix.bind s_unix (Unix.ADDR_UNIX path); - Unix.listen s_unix 5; - + to_unlink := path :: !to_unlink ; + if Sys.file_exists path then Unix.unlink path ; + Unix.bind s_unix (Unix.ADDR_UNIX path) ; + Unix.listen s_unix 5 ; let token = "token" in let protocols = - let open Xcp_channel_protocol in - [ - TCP_proxy(!ip, port); - Unix_sendmsg(my_domid, path, token); - ] in - - (* We need to hang onto a copy of the proxy_socket so we can - run a proxy in a background thread, allowing the caller to - close their copy. *) + let open Xcp_channel_protocol in + [TCP_proxy (!ip, port); Unix_sendmsg (my_domid, path, token)] + in + (* We need to hang onto a copy of the proxy_socket so we can run a proxy + in a background thread, allowing the caller to close their copy. *) let proxy_socket = Unix.dup proxy_socket in - to_close := proxy_socket :: !to_close; - - let (_: Thread.t) = Thread.create (fun (fds, paths) -> - (* The thread takes over management of the listening sockets *) - let to_close = ref fds in - let to_unlink = ref paths in - - let close fd = - if List.mem fd !to_close then begin - to_close := List.filter (fun x -> x <> fd) !to_close; - Unix.close fd; - end in - - finally - (fun () -> - let readable, _, _ = Unix.select [ s_ip; s_unix ] [] [] (-1.0) in - if List.mem s_unix readable then begin - let fd, _peer = Unix.accept s_unix in - to_close := fd :: !to_close; - let buffer = Bytes.make (String.length token) '\000' in - let n = Unix.recv fd buffer 0 (Bytes.length buffer) [] in - let token' = Bytes.sub_string buffer 0 n in - if token = token' then begin - let (_: int) = Fd_send_recv.send_fd_substring fd token 0 (String.length token) [] proxy_socket in - () - end - end else if List.mem s_ip readable then begin - let fd, _peer = Unix.accept s_ip in - - List.iter close !to_close; - to_close := fd :: !to_close; - proxy fd proxy_socket - end else assert false (* can never happen *) - ) (fun () -> - List.iter close !to_close; - List.iter Unix.unlink !to_unlink; - ) - ) (!to_close, !to_unlink) in + to_close := proxy_socket :: !to_close ; + let (_ : Thread.t) = + Thread.create + (fun (fds, paths) -> + (* The thread takes over management of the listening sockets *) + let to_close = ref fds in + let to_unlink = ref paths in + let close fd = + if List.mem fd !to_close then ( + to_close := List.filter (fun x -> x <> fd) !to_close ; + Unix.close fd + ) + in + finally + (fun () -> + let readable, _, _ = Unix.select [s_ip; s_unix] [] [] (-1.0) in + if List.mem s_unix readable then ( + let fd, _peer = Unix.accept s_unix in + to_close := fd :: !to_close ; + let buffer = Bytes.make (String.length token) '\000' in + let n = Unix.recv fd buffer 0 (Bytes.length buffer) [] in + let token' = Bytes.sub_string buffer 0 n in + if token = token' then + let (_ : int) = + Fd_send_recv.send_fd_substring fd token 0 + (String.length token) [] proxy_socket + in + () + ) else if List.mem s_ip readable then ( + let fd, _peer = Unix.accept s_ip in + List.iter close !to_close ; + to_close := fd :: !to_close ; + proxy fd proxy_socket + ) else + assert false + (* can never happen *)) + (fun () -> + List.iter close !to_close ; + List.iter Unix.unlink !to_unlink)) + (!to_close, !to_unlink) + in (* Handover of listening sockets successful *) - to_close := []; - to_unlink := []; - protocols - ) (fun () -> - List.iter Unix.close !to_close; - List.iter Unix.unlink !to_unlink; - ) + to_close := [] ; + to_unlink := [] ; + protocols) + (fun () -> + List.iter Unix.close !to_close ; + List.iter Unix.unlink !to_unlink) let receive protocols = let open Xcp_channel_protocol in let weight = function - | TCP_proxy(_, _) -> 2 - | Unix_sendmsg(domid, _, _) -> if my_domid = domid then 3 else 0 - | V4V_proxy(_, _) -> 0 in - let protocol = match List.sort (fun a b -> compare (weight b) (weight a)) protocols with - | [] -> - raise Channel_setup_failed - | best :: _ -> - if weight best = 0 then begin - raise Channel_setup_failed - end else best in + | TCP_proxy (_, _) -> + 2 + | Unix_sendmsg (domid, _, _) -> + if my_domid = domid then 3 else 0 + | V4V_proxy (_, _) -> + 0 + in + let protocol = + match List.sort (fun a b -> compare (weight b) (weight a)) protocols with + | [] -> + raise Channel_setup_failed + | best :: _ -> + if weight best = 0 then raise Channel_setup_failed else best + in match protocol with - | V4V_proxy(_, _) -> assert false (* weight is 0 above *) - | TCP_proxy(ip, port) -> - let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - begin + | V4V_proxy (_, _) -> + assert false (* weight is 0 above *) + | TCP_proxy (ip, port) -> ( + let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in try - Unix.connect s (Unix.ADDR_INET(Unix.inet_addr_of_string ip, port)); + Unix.connect s (Unix.ADDR_INET (Unix.inet_addr_of_string ip, port)) ; s - with e -> - Unix.close s; - raise e - end - | Unix_sendmsg(_, path, token) -> - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - finally - (fun () -> - Unix.connect s (Unix.ADDR_UNIX path); - let (_: int) = Unix.send_substring s token 0 (String.length token) [] in - let buf = Bytes.create (String.length token) in - let (_, _, fd) = Fd_send_recv.recv_fd s buf 0 (Bytes.length buf) [] in - fd - ) (fun () -> Unix.close s) - + with e -> Unix.close s ; raise e + ) + | Unix_sendmsg (_, path, token) -> + let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + finally + (fun () -> + Unix.connect s (Unix.ADDR_UNIX path) ; + let (_ : int) = + Unix.send_substring s token 0 (String.length token) [] + in + let buf = Bytes.create (String.length token) in + let _, _, fd = Fd_send_recv.recv_fd s buf 0 (Bytes.length buf) [] in + fd) + (fun () -> Unix.close s) diff --git a/lib/posix_channel.mli b/lib/posix_channel.mli index 1db458e6..8610f27a 100644 --- a/lib/posix_channel.mli +++ b/lib/posix_channel.mli @@ -12,10 +12,10 @@ * GNU Lesser General Public License for more details. *) -val send: Unix.file_descr -> Xcp_channel_protocol.t list -(** [send fd] attempts to send the channel represented by [fd] to a - remote process. Note the file descriptor remains open in the - original process and should still be closed normally. *) +val send : Unix.file_descr -> Xcp_channel_protocol.t list +(** [send fd] attempts to send the channel represented by [fd] to a remote + process. Note the file descriptor remains open in the original process and + should still be closed normally. *) -val receive: Xcp_channel_protocol.t list -> Unix.file_descr +val receive : Xcp_channel_protocol.t list -> Unix.file_descr (** [receive protocols] receives a channel from a remote. *) diff --git a/lib/scheduler.ml b/lib/scheduler.ml index eb15ed1e..bd0628f5 100644 --- a/lib/scheduler.ml +++ b/lib/scheduler.ml @@ -12,217 +12,206 @@ * GNU Lesser General Public License for more details. *) -let finally f g = - try - let result = f () in - g (); - result; - with - | e -> - g (); - raise e - -let mutex_execute m f = - Mutex.lock m; - finally f (fun () -> Mutex.unlock m) - -module D = Debug.Make(struct let name = "scheduler" end) -open D +open Xapi_stdext_threads -module Int64Map = Map.Make(struct type t = int64 let compare = Int64.compare end) +module D = Debug.Make (struct let name = "scheduler" end) -module Delay = struct +open D + +module PipeDelay = struct (* Concrete type is the ends of a pipe *) type t = { - (* A pipe is used to wake up a thread blocked in wait: *) - mutable pipe_out: Unix.file_descr option; - mutable pipe_in: Unix.file_descr option; - (* Indicates that a signal arrived before a wait: *) - mutable signalled: bool; - m: Mutex.t + (* A pipe is used to wake up a thread blocked in wait: *) + pipe_out: Unix.file_descr + ; pipe_in: Unix.file_descr } let make () = - { pipe_out = None; - pipe_in = None; - signalled = false; - m = Mutex.create () } - - exception Pre_signalled + let pipe_out, pipe_in = Unix.pipe () in + {pipe_out; pipe_in} - let wait (x: t) (seconds: float) = + let wait (x : t) (seconds : float) = let timeout = if seconds < 0.0 then 0.0 else seconds in - let to_close = ref [ ] in - let close' fd = - if List.mem fd !to_close then Unix.close fd; - to_close := List.filter (fun x -> fd <> x) !to_close in - finally - (fun () -> - try - let pipe_out = mutex_execute x.m - (fun () -> - if x.signalled then begin - x.signalled <- false; - raise Pre_signalled; - end; - let pipe_out, pipe_in = Unix.pipe () in - (* these will be unconditionally closed on exit *) - to_close := [ pipe_out; pipe_in ]; - x.pipe_out <- Some pipe_out; - x.pipe_in <- Some pipe_in; - x.signalled <- false; - pipe_out) in - let r, _, _ = Unix.select [ pipe_out ] [] [] timeout in - (* flush the single byte from the pipe *) - if r <> [] then ignore(Unix.read pipe_out (Bytes.create 1) 0 1); - (* return true if we waited the full length of time, false if we were woken *) - r = [] - with Pre_signalled -> false - ) - (fun () -> - mutex_execute x.m - (fun () -> - x.pipe_out <- None; - x.pipe_in <- None; - List.iter close' !to_close) - ) - - let signal (x: t) = - mutex_execute x.m - (fun () -> - match x.pipe_in with - | Some fd -> ignore(Unix.write fd (Bytes.of_string "X") 0 1) - | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) - ) + if Thread.wait_timed_read x.pipe_out timeout then + (* flush the single byte from the pipe *) + let (_ : int) = Unix.read x.pipe_out (Bytes.create 1) 0 1 in + (* return false if we were woken *) + false + else + (* return true if we waited the full length of time, false if we were woken *) + true + + let signal (x : t) = + let (_ : int) = Unix.write x.pipe_in (Bytes.of_string "X") 0 1 in + () end -type item = { - id: int; - name: string; - fn: unit -> unit -} +type handle = Mtime.span * int + +type handle_compat = int64 * int [@@deriving rpc] + +let rpc_of_handle (s, id) = rpc_of_handle_compat (Mtime.Span.to_uint64_ns s, id) + +let handle_of_rpc rpc = + let i64, id = handle_compat_of_rpc rpc in + (Mtime.Span.of_uint64_ns i64, id) + +module HandleMap = Map.Make (struct + type t = handle + + let compare (x1, id1) (x2, id2) = + let c = Mtime.Span.compare x1 x2 in + if c = 0 then + id2 - id1 + else + c +end) -type handle = int64 * int [@@deriving rpc] +type item = {id: int; name: string; fn: unit -> unit} type t = { - mutable schedule : item list Int64Map.t; - mutable shutdown : bool; - delay : Delay.t; - mutable next_id : int; - mutable thread : Thread.t option; - m : Mutex.t; + mutable schedule: item HandleMap.t + ; delay: PipeDelay.t + ; mutable next_id: int + ; m: Mutex.t } -type time = - | Absolute of int64 - | Delta of int +type time = Delta of int (*type t = int64 * int [@@deriving rpc]*) -let now () = Unix.gettimeofday () |> ceil |> Int64.of_float +let time_of_span span = span |> Mtime.Span.to_s |> ceil |> Int64.of_float + +let mtime_sub time now = Mtime.Span.abs_diff time now |> time_of_span + +let now () = Mtime_clock.elapsed () module Dump = struct - type u = { - time: int64; - thing: string; - } [@@deriving rpc] + type u = {time: int64; thing: string} [@@deriving rpc] + type dump = u list [@@deriving rpc] + let make s = let now = now () in - mutex_execute s.m - (fun () -> - Int64Map.fold (fun time xs acc -> List.map (fun i -> { time = Int64.sub time now; thing = i.name }) xs @ acc) s.schedule [] - ) + Threadext.Mutex.execute s.m (fun () -> + HandleMap.fold + (fun (time, _) i acc -> + {time= mtime_sub time now; thing= i.name} :: acc) + s.schedule []) end -let one_shot s time (name: string) f = - let time = match time with - | Absolute x -> x - | Delta x -> Int64.(add (of_int x) (now ())) in - let id = mutex_execute s.m - (fun () -> - let existing = - try - Int64Map.find time s.schedule - with _ -> [] - in - let id = s.next_id in - s.next_id <- s.next_id + 1; - let item = { - id = id; - name = name; - fn = f - } in - s.schedule <- Int64Map.add time (item :: existing) s.schedule; - Delay.signal s.delay; - id - ) in - (time, id) - -let cancel s (time, id) = - mutex_execute s.m - (fun () -> - let existing = - if Int64Map.mem time s.schedule - then Int64Map.find time s.schedule - else [] in - s.schedule <- Int64Map.add time (List.filter (fun i -> i.id <> id) existing) s.schedule - ) +let mtime_add x t = + let dt = Mtime.(x *. Mtime.s_to_ns |> Int64.of_float |> Span.of_uint64_ns) in + Mtime.Span.add dt t + +let one_shot_f s dt (name : string) f = + let time = mtime_add dt (now ()) in + Threadext.Mutex.execute s.m (fun () -> + let id = s.next_id in + s.next_id <- s.next_id + 1 ; + let item = {id; name; fn= f} in + let handle = (time, id) in + s.schedule <- HandleMap.add handle item s.schedule ; + PipeDelay.signal s.delay ; + handle) + +let one_shot s (Delta x) name f = one_shot_f s (float x) name f + +let cancel s handle = + Threadext.Mutex.execute s.m (fun () -> + s.schedule <- HandleMap.remove handle s.schedule) let process_expired s = let t = now () in let expired = - mutex_execute s.m - (fun () -> - let expired, unexpired = Int64Map.partition (fun t' _ -> t' <= t) s.schedule in - s.schedule <- unexpired; - Int64Map.fold (fun _ stuff acc -> acc @ stuff) expired [] |> List.rev) in + Threadext.Mutex.execute s.m (fun () -> + let expired, eq, unexpired = HandleMap.split (t, max_int) s.schedule in + assert (eq = None) ; + s.schedule <- unexpired ; + expired |> HandleMap.to_seq |> Seq.map snd) + in (* This might take a while *) - List.iter + Seq.iter (fun i -> - try - i.fn () - with e -> - debug "Scheduler ignoring exception: %s\n%!" (Printexc.to_string e) - ) expired; - expired <> [] (* true if work was done *) + try i.fn () + with e -> + debug "Scheduler ignoring exception: %s\n%!" (Printexc.to_string e)) + expired ; + expired () <> Seq.Nil + +(* true if work was done *) let rec main_loop s = - while process_expired s do () done; + while process_expired s do + () + done ; let sleep_until = - mutex_execute s.m - (fun () -> - try - Int64Map.min_binding s.schedule |> fst - with Not_found -> - Int64.add 3600L (now ()) - ) in - let seconds = Int64.sub sleep_until (now ()) in - let (_: bool) = Delay.wait s.delay (Int64.to_float seconds) in - if s.shutdown - then s.thread <- None - else main_loop s - -let start s = - if s.shutdown then failwith "Scheduler was shutdown"; - s.thread <- Some (Thread.create main_loop s) - -let make () = - let s = { - schedule = Int64Map.empty; - shutdown = false; - delay = Delay.make (); - next_id = 0; - m = Mutex.create (); - thread = None; - } in - start s; + Threadext.Mutex.execute s.m (fun () -> + try HandleMap.min_binding s.schedule |> fst |> fst + with Not_found -> mtime_add 3600. (now ())) + in + let this = now () in + let seconds = + if Mtime.Span.compare sleep_until this > 0 then + (* be careful that this is absolute difference, + it is never negative! *) + Mtime.Span.(abs_diff sleep_until this |> to_s) + else + 0. + in + let (_ : bool) = PipeDelay.wait s.delay seconds in + main_loop s + +let make_scheduler () = + let s = + { + schedule= HandleMap.empty + ; delay= PipeDelay.make () + ; next_id= 0 + ; m= Mutex.create () + } + in + let (_ : Thread.t) = Thread.create main_loop s in s -let shutdown s = - match s.thread with - | Some th -> - s.shutdown <- true; - Delay.signal s.delay; - Thread.join th - | None -> () +let make = make_scheduler + +module Delay = struct + type state = Signalled | Timedout + + let s = make_scheduler () + + type t = {c: Condition.t; m: Mutex.t; mutable state: state option} + + let make () = {c= Condition.create (); m= Mutex.create (); state= None} + + let wait t seconds = + Threadext.Mutex.execute t.m (fun () -> + let handle = + one_shot_f s seconds "Delay.wait" (fun () -> + if t.state = None then + t.state <- Some Timedout ; + Condition.broadcast t.c) + in + let rec loop () = + match t.state with + | Some Timedout -> + (* return true if we waited the full length of time *) + true + | Some Signalled -> + (* return false if we were woken, or pre-signalled *) + false + | None -> + (* initial wait or spurious wakeup *) + Condition.wait t.c t.m ; loop () + in + let result = loop () in + cancel s handle ; + t.state <- None ; + result) + + let signal t = + Threadext.Mutex.execute t.m (fun () -> + t.state <- Some Signalled ; + Condition.broadcast t.c) +end diff --git a/lib/scheduler.mli b/lib/scheduler.mli index 85f521af..f0515422 100644 --- a/lib/scheduler.mli +++ b/lib/scheduler.mli @@ -1,54 +1,49 @@ - (** The Delay module here implements simple cancellable delays. *) -module Delay : - sig - type t +module Delay : sig + type t - (** Makes a Delay.t *) - val make : unit -> t + val make : unit -> t + (** Makes a Delay.t *) - (** Wait for the specified amount of time. Returns true if we waited - the full length of time, false if we were woken *) - val wait : t -> float -> bool + val wait : t -> float -> bool + (** Wait for the specified amount of time. Returns true if we waited the full + length of time, false if we were woken *) - (** Signal anyone currently waiting with the Delay.t *) - val signal : t -> unit - end + val signal : t -> unit + (** Signal anyone currently waiting with the Delay.t *) +end (** The type of a scheduler *) type t (** The handle for referring to an item that has been scheduled *) type handle + val rpc_of_handle : handle -> Rpc.t + val handle_of_rpc : Rpc.t -> handle -(** Creates a scheduler *) val make : unit -> t +(** Creates a scheduler *) -(** Items can be scheduled at an absolute time (measured in seconds since - unix epoch) or as a delta measured in for seconds from now. *) -type time = Absolute of int64 | Delta of int - -(** Useful for Absolutely scheduled items *) -val now : unit -> int64 +(** Items can be scheduled as a delta measured in seconds from now. *) +type time = Delta of int (** This module is for dumping the state of a scheduler *) -module Dump : - sig - type u = { time : int64; thing : string; } - type dump = u list - val rpc_of_dump : dump -> Rpc.t - val dump_of_rpc : Rpc.t -> dump - val make : t -> dump - end +module Dump : sig + type u = {time: int64; thing: string} + + type dump = u list + + val rpc_of_dump : dump -> Rpc.t + + val dump_of_rpc : Rpc.t -> dump + + val make : t -> dump +end -(** Insert a one-shot item into the scheduler. *) val one_shot : t -> time -> string -> (unit -> unit) -> handle +(** Insert a one-shot item into the scheduler. *) -(** Cancel an item *) val cancel : t -> handle -> unit - -(** shutdown a scheduler. Any item currently scheduled will not - be executed. The scheduler cannot be restarted. *) -val shutdown : t -> unit +(** Cancel an item *) diff --git a/lib/syslog.ml b/lib/syslog.ml index df348cd2..cdc62c6b 100644 --- a/lib/syslog.ml +++ b/lib/syslog.ml @@ -13,64 +13,123 @@ *) type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug -type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern - | Local0 | Local1 | Local2 | Local3 - | Local4 | Local5 | Local6 | Local7 - | Lpr | Mail | News | Syslog | User | Uucp + +type facility = + | Auth + | Authpriv + | Cron + | Daemon + | Ftp + | Kern + | Local0 + | Local1 + | Local2 + | Local3 + | Local4 + | Local5 + | Local6 + | Local7 + | Lpr + | Mail + | News + | Syslog + | User + | Uucp (* external init : string -> options list -> facility -> unit = "stub_openlog" *) external log : facility -> level -> string -> unit = "stub_syslog" + external close : unit -> unit = "stub_closelog" exception Unknown_facility of string + let facility_of_string s = - match s with - |"auth"->Auth - |"authpriv"->Authpriv - |"cron"->Cron - |"daemon"->Daemon - |"ftp"->Ftp - |"kern"->Kern - |"local0"->Local0 - |"local1"->Local1 - |"local2"->Local2 - |"local3"->Local3 - |"local4"->Local4 - |"local5"->Local5 - |"local6"->Local6 - |"local7"->Local7 - |"lpr"->Lpr - |"mail"->Mail - |"news"->News - |"syslog"->Syslog - |"user"->User - |"uucp"->Uucp - |_-> raise (Unknown_facility s) + match s with + | "auth" -> + Auth + | "authpriv" -> + Authpriv + | "cron" -> + Cron + | "daemon" -> + Daemon + | "ftp" -> + Ftp + | "kern" -> + Kern + | "local0" -> + Local0 + | "local1" -> + Local1 + | "local2" -> + Local2 + | "local3" -> + Local3 + | "local4" -> + Local4 + | "local5" -> + Local5 + | "local6" -> + Local6 + | "local7" -> + Local7 + | "lpr" -> + Lpr + | "mail" -> + Mail + | "news" -> + News + | "syslog" -> + Syslog + | "user" -> + User + | "uucp" -> + Uucp + | _ -> + raise (Unknown_facility s) exception Unknown_level of string + let level_of_string s = - match String.lowercase_ascii s with - | "emergency" -> Emerg - | "alert" -> Alert - | "critical" -> Crit - | "error" | "err" -> Err - | "warning" | "warn" -> Warning - | "notice" -> Notice - | "info" -> Info - | "debug" -> Debug - | _-> raise (Unknown_level s) + match String.lowercase_ascii s with + | "emergency" -> + Emerg + | "alert" -> + Alert + | "critical" -> + Crit + | "error" | "err" -> + Err + | "warning" | "warn" -> + Warning + | "notice" -> + Notice + | "info" -> + Info + | "debug" -> + Debug + | _ -> + raise (Unknown_level s) let string_of_level = function - | Emerg -> "emergency" - | Alert -> "alert" - | Crit -> "critical" - | Err -> "error" - | Warning -> "warning" - | Notice -> "notice" - | Info -> "info" - | Debug -> "debug" + | Emerg -> + "emergency" + | Alert -> + "alert" + | Crit -> + "critical" + | Err -> + "error" + | Warning -> + "warning" + | Notice -> + "notice" + | Info -> + "info" + | Debug -> + "debug" let is_masked ~threshold level = - (* This comparison relies on the order in which the constructors in - level are declared *) - threshold < level + (* This comparison relies on the order in which the constructors in level are + declared *) + threshold < level diff --git a/lib/syslog.mli b/lib/syslog.mli index e96214fb..762b38b4 100644 --- a/lib/syslog.mli +++ b/lib/syslog.mli @@ -13,8 +13,9 @@ *) type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug + type facility = - Auth + | Auth | Authpriv | Cron | Daemon @@ -36,19 +37,21 @@ type facility = | Uucp external log : facility -> level -> string -> unit = "stub_syslog" + external close : unit -> unit = "stub_closelog" val facility_of_string : string -> facility -(** [facility_of_string facility] Return the Syslog facility corresponding to [facility]. - Raises [Unknown_facility facility] if facility is unrecognized. *) +(** [facility_of_string facility] Return the Syslog facility corresponding to + [facility]. Raises [Unknown_facility facility] if facility is unrecognized. *) val level_of_string : string -> level (** [level_of_string level] Return the Syslog level corresponding to [level]. Raises [Unknown_level level] if level is unrecognized. *) val string_of_level : level -> string -(** [string_of_level level] Return the string corresponding to the Syslog level [level] *) +(** [string_of_level level] Return the string corresponding to the Syslog level + [level] *) val is_masked : threshold:level -> level -> bool -(** [is_masked ~threshold level] Return true if [level] is below [threshold] and should therefore - not be logged. *) +(** [is_masked ~threshold level] Return true if [level] is below [threshold] and + should therefore not be logged. *) diff --git a/lib/task_server.ml b/lib/task_server.ml index 01b9c85a..d3f0145e 100644 --- a/lib/task_server.ml +++ b/lib/task_server.ml @@ -11,15 +11,14 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** - * @group Xenops -*) -open Xapi_stdext_monadic + +(** @group Xenops *) + open Xapi_stdext_pervasives.Pervasiveext open Xapi_stdext_threads.Threadext +module D = Debug.Make (struct let name = "task_server" end) -module D = Debug.Make(struct let name = "task_server" end) open D type stringpair = string * string @@ -28,7 +27,9 @@ module type INTERFACE = sig val service_name : string val does_not_exist : string * string -> exn + val cancelled : string -> exn + val marshal_exn : exn -> Rpc.t module Task : sig @@ -36,10 +37,7 @@ module type INTERFACE = sig type async_result - type completion_t = { - duration : float; - result : async_result option - } + type completion_t = {duration: float; result: async_result option} type state = | Pending of float @@ -47,243 +45,245 @@ module type INTERFACE = sig | Failed of Rpc.t type t = { - id: id; - dbg: string; - ctime: float; - state: state; - subtasks: (string * state) list; - debug_info: (string * string) list; - backtrace: string; - cancellable: bool; + id: id + ; dbg: string + ; ctime: float + ; state: state + ; subtasks: (string * state) list + ; debug_info: (string * string) list + ; backtrace: string + ; cancellable: bool } - end (* The following stuff comes from rpc-light.idl *) - end +module Task = +functor + (Interface : INTERFACE) + -> + struct + module SMap = Map.Make (struct + type t = string -module Task = functor (Interface : INTERFACE) -> struct - - module SMap = Map.Make(struct type t = string let compare = compare end) - - (* Tasks are stored in an id -> t map *) - type id = string - - (* A task is associated with every running operation *) - type task_handle = { - tasks : tasks; - id: id; (* unique task id *) - ctime: float; (* created timestamp *) - dbg: string; (* token sent by client *) - mutable state: Interface.Task.state; (* current completion state *) - mutable subtasks: (string * Interface.Task.state) list; (* one level of "subtasks" *) - f: task_handle -> Interface.Task.async_result option; (* body of the function *) - tm: Mutex.t; (* protects cancelling state: *) - mutable cancelling: bool; (* set by cancel *) - mutable cancel: (unit -> unit) list; (* attempt to cancel [f] *) - mutable cancel_points_seen: int; (* incremented every time we pass a cancellation point *) - test_cancel_at: int option; (* index of the cancel point to trigger *) - mutable backtrace: Backtrace.t; (* on error, a backtrace *) - mutable cancellable: bool; - } - - and tasks = { - task_map : task_handle SMap.t ref; - mutable test_cancel_trigger : (string * int) option; - m : Mutex.t; - c : Condition.t; - } - - let empty () = - let task_map = ref SMap.empty in - let m = Mutex.create () in - let c = Condition.create () in - { task_map; test_cancel_trigger = None; m; c } - - (* [next_task_id ()] returns a fresh task id *) - let next_task_id = - let counter = ref 0 in - fun () -> - let result = string_of_int !counter in - incr counter; - result - - let set_cancel_trigger tasks dbg n = - Mutex.execute tasks.m - (fun () -> - tasks.test_cancel_trigger <- Some (dbg, n) - ) - - let clear_cancel_trigger tasks = - Mutex.execute tasks.m - (fun () -> - tasks.test_cancel_trigger <- None - ) - - let id_of_handle task_handle = task_handle.id - - (* [add dbg f] creates a fresh [t], registers and returns it *) - let add tasks dbg (f: task_handle -> Interface.Task.async_result option) = - let t = { - tasks = tasks; - id = next_task_id (); - ctime = Unix.gettimeofday (); - dbg = dbg; - state = Interface.Task.Pending 0.; - subtasks = []; - f = f; - tm = Mutex.create (); - cancelling = false; - cancel = []; - cancel_points_seen = 0; - test_cancel_at = (match tasks.test_cancel_trigger with - | Some (dbg', n) when dbg = dbg' -> - clear_cancel_trigger tasks; (* one shot *) - Some n - | _ -> None); - backtrace = Backtrace.empty; - cancellable = true; - } in - Mutex.execute tasks.m - (fun () -> - tasks.task_map := SMap.add t.id t !(tasks.task_map) - ); - t - - (* [run t] executes the task body, updating the fields of [t] *) - let run item = - try - let start = Unix.gettimeofday () in - let result = item.f item in - let duration = Unix.gettimeofday () -. start in - item.state <- Interface.Task.Completed { Interface.Task.duration; result }; - debug "Task %s completed; duration = %.0f" item.id duration - with - | e -> - Backtrace.is_important e; - error "Task %s failed; %s" item.id (Printexc.to_string e); - item.backtrace <- Backtrace.remove e; - let e = e |> Interface.marshal_exn in - item.state <- Interface.Task.Failed e - - let find_locked tasks id = - try - SMap.find id !(tasks.task_map) - with - | _ -> raise (Interface.does_not_exist ("task", id)) - - let to_interface_task t = - { - Interface.Task.id = t.id; - dbg = t.dbg; - ctime = t.ctime; - state = t.state; - subtasks = t.subtasks; - debug_info = [ - "cancel_points_seen", string_of_int t.cancel_points_seen - ]; - backtrace = Sexplib.Sexp.to_string (Backtrace.sexp_of_t t.backtrace); - cancellable = t.cancellable; + let compare = compare + end) + + (** Tasks are stored in an id -> t map *) + type id = string + + (** A task is associated with every running operation *) + type task_handle = { + tasks: tasks + ; id: id (** unique task id *) + ; ctime: float (** created timestamp *) + ; dbg: string (** token sent by client *) + ; mutable state: Interface.Task.state (** current completion state *) + ; mutable subtasks: (string * Interface.Task.state) list + (** one level of "subtasks" *) + ; f: task_handle -> Interface.Task.async_result option + (** body of the function *) + ; tm: Mutex.t (** protects cancelling state *) + ; mutable cancelling: bool (** set by cancel *) + ; mutable cancel: (unit -> unit) list (** attempt to cancel [f] *) + ; mutable cancel_points_seen: int + (** incremented every time we pass a cancellation point *) + ; test_cancel_at: int option (** index of the cancel point to trigger *) + ; mutable backtrace: Backtrace.t (** on error, a backtrace *) + ; mutable cancellable: bool } - let handle_of_id tasks id = - Mutex.execute tasks.m (fun () -> find_locked tasks id) - - let get_state task = - task.state - - let set_state task state = - task.state <- state - - let get_dbg task_handle = - task_handle.dbg - - let replace_assoc key new_value existing = - (key, new_value) :: (List.filter (fun (k, _) -> k <> key) existing) - - let with_subtask t name f = - let start = Unix.gettimeofday () in - try - t.subtasks <- (name, Interface.Task.Pending 0.) :: t.subtasks; - let result = f () in - let duration = Unix.gettimeofday () -. start in - t.subtasks <- replace_assoc name (Interface.Task.Completed {Interface.Task.duration; result=None}) t.subtasks; - result - with e -> - Backtrace.is_important e; - let e' = Interface.marshal_exn e in - t.subtasks <- replace_assoc name (Interface.Task.Failed e') t.subtasks; - raise e - - let list tasks = - Mutex.execute tasks.m - (fun () -> - SMap.bindings !(tasks.task_map) |> List.map snd - ) - - (* Remove the task from the id -> task mapping. NB any active thread will still continue. *) - let destroy task = - let tasks = task.tasks in - Mutex.execute tasks.m - (fun () -> - tasks.task_map := SMap.remove task.id !(tasks.task_map) - ) - - let cancel task = - let callbacks = Mutex.execute task.tm - (fun () -> - if not task.cancellable then begin - info "Task %s is not cancellable." task.id; - [] - end - else begin - task.cancelling <- true; - task.cancel - end - ) in - List.iter - (fun f -> - try - f () - with e -> - debug "Task.cancel %s: ignore exception %s" task.id (Printexc.to_string e) - ) callbacks - - let raise_cancelled task = - info "Task %s has been cancelled: raising Cancelled exception" task.id; - raise (Interface.cancelled task.id) - - let check_cancelling_locked task = - task.cancel_points_seen <- task.cancel_points_seen + 1; - if task.cancelling then raise_cancelled task; - Opt.iter (fun x -> if task.cancel_points_seen = x then begin - info "Task %s has been triggered by the test-case (cancel_point = %d)" task.id task.cancel_points_seen; - raise_cancelled task - end) task.test_cancel_at - - let check_cancelling t = - Mutex.execute t.tm (fun () -> check_cancelling_locked t) - - let with_cancel t cancel_fn f = - Mutex.execute t.tm (fun () -> - try - check_cancelling_locked t; - t.cancel <- cancel_fn :: t.cancel - with e -> - (try cancel_fn () with e -> debug "Task.cancel %s: ignore exception %s" t.id (Printexc.to_string e)); - raise e); - finally - (fun () -> - check_cancelling t; - f () - ) - (fun () -> Mutex.execute t.tm (fun () -> t.cancel <- List.tl t.cancel)) - - let prohibit_cancellation task = - Mutex.execute task.tm (fun () -> - (* If task is cancelling, just cancel it before setting it to not cancellable *) - check_cancelling_locked task; - task.cancellable <- false) -end + and tasks = { + task_map: task_handle SMap.t ref + ; mutable test_cancel_trigger: (string * int) option + ; m: Mutex.t + ; c: Condition.t + } + + let empty () = + let task_map = ref SMap.empty in + let m = Mutex.create () in + let c = Condition.create () in + {task_map; test_cancel_trigger= None; m; c} + + (* [next_task_id ()] returns a fresh task id *) + let next_task_id = + let counter = ref 0 in + fun () -> + let result = string_of_int !counter in + incr counter ; result + + let set_cancel_trigger tasks dbg n = + Mutex.execute tasks.m (fun () -> + tasks.test_cancel_trigger <- Some (dbg, n)) + + let clear_cancel_trigger tasks = + Mutex.execute tasks.m (fun () -> tasks.test_cancel_trigger <- None) + + let id_of_handle task_handle = task_handle.id + + (* [add dbg f] creates a fresh [t], registers and returns it *) + let add tasks dbg (f : task_handle -> Interface.Task.async_result option) = + let t = + { + tasks + ; id= next_task_id () + ; ctime= Unix.gettimeofday () + ; dbg + ; state= Interface.Task.Pending 0. + ; subtasks= [] + ; f + ; tm= Mutex.create () + ; cancelling= false + ; cancel= [] + ; cancel_points_seen= 0 + ; test_cancel_at= + ( match tasks.test_cancel_trigger with + | Some (dbg', n) when dbg = dbg' -> + (* one shot *) + clear_cancel_trigger tasks ; Some n + | _ -> + None + ) + ; backtrace= Backtrace.empty + ; cancellable= true + } + in + Mutex.execute tasks.m (fun () -> + tasks.task_map := SMap.add t.id t !(tasks.task_map)) ; + t + + (* [run t] executes the task body, updating the fields of [t] *) + let run item = + try + let start = Unix.gettimeofday () in + let result = item.f item in + let duration = Unix.gettimeofday () -. start in + item.state <- Interface.Task.Completed {Interface.Task.duration; result} ; + debug "Task %s completed; duration = %.0f" item.id duration + with e -> + Backtrace.is_important e ; + error "Task %s failed; %s" item.id (Printexc.to_string e) ; + item.backtrace <- Backtrace.remove e ; + let e = e |> Interface.marshal_exn in + item.state <- Interface.Task.Failed e + + let find_locked tasks id = + try SMap.find id !(tasks.task_map) + with _ -> raise (Interface.does_not_exist ("task", id)) + + let to_interface_task t = + { + Interface.Task.id= t.id + ; dbg= t.dbg + ; ctime= t.ctime + ; state= t.state + ; subtasks= t.subtasks + ; debug_info= [("cancel_points_seen", string_of_int t.cancel_points_seen)] + ; backtrace= Sexplib.Sexp.to_string (Backtrace.sexp_of_t t.backtrace) + ; cancellable= t.cancellable + } + + let handle_of_id tasks id = + Mutex.execute tasks.m (fun () -> find_locked tasks id) + + let get_state task = task.state + + let set_state task state = task.state <- state + + let get_dbg task_handle = task_handle.dbg + + let replace_assoc key new_value existing = + (key, new_value) :: List.filter (fun (k, _) -> k <> key) existing + + let with_subtask t name f = + let start = Unix.gettimeofday () in + try + t.subtasks <- (name, Interface.Task.Pending 0.) :: t.subtasks ; + let result = f () in + let duration = Unix.gettimeofday () -. start in + t.subtasks <- + replace_assoc name + (Interface.Task.Completed {Interface.Task.duration; result= None}) + t.subtasks ; + result + with e -> + Backtrace.is_important e ; + let e' = Interface.marshal_exn e in + t.subtasks <- replace_assoc name (Interface.Task.Failed e') t.subtasks ; + raise e + + let list tasks = + Mutex.execute tasks.m (fun () -> + SMap.bindings !(tasks.task_map) |> List.map snd) + + (* Remove the task from the id -> task mapping. NB any active thread will + still continue. *) + let destroy task = + let tasks = task.tasks in + Mutex.execute tasks.m (fun () -> + tasks.task_map := SMap.remove task.id !(tasks.task_map)) + + let cancel task = + let callbacks = + Mutex.execute task.tm (fun () -> + if not task.cancellable then ( + info "Task %s is not cancellable." task.id ; + [] + ) else ( + task.cancelling <- true ; + task.cancel + )) + in + List.iter + (fun f -> + try f () + with e -> + debug "Task.cancel %s: ignore exception %s" task.id + (Printexc.to_string e)) + callbacks + + let raise_cancelled task = + info "Task %s has been cancelled: raising Cancelled exception" task.id ; + raise (Interface.cancelled task.id) + + let check_cancelling_locked task = + task.cancel_points_seen <- task.cancel_points_seen + 1 ; + if task.cancelling then raise_cancelled task ; + Option.iter + (fun x -> + if task.cancel_points_seen = x then ( + info + "Task %s has been triggered by the test-case (cancel_point = %d)" + task.id task.cancel_points_seen ; + raise_cancelled task + )) + task.test_cancel_at + + let check_cancelling t = + Mutex.execute t.tm (fun () -> check_cancelling_locked t) + + let with_cancel t cancel_fn f = + Mutex.execute t.tm (fun () -> + try + check_cancelling_locked t ; + t.cancel <- cancel_fn :: t.cancel + with e -> + ( try cancel_fn () + with e -> + debug "Task.cancel %s: ignore exception %s" t.id + (Printexc.to_string e) + ) ; + raise e) ; + finally + (fun () -> check_cancelling t ; f ()) + (fun () -> Mutex.execute t.tm (fun () -> t.cancel <- List.tl t.cancel)) + + let prohibit_cancellation task = + Mutex.execute task.tm (fun () -> + (* If task is cancelling, just cancel it before setting it to not + cancellable *) + check_cancelling_locked task ; + task.cancellable <- false) + end diff --git a/lib/task_server.mli b/lib/task_server.mli index 28a1a463..5ab32947 100644 --- a/lib/task_server.mli +++ b/lib/task_server.mli @@ -1,106 +1,116 @@ -(* Task_server: Helper for interfaces of a particular shape - * - * This module is a helper module for interfaces that implement a Task interface - * with which asynchronous calls are implemented. In particular, it handles - * subtasks, cancellation, reporting of backtraces and a way of injecting - * failures at particular points known as 'cancellation triggers' -*) +(* Task_server: Helper for interfaces of a particular shape * * This module is a + helper module for interfaces that implement a Task interface * with which + asynchronous calls are implemented. In particular, it handles * subtasks, + cancellation, reporting of backtraces and a way of injecting * failures at + particular points known as 'cancellation triggers' *) type stringpair = string * string -module type INTERFACE = -sig +module type INTERFACE = sig val service_name : string + val does_not_exist : stringpair -> exn + val cancelled : string -> exn + val marshal_exn : exn -> Rpc.t - module Task : - sig + module Task : sig type id = string + type async_result - type completion_t = { - duration : float; - result : async_result option; - } + + type completion_t = {duration: float; result: async_result option} + type state = - Pending of float + | Pending of float | Completed of completion_t | Failed of Rpc.t + type t = { - id: id; - dbg: string; - ctime: float; - state: state; - subtasks: (string * state) list; - debug_info: (string * string) list; - backtrace: string; - cancellable: bool; + id: id + ; dbg: string + ; ctime: float + ; state: state + ; subtasks: (string * state) list + ; debug_info: (string * string) list + ; backtrace: string + ; cancellable: bool } end end -module Task : - functor (Interface : INTERFACE) -> - sig +module Task : functor (Interface : INTERFACE) -> sig + (* An [id] is a marshallable reference to a task in a [tasks] type *) + type id = string - (* An [id] is a marshallable reference to a task in a [tasks] type *) - type id = string + (* A [task_handle] is required for all operations on tasks *) + type task_handle - (* A [task_handle] is required for all operations on tasks *) - type task_handle - - (* A [tasks] record contains a list of tasks *) - type tasks - - (* Operations on [tasks] *) - val empty : unit -> tasks - val list : tasks -> task_handle list - - (* After running [set_cancel_trigger tasks dbg n], the next task added with - matching [dbg] will be cancelled on the [n]th time it checks for cancellation *) - val set_cancel_trigger : tasks -> string -> int -> unit - val clear_cancel_trigger : tasks -> unit - - (* Convert between task_handle and id and Interface.Task.t *) - val id_of_handle : task_handle -> id - val handle_of_id : tasks -> id -> task_handle - val to_interface_task : task_handle -> Interface.Task.t - - (* [add tasks dbg f] adds a new task with debug string [dbg] that will execute [f] when run *) - val add : tasks -> string -> (task_handle -> Interface.Task.async_result option) -> task_handle - val run : task_handle -> unit - - (* Query/Set the current state/dbg key of a task *) - val get_state : task_handle -> Interface.Task.state - val set_state : task_handle -> Interface.Task.state -> unit - val get_dbg : task_handle -> string - - (* Given a task, record a specific subtask happening. Subtasks are just for - labelling subsections of a task, and there is no real task hierarchy. *) - val with_subtask : task_handle -> id -> (unit -> 'a) -> 'a - - (* Destroy removes the task from the [tasks] list *) - val destroy : task_handle -> unit - - (* Cancel attempts to cancel a task. This is a cooperative thing, - the task must check ifself whether it has been cancelled. However, any - cancel function passed in via [with_cancel] will be executed after the - task has been marked as cancelled *) - val cancel : task_handle -> unit - - (* This will raise the appropriate exception to record that the - currently executing task has been cancelled. Should be called within the - context of the function [f] from the [add] function call *) - val raise_cancelled : task_handle -> 'a - - (* Checks to see whether the task has been asked to cancel. Raises the - Cancelled exception if it has, or if it has hit the cancellation point - set *) - val check_cancelling : task_handle -> unit - - (* Sets a cancellation function to be called if the task is cancelled *) - val with_cancel : task_handle -> (unit -> unit) -> (unit -> 'a) -> 'a - (* Set a task not cancellable *) - val prohibit_cancellation: task_handle -> unit - end + (* A [tasks] record contains a list of tasks *) + type tasks + + (* Operations on [tasks] *) + val empty : unit -> tasks + + val list : tasks -> task_handle list + + (* After running [set_cancel_trigger tasks dbg n], the next task added with + matching [dbg] will be cancelled on the [n]th time it checks for + cancellation *) + val set_cancel_trigger : tasks -> string -> int -> unit + + val clear_cancel_trigger : tasks -> unit + + (* Convert between task_handle and id and Interface.Task.t *) + val id_of_handle : task_handle -> id + + val handle_of_id : tasks -> id -> task_handle + + val to_interface_task : task_handle -> Interface.Task.t + + (* [add tasks dbg f] adds a new task with debug string [dbg] that will execute + [f] when run *) + val add : + tasks + -> string + -> (task_handle -> Interface.Task.async_result option) + -> task_handle + + val run : task_handle -> unit + + (* Query/Set the current state/dbg key of a task *) + val get_state : task_handle -> Interface.Task.state + + val set_state : task_handle -> Interface.Task.state -> unit + + val get_dbg : task_handle -> string + + (* Given a task, record a specific subtask happening. Subtasks are just for + labelling subsections of a task, and there is no real task hierarchy. *) + val with_subtask : task_handle -> id -> (unit -> 'a) -> 'a + + (* Destroy removes the task from the [tasks] list *) + val destroy : task_handle -> unit + + (* Cancel attempts to cancel a task. This is a cooperative thing, the task + must check ifself whether it has been cancelled. However, any cancel + function passed in via [with_cancel] will be executed after the task has + been marked as cancelled *) + val cancel : task_handle -> unit + + (* This will raise the appropriate exception to record that the currently + executing task has been cancelled. Should be called within the context of + the function [f] from the [add] function call *) + val raise_cancelled : task_handle -> 'a + + (* Checks to see whether the task has been asked to cancel. Raises the + Cancelled exception if it has, or if it has hit the cancellation point set *) + val check_cancelling : task_handle -> unit + + (* Sets a cancellation function to be called if the task is cancelled *) + val with_cancel : task_handle -> (unit -> unit) -> (unit -> 'a) -> 'a + + (* Set a task not cancellable *) + val prohibit_cancellation : task_handle -> unit +end diff --git a/lib/updates.ml b/lib/updates.ml index cbdeab1a..1c011c64 100644 --- a/lib/updates.ml +++ b/lib/updates.ml @@ -1,7 +1,6 @@ (******************************************************************************) (* Object update tracking *) -open Xapi_stdext_monadic open Xapi_stdext_pervasives.Pervasiveext module type INTERFACE = sig @@ -9,225 +8,230 @@ module type INTERFACE = sig module Dynamic : sig type id + val rpc_of_id : id -> Rpc.t end end -module Updates = functor(Interface : INTERFACE) -> struct - - module UpdateRecorder = functor(Ord: Map.OrderedType) -> struct - (* Map of thing -> last update counter *) - module M = Map.Make(struct - type t = Ord.t - let compare = compare - end) - - type id = int - - (* Type for inner snapshot that we create when injecting a barrier *) - type barrier = { - bar_id: int; (* This int is a token from outside. *) - map_s: int M.t; (* Snapshot of main map *) - event_id: id (* Snapshot of "next" from when barrier was injected *) - } - - type t = { - map: int M.t; (* Events with incrementing ids from "next" *) - barriers: barrier list; - next: id - } - - let initial = 0 - - let empty = { - map = M.empty; - barriers = []; - next = initial + 1; - } - - let add x t = { - map = M.add x t.next t.map; - barriers = t.barriers; - next = t.next + 1 - }, t.next + 1 - - let remove x t = { - map = M.remove x t.map; - barriers = t.barriers; - next = t.next + 1 - }, t.next + 1 - - let filter f t = { - map = M.filter f t.map; - barriers = t.barriers; - next = t.next + 1 - }, t.next + 1 - - let inject_barrier id filterfn t = { - map = t.map; - barriers = { - bar_id = id; - map_s = M.filter filterfn t.map; - event_id = t.next - }::t.barriers; - next = t.next + 1 - }, t.next + 1 - - let remove_barrier id t = { - map = t.map; - barriers = List.filter (fun br -> br.bar_id <> id) t.barriers; - next = t.next + 1 - }, t.next + 1 - - let get from t = - (* [from] is the id of the most recent event already seen *) - let get_from_map map = - let _before, after = M.partition (fun _ time -> time <= from) map in - let xs, last = M.fold (fun key v (acc, m) -> (key, v) :: acc, max m v) after ([], from) in - let xs = List.sort (fun (_, v1) (_, v2) -> compare v1 v2) xs - |> List.map fst - in - xs, last +module Updates = +functor + (Interface : INTERFACE) + -> + struct + module UpdateRecorder = + functor + (Ord : Map.OrderedType) + -> + struct + (* Map of thing -> last update counter *) + module M = Map.Make (struct + type t = Ord.t + + let compare = compare + end) + + type id = int + + (* Type for inner snapshot that we create when injecting a barrier *) + type barrier = { + bar_id: int (** This int is a token from outside. *) + ; map_s: int M.t (** Snapshot of main map *) + ; event_id: id + (** Snapshot of "next" from when barrier was injected *) + } + + type t = { + map: int M.t (** Events with incrementing ids from "next" *) + ; barriers: barrier list + ; next: id + } + + let initial = 0 + + let empty = {map= M.empty; barriers= []; next= initial + 1} + + let add x t = + ( {map= M.add x t.next t.map; barriers= t.barriers; next= t.next + 1} + , t.next + 1 ) + + let remove x t = + ( {map= M.remove x t.map; barriers= t.barriers; next= t.next + 1} + , t.next + 1 ) + + let filter f t = + ( {map= M.filter f t.map; barriers= t.barriers; next= t.next + 1} + , t.next + 1 ) + + let inject_barrier id filterfn t = + ( { + map= t.map + ; barriers= + {bar_id= id; map_s= M.filter filterfn t.map; event_id= t.next} + :: t.barriers + ; next= t.next + 1 + } + , t.next + 1 ) + + let remove_barrier id t = + ( { + map= t.map + ; barriers= List.filter (fun br -> br.bar_id <> id) t.barriers + ; next= t.next + 1 + } + , t.next + 1 ) + + let get from t = + (* [from] is the id of the most recent event already seen *) + let get_from_map map = + let _before, after = M.partition (fun _ time -> time <= from) map in + let xs, last = + M.fold + (fun key v (acc, m) -> ((key, v) :: acc, max m v)) + after ([], from) + in + let xs = + List.sort (fun (_, v1) (_, v2) -> compare v1 v2) xs + |> List.map fst + in + (xs, last) + in + let rec filter_barriers bl acc = + match bl with + (* Stops at first too-old one, unlike List.filter *) + | x :: xs when x.event_id > from -> + filter_barriers xs (x :: acc) + | _ -> + List.rev acc + in + let recent_b = filter_barriers t.barriers [] in + let barriers = + List.map + (fun br -> (br.bar_id, get_from_map br.map_s |> fst)) + recent_b + in + let rest, last_event = get_from_map t.map in + let last = + match recent_b with + (* assumes recent_b is sorted newest-first *) + | [] -> + last_event + | x :: _ -> + max last_event x.event_id + in + (* Barriers are stored newest-first, reverse to return them in order *) + (List.rev barriers, rest, last) + + let last_id t = t.next - 1 + + (* let fold f t init = M.fold f t.map init *) + end + + open Xapi_stdext_threads.Threadext + + module U = UpdateRecorder (struct + type t = Interface.Dynamic.id + + let compare = compare + end) + + type id = U.id + + type t = {mutable u: U.t; c: Condition.t; s: Scheduler.t; m: Mutex.t} + + let empty scheduler = + {u= U.empty; c= Condition.create (); s= scheduler; m= Mutex.create ()} + + type get_result = + (int * Interface.Dynamic.id list) list * Interface.Dynamic.id list * id + + let get dbg ?(with_cancel = fun _ f -> f ()) from timeout t = + let from = Option.value ~default:U.initial from in + let cancel = ref false in + let cancel_fn () = + Mutex.execute t.m (fun () -> + cancel := true ; + Condition.broadcast t.c) in - let rec filter_barriers bl acc = - match bl with (* Stops at first too-old one, unlike List.filter *) - | x::xs when (x.event_id > from) -> - filter_barriers xs (x::acc) - | _ -> List.rev acc + let id = + Option.map + (fun timeout -> + Scheduler.one_shot t.s (Scheduler.Delta timeout) dbg cancel_fn) + timeout in - let recent_b = filter_barriers t.barriers [] in - let barriers = List.map (fun (br) -> (br.bar_id,get_from_map br.map_s |> fst)) recent_b in - let rest,last_event = get_from_map t.map in - let last = match recent_b with - (* assumes recent_b is sorted newest-first *) - | [] -> last_event - | x::_ -> max last_event x.event_id in - (* Barriers are stored newest-first, reverse to return them in order *) - (List.rev barriers, rest, last) - - let last_id t = t.next - 1 - -(* let fold f t init = M.fold f t.map init *) - end - - open Xapi_stdext_threads.Threadext - - module U = UpdateRecorder(struct type t = Interface.Dynamic.id let compare = compare end) - - type id = U.id - - type t = { - mutable u: U.t; - c: Condition.t; - s: Scheduler.t; - m: Mutex.t; - } - - let empty scheduler = { - u = U.empty; - c = Condition.create (); - s = scheduler; - m = Mutex.create (); - } - - type get_result = - (int * Interface.Dynamic.id list) list * Interface.Dynamic.id list * id - - let get dbg ?(with_cancel=(fun _ f -> f ())) from timeout t = - let from = Opt.default U.initial from in - let cancel = ref false in - let cancel_fn () = - Mutex.execute t.m - (fun () -> - cancel := true; - Condition.broadcast t.c - ) - in - let id = Opt.map (fun timeout -> - Scheduler.one_shot t.s (Scheduler.Delta timeout) dbg cancel_fn - ) timeout in - with_cancel cancel_fn (fun () -> - finally (fun () -> - Mutex.execute t.m (fun () -> - let is_empty (x,y,_) = x=[] && y=[] in - - let rec wait () = - let result = U.get from t.u in - if is_empty result && not (!cancel) then - begin Condition.wait t.c t.m; wait () end - else result - in - wait () - ) - ) (fun () -> Opt.iter (Scheduler.cancel t.s) id)) - - let last_id _dbg t = - Mutex.execute t.m - (fun () -> - U.last_id t.u - ) - - let add x t = - Mutex.execute t.m - (fun () -> - let result, _id = U.add x t.u in - t.u <- result; - Condition.broadcast t.c - ) - - let remove x t = - Mutex.execute t.m - (fun () -> - let result, _id = U.remove x t.u in - t.u <- result; - Condition.broadcast t.c - ) - - let filter f t = - Mutex.execute t.m - (fun () -> - let result, _id = U.filter (fun x _y -> f x) t.u in - t.u <- result; - Condition.broadcast t.c - ) - - let inject_barrier id filter t = - Mutex.execute t.m - (fun () -> - let result, _id = U.inject_barrier id filter t.u in - t.u <- result; - Condition.broadcast t.c) - - let remove_barrier id t = - Mutex.execute t.m - (fun () -> - let result, _id = U.remove_barrier id t.u in - t.u <- result; - Condition.broadcast t.c) - - module Dump = struct - type u = { - id: int; - v: string; - } [@@deriving rpc] - type dump = { - updates: u list; - barriers : (int * int * (u list)) list; - (* In barriers, first int is token id of barrier; - * second int is event id of snapshot (from "next") *) - } [@@deriving rpc] - let make_list updates = - U.M.fold (fun key v acc -> { id = v; v = (key |> Interface.Dynamic.rpc_of_id |> Jsonrpc.to_string) } :: acc) updates [] - let make_raw u = - { updates = make_list u.U.map; - barriers = List.map (fun (br) -> (br.U.bar_id, br.U.event_id, make_list br.U.map_s)) u.U.barriers; + with_cancel cancel_fn (fun () -> + finally + (fun () -> + Mutex.execute t.m (fun () -> + let is_empty (x, y, _) = x = [] && y = [] in + let rec wait () = + let result = U.get from t.u in + if is_empty result && not !cancel then ( + Condition.wait t.c t.m ; wait () + ) else + result + in + wait ())) + (fun () -> Option.iter (Scheduler.cancel t.s) id)) + + let last_id _dbg t = Mutex.execute t.m (fun () -> U.last_id t.u) + + let add x t = + Mutex.execute t.m (fun () -> + let result, _id = U.add x t.u in + t.u <- result ; + Condition.broadcast t.c) + + let remove x t = + Mutex.execute t.m (fun () -> + let result, _id = U.remove x t.u in + t.u <- result ; + Condition.broadcast t.c) + + let filter f t = + Mutex.execute t.m (fun () -> + let result, _id = U.filter (fun x _y -> f x) t.u in + t.u <- result ; + Condition.broadcast t.c) + + let inject_barrier id filter t = + Mutex.execute t.m (fun () -> + let result, _id = U.inject_barrier id filter t.u in + t.u <- result ; + Condition.broadcast t.c) + + let remove_barrier id t = + Mutex.execute t.m (fun () -> + let result, _id = U.remove_barrier id t.u in + t.u <- result ; + Condition.broadcast t.c) + + module Dump = struct + type u = {id: int; v: string} [@@deriving rpc] + + type dump = { + updates: u list + ; barriers: (int * int * u list) list + (* In barriers, first int is token id of barrier; second int is + event id of snapshot (from "next") *) } - let make t = - Mutex.execute t.m - (fun () -> - make_raw t.u - ) + [@@deriving rpc] + + let make_list updates = + U.M.fold + (fun key v acc -> + {id= v; v= key |> Interface.Dynamic.rpc_of_id |> Jsonrpc.to_string} + :: acc) + updates [] + + let make_raw u = + { + updates= make_list u.U.map + ; barriers= + List.map + (fun br -> (br.U.bar_id, br.U.event_id, make_list br.U.map_s)) + u.U.barriers + } + + let make t = Mutex.execute t.m (fun () -> make_raw t.u) + end end - - -end diff --git a/lib/updates.mli b/lib/updates.mli index 7e31d982..a054c558 100644 --- a/lib/updates.mli +++ b/lib/updates.mli @@ -1,83 +1,85 @@ -(** This module is a helper for interfaces of a particular shape. - * - * The idea is that updates are generated by a component when another - * component should be notified of events. For example, when a VM changes - * state, xenopsd uses this interface so that xapi knows something has - * changed. The updates contain no information other than that something - * has changed, so additionally the interface needs to have some sort of - * mechanism for querying the current state of the object in question. - * - * This module provides functions for adding updates, adding barriers - * (which contain a snapshot of the current updates), and a blocking call to - * that returns the latest set of updates, optionally given a token that - * represents the last set of updates received. -*) - -module type INTERFACE = -sig +(** This module is a helper for interfaces of a particular shape. * * The idea + is that updates are generated by a component when another * component should + be notified of events. For example, when a VM changes * state, xenopsd uses + this interface so that xapi knows something has * changed. The updates + contain no information other than that something * has changed, so + additionally the interface needs to have some sort of * mechanism for + querying the current state of the object in question. * * This module + provides functions for adding updates, adding barriers * (which contain a + snapshot of the current updates), and a blocking call to * that returns the + latest set of updates, optionally given a token that * represents the last + set of updates received. *) + +module type INTERFACE = sig val service_name : string - module Dynamic : - sig type id val rpc_of_id : id -> Rpc.t end + + module Dynamic : sig + type id + + val rpc_of_id : id -> Rpc.t + end end -module Updates : - functor (Interface : INTERFACE) -> - sig - type id = int - - (* Updates are kept in a `t` *) - type t - - (* Create an empty updates recorder using the given scheduler *) - val empty : Scheduler.t -> t - - (* last_id [dbg] [t] returns the last id that's in use in [t] *) - val last_id : string -> t -> int - - (* The return type for `get`. Returns a list of barriers, then a list of updates, then a token - to pass to the next invocation of `get` *) - type get_result = (int * Interface.Dynamic.id list) list * Interface.Dynamic.id list * id - - (* [get dbg ?with_cancel from timeout t] is a blocking call that will return all the updates - recorded in [t] since [from] (or for all time if [from] is None). [timeout], if it is - not None, is the timeout in seconds to wait. [dbg] is a debug string. [with_cancel] is - a function passed in that allows this call to be cancelled. See Task_server.with_cancel - for an example function that may be used *) - val get : - string -> - ?with_cancel:((unit -> unit) -> - (unit -> get_result) -> get_result) -> - id option -> - int option -> t -> get_result - - (* Add an update to a particular type of item (e.g. 'VM' or 'VBD', defined in INTERFACE) *) - val add : Interface.Dynamic.id -> t -> unit - - (* Remove an update *) - val remove : Interface.Dynamic.id -> t -> unit - - (* Filter updates to remove those that don't satisfy the predicate passed in *) - val filter : (Interface.Dynamic.id -> bool) -> t -> unit - - (* [inject_barrier n p t] Inject a barrier identified by [n] into [t]. The barrier will contain a - snapshot of all current updates that match the predicate [p]. *) - val inject_barrier : int -> (Interface.Dynamic.id -> int -> bool) -> t -> unit - - (* Removes a barrier *) - val remove_barrier : int -> t -> unit - - (* The Dump module is to dump the internal state of the Updates value for debugging - purposes *) - module Dump : - sig - type u = { id : int; v : string; } - type dump = { - updates : u list; - barriers : (int * int * u list) list; - } - val rpc_of_dump : dump -> Rpc.t - val dump_of_rpc : Rpc.t -> dump - val make : t -> dump - end +module Updates : functor (Interface : INTERFACE) -> sig + type id = int + + (* Updates are kept in a `t` *) + type t + + (* Create an empty updates recorder using the given scheduler *) + val empty : Scheduler.t -> t + + (* last_id [dbg] [t] returns the last id that's in use in [t] *) + val last_id : string -> t -> int + + (* The return type for `get`. Returns a list of barriers, then a list of + updates, then a token to pass to the next invocation of `get` *) + type get_result = + (int * Interface.Dynamic.id list) list * Interface.Dynamic.id list * id + + (* [get dbg ?with_cancel from timeout t] is a blocking call that will return + all the updates recorded in [t] since [from] (or for all time if [from] is + None). [timeout], if it is not None, is the timeout in seconds to wait. + [dbg] is a debug string. [with_cancel] is a function passed in that allows + this call to be cancelled. See Task_server.with_cancel for an example + function that may be used *) + val get : + string + -> ?with_cancel:((unit -> unit) -> (unit -> get_result) -> get_result) + -> id option + -> int option + -> t + -> get_result + + (* Add an update to a particular type of item (e.g. 'VM' or 'VBD', defined in + INTERFACE) *) + val add : Interface.Dynamic.id -> t -> unit + (* Remove an update *) + val remove : Interface.Dynamic.id -> t -> unit + + (* Filter updates to remove those that don't satisfy the predicate passed in *) + val filter : (Interface.Dynamic.id -> bool) -> t -> unit + + (* [inject_barrier n p t] Inject a barrier identified by [n] into [t]. The + barrier will contain a snapshot of all current updates that match the + predicate [p]. *) + val inject_barrier : int -> (Interface.Dynamic.id -> int -> bool) -> t -> unit + + (* Removes a barrier *) + val remove_barrier : int -> t -> unit + + (* The Dump module is to dump the internal state of the Updates value for + debugging purposes *) + module Dump : sig + type u = {id: int; v: string} + + type dump = {updates: u list; barriers: (int * int * u list) list} + + val rpc_of_dump : dump -> Rpc.t + + val dump_of_rpc : Rpc.t -> dump + + val make : t -> dump end +end diff --git a/lib/xcp_channel.ml b/lib/xcp_channel.ml index fa07fede..395da851 100644 --- a/lib/xcp_channel.ml +++ b/lib/xcp_channel.ml @@ -1,9 +1,11 @@ type t = Unix.file_descr let file_descr_of_t t = t + let t_of_file_descr t = t [@@@ocaml.warning "-34"] + type protocols = Xcp_channel_protocol.t list [@@deriving rpc] let rpc_of_t fd = @@ -13,4 +15,3 @@ let rpc_of_t fd = let t_of_rpc x = let protocols = protocols_of_rpc x in Posix_channel.receive protocols - diff --git a/lib/xcp_channel.mli b/lib/xcp_channel.mli index 6bb96802..35849a1e 100644 --- a/lib/xcp_channel.mli +++ b/lib/xcp_channel.mli @@ -1,10 +1,13 @@ type t -val rpc_of_t: t -> Rpc.t -val t_of_rpc: Rpc.t -> t +val rpc_of_t : t -> Rpc.t -val file_descr_of_t: t -> Unix.file_descr -val t_of_file_descr: Unix.file_descr -> t +val t_of_rpc : Rpc.t -> t -val protocols_of_rpc: Rpc.t -> Xcp_channel_protocol.t list -val rpc_of_protocols: Xcp_channel_protocol.t list -> Rpc.t +val file_descr_of_t : t -> Unix.file_descr + +val t_of_file_descr : Unix.file_descr -> t + +val protocols_of_rpc : Rpc.t -> Xcp_channel_protocol.t list + +val rpc_of_protocols : Xcp_channel_protocol.t list -> Rpc.t diff --git a/lib/xcp_channel_protocol.ml b/lib/xcp_channel_protocol.ml index f321484a..76730ba4 100644 --- a/lib/xcp_channel_protocol.ml +++ b/lib/xcp_channel_protocol.ml @@ -13,9 +13,7 @@ *) type t = - | TCP_proxy of string * int (** IP, port *) - | V4V_proxy of int * int (** domid, port *) - | Unix_sendmsg of int * string * string (** domid, path, token *) + | TCP_proxy of string * int (** IP, port *) + | V4V_proxy of int * int (** domid, port *) + | Unix_sendmsg of int * string * string (** domid, path, token *) [@@deriving rpc] - - diff --git a/lib/xcp_channel_protocol.mli b/lib/xcp_channel_protocol.mli index a432b2ff..4751e484 100644 --- a/lib/xcp_channel_protocol.mli +++ b/lib/xcp_channel_protocol.mli @@ -13,10 +13,10 @@ *) type t = - | TCP_proxy of string * int (** IP, port *) - | V4V_proxy of int * int (** domid, port *) - | Unix_sendmsg of int * string * string (** domid, path, token *) + | TCP_proxy of string * int (** IP, port *) + | V4V_proxy of int * int (** domid, port *) + | Unix_sendmsg of int * string * string (** domid, path, token *) -val rpc_of_t: t -> Rpc.t -val t_of_rpc: Rpc.t -> t +val rpc_of_t : t -> Rpc.t +val t_of_rpc : Rpc.t -> t diff --git a/lib/xcp_client.ml b/lib/xcp_client.ml index fafc8eba..de040270 100644 --- a/lib/xcp_client.ml +++ b/lib/xcp_client.ml @@ -14,91 +14,115 @@ (* Generic RPC marshalling functions for XCP services *) -module Request = Cohttp.Request.Make(Cohttp_posix_io.Buffered_IO) -module Response = Cohttp.Response.Make(Cohttp_posix_io.Buffered_IO) +module Request = Cohttp.Request.Make (Cohttp_posix_io.Buffered_IO) +module Response = Cohttp.Response.Make (Cohttp_posix_io.Buffered_IO) let get_user_agent () = Sys.argv.(0) let switch_path = ref "/var/run/message-switch/sock" + let use_switch = ref true let get_ok = function - | `Ok x -> x - | `Error e -> + | Ok x -> + x + | Error e -> let b = Buffer.create 16 in let fmt = Format.formatter_of_buffer b in - Message_switch_unix.Protocol_unix.Client.pp_error fmt e; - Format.pp_print_flush fmt (); + Message_switch_unix.Protocol_unix.Client.pp_error fmt e ; + Format.pp_print_flush fmt () ; failwith (Buffer.contents b) let switch_rpc ?timeout queue_name string_of_call response_of_string = - let t = get_ok (Message_switch_unix.Protocol_unix.Client.connect ~switch:!switch_path ()) in - fun call -> - response_of_string (get_ok (Message_switch_unix.Protocol_unix.Client.rpc ~t ?timeout ~queue:queue_name ~body:(string_of_call call) ())) + let t = + get_ok + (Message_switch_unix.Protocol_unix.Client.connect ~switch:!switch_path ()) + in + fun call -> + response_of_string + (get_ok + (Message_switch_unix.Protocol_unix.Client.rpc ~t ?timeout + ~queue:queue_name ~body:(string_of_call call) ())) let split_colon str = try let x = String.index str ':' in let uname = String.sub str 0 x in - let passwd = String.sub str (x+1) (String.length str - x - 1) in - [uname ; passwd] - with Not_found -> - [str] + let passwd = String.sub str (x + 1) (String.length str - x - 1) in + [uname; passwd] + with Not_found -> [str] (* Use HTTP to frame RPC messages *) [@@@ocaml.warning "-27"] -let http_rpc string_of_call response_of_string ?(srcstr="unset") ?(dststr="unset") url call = - let uri = Uri.of_string (url ()) in - let req = string_of_call call in - - let headers = Cohttp.Header.of_list [ - "User-agent", get_user_agent (); - "content-length", string_of_int (String.length req); - ] in - (* If we have a username:password@ then use basic authentication *) - let userinfo = Uri.userinfo uri in - let headers = match userinfo with - | Some x -> - begin match split_colon x with - | username :: password :: [] -> - Cohttp.Header.add_authorization headers (`Basic (username, password)) - | _ -> headers - end - | None -> headers in - - let http_req = Cohttp.Request.make ~meth:`POST ~version:`HTTP_1_1 ~headers uri in +let http_rpc string_of_call response_of_string ?(srcstr = "unset") + ?(dststr = "unset") url call = + let uri = Uri.of_string (url ()) in + let req = string_of_call call in + let headers = + Cohttp.Header.of_list + [ + ("User-agent", get_user_agent ()) + ; ("content-length", string_of_int (String.length req)) + ] + in + (* If we have a username:password@ then use basic authentication *) + let userinfo = Uri.userinfo uri in + let headers = + match userinfo with + | Some x -> ( + match split_colon x with + | [username; password] -> + Cohttp.Header.add_authorization headers (`Basic (username, password)) + | _ -> + headers + ) + | None -> + headers + in + let http_req = + Cohttp.Request.make ~meth:`POST ~version:`HTTP_1_1 ~headers uri + in + Open_uri.with_open_uri uri (fun 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 req) http_req oc ; + match Response.read ic with + | `Eof -> + failwith + (Printf.sprintf "Failed to read HTTP response from: %s" (url ())) + | `Invalid x -> + failwith + (Printf.sprintf "Failed to read HTTP response from: %s (got '%s')" + (url ()) x) + | `Ok response -> ( + let body = Buffer.create 16 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 () ; + let body = Buffer.contents body |> response_of_string in + match Cohttp.Response.status response with + | `OK -> + body + | bad -> + failwith + (Printf.sprintf "Unexpected HTTP response code: %s" + (Cohttp.Code.string_of_status bad)) + )) - Open_uri.with_open_uri uri - (fun 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 req) http_req oc; - match Response.read ic with - | `Eof -> failwith (Printf.sprintf "Failed to read HTTP response from: %s" (url ())) - | `Invalid x -> failwith (Printf.sprintf "Failed to read HTTP response from: %s (got '%s')" (url ()) x) - | `Ok response -> - let body = Buffer.create 16 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 (); - let body = Buffer.contents body |> response_of_string in - begin match Cohttp.Response.status response with - | `OK -> body - | bad -> failwith (Printf.sprintf "Unexpected HTTP response code: %s" (Cohttp.Code.string_of_status bad)) - end - ) let xml_http_rpc = http_rpc Xmlrpc.string_of_call Xmlrpc.response_of_string -let json_switch_rpc ?timeout queue_name = switch_rpc ?timeout queue_name Jsonrpc.string_of_call Jsonrpc.response_of_string + +let json_switch_rpc ?timeout queue_name = + switch_rpc ?timeout queue_name Jsonrpc.string_of_call + Jsonrpc.response_of_string let () = Printexc.register_printer (function @@ -106,28 +130,30 @@ let () = Some (Printf.sprintf "Xmlm.Error(%d:%d, \"%s\")" line col (Xmlm.error_message error)) - | _ -> None ) + | _ -> + None) (* Use a binary 16-byte length to frame RPC messages *) -let binary_rpc string_of_call response_of_string ?(srcstr="unset") ?(dststr="unset") url (call: Rpc.call) : Rpc.response = - let uri = Uri.of_string (url ()) in - Open_uri.with_open_uri uri - (fun fd -> - let ic = Unix.in_channel_of_descr fd in - let oc = Unix.out_channel_of_descr fd in - let msg_buf = string_of_call call in - let len = Printf.sprintf "%016d" (String.length msg_buf) in - output_string oc len; - output_string oc msg_buf; - flush oc; - let len_buf = Bytes.make 16 '\000' in - really_input ic len_buf 0 16; - let len = int_of_string (Bytes.unsafe_to_string len_buf) in - let msg_buf = Bytes.make len '\000' in - really_input ic msg_buf 0 len; - let (response: Rpc.response) = response_of_string (Bytes.unsafe_to_string msg_buf) in - response - ) - -let json_binary_rpc = binary_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string - +let binary_rpc string_of_call response_of_string ?(srcstr = "unset") + ?(dststr = "unset") url (call : Rpc.call) : Rpc.response = + let uri = Uri.of_string (url ()) in + Open_uri.with_open_uri uri (fun fd -> + let ic = Unix.in_channel_of_descr fd in + let oc = Unix.out_channel_of_descr fd in + let msg_buf = string_of_call call in + let len = Printf.sprintf "%016d" (String.length msg_buf) in + output_string oc len ; + output_string oc msg_buf ; + flush oc ; + let len_buf = Bytes.make 16 '\000' in + really_input ic len_buf 0 16 ; + let len = int_of_string (Bytes.unsafe_to_string len_buf) in + let msg_buf = Bytes.make len '\000' in + really_input ic msg_buf 0 len ; + let (response : Rpc.response) = + response_of_string (Bytes.unsafe_to_string msg_buf) + in + response) + +let json_binary_rpc = + binary_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string diff --git a/lib/xcp_const.ml b/lib/xcp_const.ml index 81aee064..1e6cfdff 100644 --- a/lib/xcp_const.ml +++ b/lib/xcp_const.ml @@ -1 +1,6 @@ -let good_ciphersuites = "ECDHE-RSA-AES256-SHA384:ECDHE-RSA-AES256-GCM-SHA384:AES256-SHA256:AES128-SHA256" +let good_ciphersuites = + String.concat ":" + [ + "ECDHE-RSA-AES256-GCM-SHA384" + ; "ECDHE-RSA-AES128-GCM-SHA256" + ] diff --git a/lib/xcp_coverage.mli b/lib/xcp_coverage.mli deleted file mode 100644 index 0eaaea0b..00000000 --- a/lib/xcp_coverage.mli +++ /dev/null @@ -1,17 +0,0 @@ -(* The build system chooses either 'coverage/enabled.ml' or - * 'coverage/disabled.ml' as an implementation. - * Executables need to make exactly one call to exactly one of - * [init], [dispatcher_init] or [Xcp_service.configure2]. - * *) - -(** [init name] sets up coverage profiling for binary [name]. You could - * use [Sys.argv.(0)] for [name]. - *) - -val init: string -> unit - -(** [dispatcher_init name] only initializes the toplevel coverage API dispatcher on a system. - * This is meant to be called only by XAPI, which will have to call both [init] - * and [dispatcher_init]. - *) -val dispatcher_init : string -> unit diff --git a/lib/xcp_pci.ml b/lib/xcp_pci.ml index 354d6294..bdeaf088 100644 --- a/lib/xcp_pci.ml +++ b/lib/xcp_pci.ml @@ -1,17 +1,12 @@ open Sexplib.Std -type address = { - domain: int; - bus: int; - dev: int; - fn: int; -} +type address = {domain: int; bus: int; dev: int; fn: int} [@@deriving sexp, rpc, rpcty] let address_of_string str = - Scanf.sscanf str "%04x:%02x:%02x.%x" - (fun domain bus dev fn -> {domain; bus; dev; fn}) + Scanf.sscanf str "%04x:%02x:%02x.%x" (fun domain bus dev fn -> + {domain; bus; dev; fn}) let string_of_address address = - Printf.sprintf "%04x:%02x:%02x.%x" - address.domain address.bus address.dev address.fn + Printf.sprintf "%04x:%02x:%02x.%x" address.domain address.bus address.dev + address.fn diff --git a/lib/xcp_service.ml b/lib/xcp_service.ml index c60ced4f..4a4cf9e7 100644 --- a/lib/xcp_service.ml +++ b/lib/xcp_service.ml @@ -11,424 +11,528 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -open Xapi_stdext_monadic -module StringSet = Set.Make(String) +module StringSet = Set.Make (String) (* Server configuration. We have built-in (hopefully) sensible defaults, - together with command-line arguments and a configuration file. They - are applied in order: (latest takes precedence) - defaults < arguments < config file -*) + together with command-line arguments and a configuration file. They are + applied in order: (latest takes precedence) defaults < arguments < config + file *) let default_service_name = Filename.basename Sys.argv.(0) + let config_file = ref (Printf.sprintf "/etc/%s.conf" default_service_name) + let config_dir = ref (Printf.sprintf "/etc/%s.conf.d" default_service_name) + let pidfile = ref (Printf.sprintf "/var/run/%s.pid" default_service_name) + let extra_search_path = ref [] + let log_destination = ref "syslog:daemon" + let log_level = ref Syslog.Debug + let daemon = ref false + let have_daemonized () = Unix.getppid () = 1 let common_prefix = "org.xen.xapi." let finally f g = - try - let result = f () in - g (); - result - with e -> - g (); - raise e + try + let result = f () in + g () ; result + with e -> g () ; raise e type opt = string * Arg.spec * (unit -> string) * string -module D = Debug.Make(struct let name = default_service_name end) +module D = Debug.Make (struct let name = default_service_name end) + open D module Config_file = struct - open Arg - - let apply v = function - | Unit f -> f () - | Bool f -> f (bool_of_string v) - | Set b -> b := (bool_of_string v) - | Clear b -> b := not (bool_of_string v) - | String f -> f v - | Set_string s -> s := v - | Int f -> f (int_of_string v) - | Set_int i -> i := (int_of_string v) - | Float f -> f (float_of_string v) - | Set_float f -> f := (float_of_string v) - | _ -> failwith "Unsupported type in config file" - - (* Trim trailing whitespace from a line *) - let trim_trailing_ws line = - let re_ws = Re.compile (Re.Emacs.re "[ \t]+$") in - try - let ofs = fst (Re.Group.all_offset (Re.exec re_ws line)).(0) in - String.sub line 0 ofs - with Not_found -> - line - - let trim_comment line = - try - let i = String.index line '#' in - String.sub line 0 i - with Not_found -> line - - let get_kv line = - let re = Re.compile (Re.Emacs.re "\\([^=\\ \t]+\\)[\\ \t]*=[\\ \t]*\\(.*\\)") in - let get (x,y) = String.sub line x (y-x) in - try - match Re.Group.all_offset (Re.exec re line) with - | [| _; key_ofs; v_ofs |] -> - (* First in array is always the full extent of all matches *) - Some (get key_ofs, get v_ofs) - | _ -> - None - with _ -> - None - - let strip_quotes (k,v) = - if String.length v < 2 - then (k,v) - else - let first = v.[0] and last = v.[String.length v - 1] in - if first = last && (first = '"' || first = '\'') - then (k,String.sub v 1 (String.length v - 2)) - else (k,v) - - let parse_line line = - (* Strip comments *) - let stripped = line |> trim_comment |> trim_trailing_ws in - let lift f x = Some (f x) in - let (>>=) m f = match m with Some x -> f x | None -> None in - get_kv stripped >>= lift strip_quotes - - let process_line data spec = - let spec = List.map (fun (a, b, _, _) -> a, b) spec in - match parse_line data with - | Some (key,v) -> - if List.mem_assoc key spec then apply v (List.assoc key spec) - | None -> () - - let parse filename spec = - (* Remove the unnecessary doc parameter *) - let ic = open_in filename in - finally - (fun () -> - try - while true do - let line = input_line ic in - process_line line spec - done - with End_of_file -> () - ) (fun () -> close_in ic) - - let dump spec = - List.iter (fun (name, _, printer, description) -> - debug "%s = %s (%s)" name (printer ()) description - ) spec - + open Arg + + let apply v = function + | Unit f -> + f () + | Bool f -> + f (bool_of_string v) + | Set b -> + b := bool_of_string v + | Clear b -> + b := not (bool_of_string v) + | String f -> + f v + | Set_string s -> + s := v + | Int f -> + f (int_of_string v) + | Set_int i -> + i := int_of_string v + | Float f -> + f (float_of_string v) + | Set_float f -> + f := float_of_string v + | _ -> + failwith "Unsupported type in config file" + + (* Trim trailing whitespace from a line *) + let trim_trailing_ws line = + let re_ws = Re.compile (Re.Emacs.re "[ \t]+$") in + try + let ofs = fst (Re.Group.all_offset (Re.exec re_ws line)).(0) in + String.sub line 0 ofs + with Not_found -> line + + let trim_comment line = + try + let i = String.index line '#' in + String.sub line 0 i + with Not_found -> line + + let get_kv line = + let re = + Re.compile (Re.Emacs.re "\\([^=\\ \t]+\\)[\\ \t]*=[\\ \t]*\\(.*\\)") + in + let get (x, y) = String.sub line x (y - x) in + try + match Re.Group.all_offset (Re.exec re line) with + | [|_; key_ofs; v_ofs|] -> + (* First in array is always the full extent of all matches *) + Some (get key_ofs, get v_ofs) + | _ -> + None + with _ -> None + + let strip_quotes (k, v) = + if String.length v < 2 then + (k, v) + else + let first = v.[0] and last = v.[String.length v - 1] in + if first = last && (first = '"' || first = '\'') then + (k, String.sub v 1 (String.length v - 2)) + else + (k, v) + + let parse_line line = + (* Strip comments *) + let stripped = line |> trim_comment |> trim_trailing_ws in + let lift f x = Some (f x) in + let ( >>= ) m f = match m with Some x -> f x | None -> None in + get_kv stripped >>= lift strip_quotes + + let process_line data spec = + let spec = List.map (fun (a, b, _, _) -> (a, b)) spec in + match parse_line data with + | Some (key, v) -> + if List.mem_assoc key spec then apply v (List.assoc key spec) + | None -> + () + + let parse filename spec = + (* Remove the unnecessary doc parameter *) + let ic = open_in filename in + finally + (fun () -> + try + while true do + let line = input_line ic in + process_line line spec + done + with End_of_file -> ()) + (fun () -> close_in ic) + + let dump spec = + List.iter + (fun (name, _, printer, description) -> + debug "%s = %s (%s)" name (printer ()) description) + spec end let rec split_c c str = try let i = String.index str c in - String.sub str 0 i :: (split_c c (String.sub str (i+1) (String.length str - i - 1))) + String.sub str 0 i + :: split_c c (String.sub str (i + 1) (String.length str - i - 1)) with Not_found -> [str] let setify = let rec loop acc = function - | [] -> acc - | x :: xs -> (if List.mem x acc then loop acc else loop (x :: acc)) xs in + | [] -> + acc + | x :: xs -> + (if List.mem x acc then loop acc else loop (x :: acc)) xs + in loop [] -let common_options = [ - "use-switch", Arg.Bool (fun b -> Xcp_client.use_switch := b), (fun () -> string_of_bool !Xcp_client.use_switch), "true if the message switch is to be enabled"; - "switch-path", Arg.Set_string Xcp_client.switch_path, (fun () -> !Xcp_client.switch_path), "Unix domain socket path on localhost where the message switch is listening"; - "search-path", Arg.String (fun s -> extra_search_path := (split_c ':' s) @ !extra_search_path), (fun () -> String.concat ":" !extra_search_path), "Search path for resources"; - "pidfile", Arg.Set_string pidfile, (fun () -> !pidfile), "Filename to write process PID"; - "log", Arg.Set_string log_destination, (fun () -> !log_destination), "Where to write log messages"; - "daemon", Arg.Bool (fun x -> daemon := x), (fun () -> string_of_bool !daemon), "True if we are to daemonise"; - "disable-logging-for", Arg.String - (fun x -> debug "Parsing [%s]" x; - try - let modules = List.filter (fun x -> x <> "") (split_c ' ' x) in - List.iter Debug.disable modules - with e -> - error "Processing disabled-logging-for = %s: %s" x (Printexc.to_string e) - ), (fun () -> String.concat " " (setify (List.map fst (Debug.disabled_modules ())))), "A space-separated list of debug modules to suppress logging from"; - - "loglevel", Arg.String - (fun x -> - debug "Parsing [%s]" x; - try - log_level := Syslog.level_of_string x; - Debug.set_level !log_level - with e -> - error "Processing loglevel = %s: %s" x (Printexc.to_string e)), - (fun () -> Syslog.string_of_level !log_level), "Log level"; - - "inventory", Arg.Set_string Inventory.inventory_filename, (fun () -> !Inventory.inventory_filename), "Location of the inventory file"; - "config", Arg.Set_string config_file, (fun () -> !config_file), "Location of configuration file"; - "config-dir", Arg.Set_string config_dir, (fun () -> !config_dir), "Location of directory containing configuration file fragments"; -] +let common_options = + [ + ( "use-switch" + , Arg.Bool (fun b -> Xcp_client.use_switch := b) + , (fun () -> string_of_bool !Xcp_client.use_switch) + , "true if the message switch is to be enabled" ) + ; ( "switch-path" + , Arg.Set_string Xcp_client.switch_path + , (fun () -> !Xcp_client.switch_path) + , "Unix domain socket path on localhost where the message switch is \ + listening" ) + ; ( "search-path" + , Arg.String + (fun s -> extra_search_path := split_c ':' s @ !extra_search_path) + , (fun () -> String.concat ":" !extra_search_path) + , "Search path for resources" ) + ; ( "pidfile" + , Arg.Set_string pidfile + , (fun () -> !pidfile) + , "Filename to write process PID" ) + ; ( "log" + , Arg.Set_string log_destination + , (fun () -> !log_destination) + , "Where to write log messages" ) + ; ( "daemon" + , Arg.Bool (fun x -> daemon := x) + , (fun () -> string_of_bool !daemon) + , "True if we are to daemonise" ) + ; ( "disable-logging-for" + , Arg.String + (fun x -> + debug "Parsing [%s]" x ; + try + let modules = List.filter (fun x -> x <> "") (split_c ' ' x) in + List.iter Debug.disable modules + with e -> + error "Processing disabled-logging-for = %s: %s" x + (Printexc.to_string e)) + , (fun () -> + String.concat " " (setify (List.map fst (Debug.disabled_modules ())))) + , "A space-separated list of debug modules to suppress logging from" ) + ; ( "loglevel" + , Arg.String + (fun x -> + debug "Parsing [%s]" x ; + try + log_level := Syslog.level_of_string x ; + Debug.set_level !log_level + with e -> + error "Processing loglevel = %s: %s" x (Printexc.to_string e)) + , (fun () -> Syslog.string_of_level !log_level) + , "Log level" ) + ; ( "inventory" + , Arg.Set_string Inventory.inventory_filename + , (fun () -> !Inventory.inventory_filename) + , "Location of the inventory file" ) + ; ( "config" + , Arg.Set_string config_file + , (fun () -> !config_file) + , "Location of configuration file" ) + ; ( "config-dir" + , Arg.Set_string config_dir + , (fun () -> !config_dir) + , "Location of directory containing configuration file fragments" ) + ] let loglevel () = !log_level module Term = Cmdliner.Term let rec list = function - | [] -> Term.pure [] - | x :: xs -> Term.app (Term.app (Term.pure (fun x y -> x :: y)) x) (list xs) + | [] -> + Term.pure [] + | x :: xs -> + Term.app (Term.app (Term.pure (fun x y -> x :: y)) x) (list xs) -let command_of ?(name = Sys.argv.(0)) ?(version = "unknown") ?(doc = "Please describe this command.") xs = +let command_of ?(name = Sys.argv.(0)) ?(version = "unknown") + ?(doc = "Please describe this command.") xs = let term_of_option (key, arg, get_fn, doc) = let default = get_fn () in match arg with | Arg.Unit f -> - let t = Cmdliner.Arg.(value & flag & info [ key ] ~doc) in - let make = function true -> f () | false -> () in - Term.(pure make $ t) + let t = Cmdliner.Arg.(value & flag & info [key] ~doc) in + let make = function true -> f () | false -> () in + Term.(pure make $ t) | Arg.Bool f -> - let t = Cmdliner.Arg.(value & opt bool (bool_of_string default) & info [ key ] ~doc) in - Term.(pure f $ t) + let t = + Cmdliner.Arg.( + value & opt bool (bool_of_string default) & info [key] ~doc) + in + Term.(pure f $ t) | Arg.Set b -> - let t = Cmdliner.Arg.(value & opt bool (bool_of_string default) & info [ key ] ~doc) in - let make v = b := v in - Term.(pure make $ t) + let t = + Cmdliner.Arg.( + value & opt bool (bool_of_string default) & info [key] ~doc) + in + let make v = b := v in + Term.(pure make $ t) | Arg.Clear b -> - let t = Cmdliner.Arg.(value & opt bool (bool_of_string default) & info [ key ] ~doc) in - let make v = b := not v in - Term.(pure make $ t) + let t = + Cmdliner.Arg.( + value & opt bool (bool_of_string default) & info [key] ~doc) + in + let make v = b := not v in + Term.(pure make $ t) | Arg.String f -> - let t = Cmdliner.Arg.(value & opt string default & info [ key ] ~doc) in - Term.(pure f $ t) + let t = Cmdliner.Arg.(value & opt string default & info [key] ~doc) in + Term.(pure f $ t) | Arg.Set_string s -> - let t = Cmdliner.Arg.(value & opt string default & info [ key ] ~doc) in - let make v = s := v in - Term.(pure make $ t) + let t = Cmdliner.Arg.(value & opt string default & info [key] ~doc) in + let make v = s := v in + Term.(pure make $ t) | Arg.Int f -> - let t = Cmdliner.Arg.(value & opt int (int_of_string default) & info [ key ] ~doc) in - Term.(pure f $ t) + let t = + Cmdliner.Arg.( + value & opt int (int_of_string default) & info [key] ~doc) + in + Term.(pure f $ t) | Arg.Set_int s -> - let t = Cmdliner.Arg.(value & opt int (int_of_string default) & info [ key ] ~doc) in - let make v = s := v in - Term.(pure make $ t) + let t = + Cmdliner.Arg.( + value & opt int (int_of_string default) & info [key] ~doc) + in + let make v = s := v in + Term.(pure make $ t) | Arg.Float f -> - let t = Cmdliner.Arg.(value & opt float (float_of_string default) & info [ key ] ~doc) in - Term.(pure f $ t) + let t = + Cmdliner.Arg.( + value & opt float (float_of_string default) & info [key] ~doc) + in + Term.(pure f $ t) | Arg.Set_float s -> - let t = Cmdliner.Arg.(value & opt float (float_of_string default) & info [ key ] ~doc) in - let make v = s := v in - Term.(pure make $ t) + let t = + Cmdliner.Arg.( + value & opt float (float_of_string default) & info [key] ~doc) + in + let make v = s := v in + Term.(pure make $ t) | _ -> - let t = Cmdliner.Arg.(value & opt string default & info [ key ] ~doc) in - let make v = Config_file.apply v arg in - Term.(pure make $ t) in + let t = Cmdliner.Arg.(value & opt string default & info [key] ~doc) in + let make v = Config_file.apply v arg in + Term.(pure make $ t) + in let terms = List.map term_of_option xs in - let _common_options = "COMMON OPTIONS" in - let man = [ - `S "DESCRIPTION"; - `P doc; - `S _common_options; - `P "These options are common to all services."; - `S "BUGS"; - `P "Check bug reports at http://github.com/xapi-project/xcp-idl"; - ] in - Term.(ret(pure (fun (_: unit list) -> `Ok ()) $ (list terms))), - Term.info name ~version ~sdocs:_common_options ~man - -let arg_spec = List.map (fun (a, b, _, c) -> "-" ^ a, b, c) + let man = + [ + `S "DESCRIPTION" + ; `P doc + ; `S _common_options + ; `P "These options are common to all services." + ; `S "BUGS" + ; `P "Check bug reports at http://github.com/xapi-project/xcp-idl" + ] + in + ( Term.(ret (pure (fun (_ : unit list) -> `Ok ()) $ list terms)) + , Term.info name ~version ~sdocs:_common_options ~man ) + +let arg_spec = List.map (fun (a, b, _, c) -> ("-" ^ a, b, c)) type res = { - name: string; - description: string; - essential: bool; - path: string ref; - perms: Unix.access_permission list + name: string + ; description: string + ; essential: bool + ; path: string ref + ; perms: Unix.access_permission list } -let default_resources = [ -] +let default_resources = [] let canonicalise x = - if not(Filename.is_relative x) - then x - else begin - (* Search the PATH and XCP_PATH for the executable *) - let paths = split_c ':' (Sys.getenv "PATH") in - let first_hit = List.fold_left (fun found path -> match found with - | Some _hit -> found - | None -> - let possibility = Filename.concat path x in - if Sys.file_exists possibility - then Some possibility - else None - ) None (paths @ !extra_search_path) in - match first_hit with - | None -> - warn "Failed to find %s on $PATH ( = %s) or search_path option ( = %s)" x (Sys.getenv "PATH") (String.concat ":" !extra_search_path); - x - | Some hit -> - info "Found '%s' at '%s'" x hit; - hit - end - -let to_opt = List.map (fun f -> f.name, Arg.String (fun x -> f.path := canonicalise x), (fun () -> !(f.path)), f.description) + if not (Filename.is_relative x) then + x + else (* Search the PATH and XCP_PATH for the executable *) + let paths = split_c ':' (Sys.getenv "PATH") in + let first_hit = + List.fold_left + (fun found path -> + match found with + | Some _hit -> + found + | None -> + let possibility = Filename.concat path x in + if Sys.file_exists possibility then Some possibility else None) + None + (paths @ !extra_search_path) + in + match first_hit with + | None -> + warn "Failed to find %s on $PATH ( = %s) or search_path option ( = %s)" + x (Sys.getenv "PATH") + (String.concat ":" !extra_search_path) ; + x + | Some hit -> + info "Found '%s' at '%s'" x hit ; + hit + +let to_opt = + List.map (fun f -> + ( f.name + , Arg.String (fun x -> f.path := canonicalise x) + , (fun () -> !(f.path)) + , f.description )) let read_config_file x = - if Sys.file_exists !config_file then begin - (* Will raise exception if config is mis-formatted. It's up to the - caller to inspect and handle the failure. - *) - Config_file.parse !config_file x; - end; - (try Sys.readdir !config_dir with _ -> [||]) - |> Array.to_list - |> List.stable_sort compare - |> List.iter - (fun fragment -> - let path = Filename.concat !config_dir fragment in - Config_file.parse path x - ) + if Sys.file_exists !config_file then + (* Will raise exception if config is mis-formatted. It's up to the caller to + inspect and handle the failure. *) + Config_file.parse !config_file x ; + (try Sys.readdir !config_dir with _ -> [||]) + |> Array.to_list + |> List.stable_sort compare + |> List.iter (fun fragment -> + let path = Filename.concat !config_dir fragment in + Config_file.parse path x) let startswith prefix x = - let prefix' = String.length prefix and x' = String.length x in - prefix' <= x' && (String.sub x 0 prefix' = prefix) + let prefix' = String.length prefix and x' = String.length x in + prefix' <= x' && String.sub x 0 prefix' = prefix let configure_common ~options ~resources arg_parse_fn = - (* Register the Logs reporter to ensure we get log messages from libraries using Logs *) - Debug.init_logs (); - - let resources = default_resources @ resources in - let config_spec = common_options @ options @ (to_opt resources) in - + (* Register the Logs reporter to ensure we get log messages from libraries + using Logs *) + Debug.init_logs () ; + let resources = default_resources @ resources in + let config_spec = common_options @ options @ to_opt resources in (* It's very confusing if there are duplicate key names *) let keys = List.map (fun (k, _, _, _) -> k) config_spec in let rec check_for_duplicates seen_already = function - | [] -> () - | x :: xs -> - if List.mem x seen_already then begin - warn "Duplicate configuration keys in Xcp_service.configure: %s in [ %s ]" - x (String.concat "; " keys) - end; - check_for_duplicates (x :: seen_already) xs in - check_for_duplicates [] keys; - - arg_parse_fn config_spec; - read_config_file config_spec; - List.iter (fun r -> r.path := canonicalise !(r.path)) resources; - Config_file.dump config_spec; - (* Check the required binaries are all available *) - List.iter - (fun f -> - try - if f.essential - then Unix.access !(f.path) f.perms - with _ -> - let args = List.filter (fun x -> not(startswith ("--" ^ f.name) x)) (Array.to_list Sys.argv) in - let lines = [ - "Cannot access " ^ !(f.path); - Printf.sprintf "Please either add to %s" !config_file; - Printf.sprintf " %s=<%s>" f.name f.description; - "or add a command-line argument"; - Printf.sprintf " %s --%s=<%s>" (String.concat " " args) f.name f.description; - ] in - List.iter (fun x -> error "%s" x) lines; - failwith (String.concat "\n" lines) - ) resources; - - Sys.set_signal Sys.sigpipe Sys.Signal_ignore - -let configure ?(options=[]) ?(resources=[]) () = + | [] -> + () + | x :: xs -> + if List.mem x seen_already then + warn + "Duplicate configuration keys in Xcp_service.configure: %s in [ %s \ + ]" + x (String.concat "; " keys) ; + check_for_duplicates (x :: seen_already) xs + in + check_for_duplicates [] keys ; + arg_parse_fn config_spec ; + read_config_file config_spec ; + List.iter (fun r -> r.path := canonicalise !(r.path)) resources ; + Config_file.dump config_spec ; + (* Check the required binaries are all available *) + List.iter + (fun f -> + try if f.essential then Unix.access !(f.path) f.perms + with _ -> + let args = + List.filter + (fun x -> not (startswith ("--" ^ f.name) x)) + (Array.to_list Sys.argv) + in + let lines = + [ + "Cannot access " ^ !(f.path) + ; Printf.sprintf "Please either add to %s" !config_file + ; Printf.sprintf " %s=<%s>" f.name f.description + ; "or add a command-line argument" + ; Printf.sprintf " %s --%s=<%s>" (String.concat " " args) f.name + f.description + ] + in + List.iter (fun x -> error "%s" x) lines ; + failwith (String.concat "\n" lines)) + resources ; + Sys.set_signal Sys.sigpipe Sys.Signal_ignore + +let configure ?(options = []) ?(resources = []) () = try - configure_common ~options ~resources - (fun config_spec -> - Arg.parse (Arg.align (arg_spec config_spec)) + configure_common ~options ~resources (fun config_spec -> + Arg.parse + (Arg.align (arg_spec config_spec)) (fun _ -> failwith "Invalid argument") - (Printf.sprintf "Usage: %s [-config filename]" Sys.argv.(0)) - ) - with Failure _ -> - exit 1 + (Printf.sprintf "Usage: %s [-config filename]" Sys.argv.(0))) + with Failure _ -> exit 1 -type ('a, 'b) error = [ - | `Ok of 'a - | `Error of 'b -] +type ('a, 'b) error = [`Ok of 'a | `Error of 'b] -let configure2 ~name ~version ~doc ?(options=[]) ?(resources=[]) () = +let configure2 ~name ~version ~doc ?(options = []) ?(resources = []) () = try - Xcp_coverage.init name; - configure_common ~options ~resources - (fun config_spec -> + configure_common ~options ~resources (fun config_spec -> match Term.eval (command_of ~name ~version ~doc config_spec) with - | `Ok () -> () - | `Error _ -> failwith "Failed to parse command-line arguments" - | _ -> exit 0 (* --help *) - ); + | `Ok () -> + () + | `Error _ -> + failwith "Failed to parse command-line arguments" + | _ -> + exit 0 + (* --help *)) ; `Ok () - with Failure m -> - `Error m + with Failure m -> `Error m let http_handler call_of_string string_of_response process s = - let ic = Unix.in_channel_of_descr s in - let oc = Unix.out_channel_of_descr s in - let module Request = Cohttp.Request.Make(Cohttp_posix_io.Buffered_IO) in - let module Response = Cohttp.Response.Make(Cohttp_posix_io.Buffered_IO) in - match Request.read ic with - | `Eof -> - debug "Failed to read HTTP request" - | `Invalid x -> - debug "Failed to read HTTP request. Got: '%s'" x - | `Ok req -> - begin match Cohttp.Request.meth req, Uri.path (Cohttp.Request.uri req) with - | `POST, _ -> - let headers = Cohttp.Request.headers req in - begin match Cohttp.Header.get headers "content-length" with - | None -> - debug "Failed to read content-length" - | Some content_length -> - let content_length = int_of_string content_length in - let request_txt = Bytes.make content_length '\000' in - really_input ic request_txt 0 content_length; - let rpc_call = call_of_string (Bytes.unsafe_to_string request_txt) in - debug "%s" (Rpc.string_of_call rpc_call); - let rpc_response = process rpc_call in - debug " %s" (Rpc.string_of_response rpc_response); - let response_txt = string_of_response rpc_response in - let content_length = String.length response_txt in - let headers = Cohttp.Header.of_list [ - "user-agent", default_service_name; - "content-length", string_of_int content_length; - ] in - let response = Cohttp.Response.make ~version:`HTTP_1_1 ~status:`OK ~headers ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int content_length)) () in - Response.write (fun t -> Response.write_body t response_txt) response oc - end - | _, _ -> - let content_length = 0 in - let headers = Cohttp.Header.of_list [ - "user-agent", default_service_name; - "content-length", string_of_int content_length; - ] in - let response = Cohttp.Response.make ~version:`HTTP_1_1 ~status:`Not_found ~headers ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int content_length)) () in - Response.write (fun _t -> ()) response oc - end - -let ign_int (t:int) = ignore t + let ic = Unix.in_channel_of_descr s in + let oc = Unix.out_channel_of_descr s in + let module Request = Cohttp.Request.Make (Cohttp_posix_io.Buffered_IO) in + let module Response = Cohttp.Response.Make (Cohttp_posix_io.Buffered_IO) in + match Request.read ic with + | `Eof -> + debug "Failed to read HTTP request" + | `Invalid x -> + debug "Failed to read HTTP request. Got: '%s'" x + | `Ok req -> ( + match (Cohttp.Request.meth req, Uri.path (Cohttp.Request.uri req)) with + | `POST, _ -> ( + let headers = Cohttp.Request.headers req in + match Cohttp.Header.get headers "content-length" with + | None -> + debug "Failed to read content-length" + | Some content_length -> + let content_length = int_of_string content_length in + let request_txt = Bytes.make content_length '\000' in + really_input ic request_txt 0 content_length ; + let rpc_call = + call_of_string (Bytes.unsafe_to_string request_txt) + in + debug "%s" (Rpc.string_of_call rpc_call) ; + let rpc_response = process rpc_call in + debug " %s" (Rpc.string_of_response rpc_response) ; + let response_txt = string_of_response rpc_response in + let content_length = String.length response_txt in + let headers = + Cohttp.Header.of_list + [ + ("user-agent", default_service_name) + ; ("content-length", string_of_int content_length) + ] + in + let response = + Cohttp.Response.make ~version:`HTTP_1_1 ~status:`OK ~headers + ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int content_length)) + () + in + Response.write + (fun t -> Response.write_body t response_txt) + response oc + ) + | _, _ -> + let content_length = 0 in + let headers = + Cohttp.Header.of_list + [ + ("user-agent", default_service_name) + ; ("content-length", string_of_int content_length) + ] + in + let response = + Cohttp.Response.make ~version:`HTTP_1_1 ~status:`Not_found ~headers + ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int content_length)) + () + in + Response.write (fun _t -> ()) response oc + ) + +let ign_int (t : int) = ignore t let default_raw_fn rpc_fn s = - http_handler Xmlrpc.call_of_string Xmlrpc.string_of_response rpc_fn s + http_handler Xmlrpc.call_of_string Xmlrpc.string_of_response rpc_fn s let mkdir_rec dir perm = - let rec p_mkdir dir = - let p_name = Filename.dirname dir in - if p_name <> "/" && p_name <> "." - then p_mkdir p_name; - (try Unix.mkdir dir perm with Unix.Unix_error(Unix.EEXIST, _, _) -> ()) in - p_mkdir dir + let rec p_mkdir dir = + let p_name = Filename.dirname dir in + if p_name <> "/" && p_name <> "." then p_mkdir p_name ; + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + in + p_mkdir dir type server = | Socket of Unix.file_descr * (Unix.file_descr -> unit) @@ -436,102 +540,110 @@ type server = (* Start accepting connections on sockets before we daemonize *) let make_socket_server path fn = - try - (try Unix.unlink path with Unix.Unix_error(Unix.ENOENT, _, _) -> ()); - mkdir_rec (Filename.dirname path) 0o0755; - let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unix.bind sock (Unix.ADDR_UNIX path); - Unix.listen sock 5; - info "Listening on %s" path; - Socket (sock, fn) - with e -> - error "Failed to listen on Unix domain socket %s. Raw error was: %s" path (Printexc.to_string e); - begin match e with - | Unix.Unix_error(Unix.EACCES, _, _) -> - error "Access was denied."; - error "Possible fixes include:"; - error "1. Run this program as root (recommended)"; - error "2. Make the permissions in the filesystem more permissive (my effective uid is %d)" (Unix.geteuid ()); - error "3. Adjust the sockets-path directive in %s" !config_file; - exit 1 - | _ -> () - end; - raise e - -let make_queue_server name fn = - Queue(name, fn) (* TODO: connect to the message switch *) + try + (try Unix.unlink path with Unix.Unix_error (Unix.ENOENT, _, _) -> ()) ; + mkdir_rec (Filename.dirname path) 0o0755 ; + let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.bind sock (Unix.ADDR_UNIX path) ; + Unix.listen sock 5 ; + info "Listening on %s" path ; + Socket (sock, fn) + with e -> + error "Failed to listen on Unix domain socket %s. Raw error was: %s" path + (Printexc.to_string e) ; + ( match e with + | Unix.Unix_error (Unix.EACCES, _, _) -> + error "Access was denied." ; + error "Possible fixes include:" ; + error "1. Run this program as root (recommended)" ; + error + "2. Make the permissions in the filesystem more permissive (my \ + effective uid is %d)" + (Unix.geteuid ()) ; + error "3. Adjust the sockets-path directive in %s" !config_file ; + exit 1 + | _ -> + () + ) ; + raise e + +let make_queue_server name fn = Queue (name, fn) + +(* TODO: connect to the message switch *) let make ~path ~queue_name ?raw_fn ~rpc_fn () = - if !Xcp_client.use_switch - then make_queue_server queue_name rpc_fn - else make_socket_server path (match raw_fn with - | Some x -> x - | None -> default_raw_fn rpc_fn - ) + if !Xcp_client.use_switch then + make_queue_server queue_name rpc_fn + else + make_socket_server path + (match raw_fn with Some x -> x | None -> default_raw_fn rpc_fn) let serve_forever = function - | Socket(listening_sock, fn) -> - while true do - let this_connection, _ = Unix.accept listening_sock in - let (_: Thread.t) = Thread.create - (fun () -> - finally - (fun () -> fn this_connection) - (fun () -> Unix.close this_connection) - ) () in - () - done - | Queue(queue_name, fn) -> - let process x = Jsonrpc.string_of_response (fn (Jsonrpc.call_of_string x)) in - let _ = Message_switch_unix.Protocol_unix.Server.listen ~process ~switch:!Xcp_client.switch_path ~queue:queue_name () in - let rec forever () = - Thread.delay 3600.; - forever () in - forever () + | Socket (listening_sock, fn) -> + while true do + let this_connection, _ = Unix.accept listening_sock in + let (_ : Thread.t) = + Thread.create + (fun () -> + finally + (fun () -> fn this_connection) + (fun () -> Unix.close this_connection)) + () + in + () + done + | Queue (queue_name, fn) -> + let process x = + Jsonrpc.string_of_response (fn (Jsonrpc.call_of_string x)) + in + let _ = + Message_switch_unix.Protocol_unix.Server.listen ~process + ~switch:!Xcp_client.switch_path ~queue:queue_name () + in + let rec forever () = Thread.delay 3600. ; forever () in + forever () let pidfile_write filename = - let fd = Unix.openfile filename - [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] - 0o640 in - finally - (fun () -> - let pid = Unix.getpid () in - let buf = - string_of_int pid ^ "\n" - |> Bytes.of_string - in - let len = Bytes.length buf in - if Unix.write fd buf 0 len <> len - then failwith "pidfile_write failed") - (fun () -> Unix.close fd) - + let fd = + Unix.openfile filename [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o640 + in + finally + (fun () -> + let pid = Unix.getpid () in + let buf = string_of_int pid ^ "\n" |> Bytes.of_string in + let len = Bytes.length buf in + if Unix.write fd buf 0 len <> len then + failwith "pidfile_write failed") + (fun () -> Unix.close fd) (* Cf Stevens et al, Advanced Programming in the UNIX Environment, Section 13.3 *) let daemonize ?start_fn () = - if not (have_daemonized ()) - then - ign_int (Unix.umask 0); - match Unix.fork () with - | 0 -> - if Unix.setsid () == -1 then failwith "Unix.setsid failed"; - Sys.set_signal Sys.sighup Sys.Signal_ignore; - (match Unix.fork () with - | 0 -> - Opt.iter (fun fn -> fn ()) start_fn; - Unix.chdir "/"; - mkdir_rec (Filename.dirname !pidfile) 0o755; - pidfile_write !pidfile; - let nullfd = Unix.openfile "/dev/null" [ Unix.O_RDWR ] 0 in - Unix.dup2 nullfd Unix.stdin; - Unix.dup2 nullfd Unix.stdout; - Unix.dup2 nullfd Unix.stderr; - Unix.close nullfd - | _ -> exit 0) - | _ -> exit 0 + if not (have_daemonized ()) then + ign_int (Unix.umask 0) ; + match Unix.fork () with + | 0 -> ( + if Unix.setsid () == -1 then failwith "Unix.setsid failed" ; + Sys.set_signal Sys.sighup Sys.Signal_ignore ; + match Unix.fork () with + | 0 -> + Option.iter (fun fn -> fn ()) start_fn ; + Unix.chdir "/" ; + mkdir_rec (Filename.dirname !pidfile) 0o755 ; + pidfile_write !pidfile ; + let nullfd = Unix.openfile "/dev/null" [Unix.O_RDWR] 0 in + Unix.dup2 nullfd Unix.stdin ; + Unix.dup2 nullfd Unix.stdout ; + Unix.dup2 nullfd Unix.stderr ; + Unix.close nullfd + | _ -> + exit 0 + ) + | _ -> + exit 0 let maybe_daemonize ?start_fn () = - if !daemon then - daemonize ?start_fn () - else - Opt.iter (fun fn -> fn ()) start_fn + if !daemon then + daemonize ?start_fn () + else + Option.iter (fun fn -> fn ()) start_fn diff --git a/lib/xcp_service.mli b/lib/xcp_service.mli index 3871be2b..74be71d8 100644 --- a/lib/xcp_service.mli +++ b/lib/xcp_service.mli @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -val common_prefix: string +val common_prefix : string type opt = string * Arg.spec * (unit -> string) * string @@ -21,44 +21,45 @@ module Config_file : sig end type res = { - name: string; - description: string; - essential: bool; - path: string ref; - perms: Unix.access_permission list; + name: string + ; description: string + ; essential: bool + ; path: string ref + ; perms: Unix.access_permission list } -val configure: ?options:opt list -> ?resources:res list -> unit -> unit +val configure : ?options:opt list -> ?resources:res list -> unit -> unit -type ('a, 'b) error = [ - | `Ok of 'a - | `Error of 'b -] +type ('a, 'b) error = [`Ok of 'a | `Error of 'b] -val configure2: - name:string -> - version:string -> - doc:string -> - ?options:opt list -> ?resources:res list -> unit -> - (unit, string) error +val configure2 : + name:string + -> version:string + -> doc:string + -> ?options:opt list + -> ?resources:res list + -> unit + -> (unit, string) error (** More advanced service configuration with manpage generation *) type server -val make_socket_server: string -> (Unix.file_descr -> unit) -> server +val make_socket_server : string -> (Unix.file_descr -> unit) -> server -val make: path:string -> - queue_name:string -> - ?raw_fn: (Unix.file_descr -> unit) -> - rpc_fn: (Rpc.call -> Rpc.response) -> - unit -> - server +val make : + path:string + -> queue_name:string + -> ?raw_fn:(Unix.file_descr -> unit) + -> rpc_fn:(Rpc.call -> Rpc.response) + -> unit + -> server -val serve_forever: server -> unit +val serve_forever : server -> unit -val daemon: bool ref -val loglevel: unit -> Syslog.level +val daemon : bool ref -val daemonize: ?start_fn:(unit -> unit) -> unit -> unit +val loglevel : unit -> Syslog.level -val maybe_daemonize: ?start_fn:(unit -> unit) -> unit -> unit +val daemonize : ?start_fn:(unit -> unit) -> unit -> unit + +val maybe_daemonize : ?start_fn:(unit -> unit) -> unit -> unit diff --git a/lib_test/channel_test.ml b/lib_test/channel_test.ml index d87162ee..739fc54e 100644 --- a/lib_test/channel_test.ml +++ b/lib_test/channel_test.ml @@ -20,11 +20,13 @@ let dup_automatic x = let dup_sendmsg x = let protos = Posix_channel.send x in - let proto = List.find (function - | Xcp_channel_protocol.Unix_sendmsg(_, _, _) -> true - | _ -> false - ) protos in - Posix_channel.receive [ proto ] + let proto = + List.find + (function + | Xcp_channel_protocol.Unix_sendmsg (_, _, _) -> true | _ -> false) + protos + in + Posix_channel.receive [proto] let count_fds () = Array.length (Sys.readdir "/proc/self/fd") @@ -33,36 +35,40 @@ let check_for_leak dup_function () = let before = count_fds () in let stdout2 = dup_function Unix.stdout in let after = count_fds () in - Alcotest.(check int) "fds" (before + 1) after; - Unix.close stdout2; + Alcotest.(check int) "fds" (before + 1) after ; + Unix.close stdout2 ; let after' = count_fds () in Alcotest.(check int) "fds" before after' let dup_proxy x = let protos = Posix_channel.send x in - let proto = List.find (function - | Xcp_channel_protocol.TCP_proxy(ip, port) -> true - | _ -> false - ) protos in - Posix_channel.receive [ proto ] + let proto = + List.find + (function + | Xcp_channel_protocol.TCP_proxy (_ip, _port) -> true | _ -> false) + protos + in + Posix_channel.receive [proto] let check_for_leak_proxy () = - let a, b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + let a, _b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in let before = count_fds () in let c = dup_proxy a in - Thread.delay 1.0; (* background fd closing *) + (* background fd closing *) + Thread.delay 1.0 ; let after = count_fds () in - Alcotest.(check int) "fds" (before + 2) after; - Unix.close c; - Thread.delay 1.0; (* background fd closing *) + Alcotest.(check int) "fds" (before + 2) after ; + Unix.close c ; + (* background fd closing *) + Thread.delay 1.0 ; let after' = count_fds () in Alcotest.(check int) "fds" before after' let tests = [ - "check_for_leak with automatic selection", `Quick, (check_for_leak dup_automatic); - "check_for_leak with sendmsg", `Quick, (check_for_leak dup_sendmsg); - "check_for_leak_proxy", `Quick, check_for_leak_proxy; + ( "check_for_leak with automatic selection" + , `Quick + , check_for_leak dup_automatic ) + ; ("check_for_leak with sendmsg", `Quick, check_for_leak dup_sendmsg) + ; ("check_for_leak_proxy", `Quick, check_for_leak_proxy) ] - - diff --git a/lib_test/cluster_interface_test.ml b/lib_test/cluster_interface_test.ml index 459da690..b5cb653e 100644 --- a/lib_test/cluster_interface_test.ml +++ b/lib_test/cluster_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "cluster_gen" end + module OldPath = struct let test_data_path = "test_data/cluster" end -module C = Cluster_interface.LocalAPI(GenTestData(GenPath)(TXmlrpc)) -module T = Cluster_interface.LocalAPI(TestOldRpcs(OldPath)(TXmlrpc)) +module C = Cluster_interface.LocalAPI (GenTestData (GenPath) (TXmlrpc)) +module T = Cluster_interface.LocalAPI (TestOldRpcs (OldPath) (TXmlrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/config_file_test.ml b/lib_test/config_file_test.ml index d95894df..5b8d410e 100644 --- a/lib_test/config_file_test.ml +++ b/lib_test/config_file_test.ml @@ -1,22 +1,26 @@ - let test_config_file () = let open Xcp_service.Config_file in - let tests = [ - "", None; - "# Foo", None; - "whatever", None; - "foo=true", Some ("foo","true"); - "n=2 # and no more", Some ("n","2"); - "n = 2 \t# and no more", Some ("n","2"); - "n = 'test' # comment", Some ("n","test"); - "n = \"test\" # comment", Some ("n","test"); - " n\t\t \t = 'foo bar baz'\t\t\t # comment", Some ("n","foo bar baz"); - " n\t\t \t = foo bar baz\t\t\t # comment", Some ("n","foo bar baz"); - "n = 'foo bar baz ' # comment", Some ("n","foo bar baz "); - ] in - List.iter (fun (x,y) -> Alcotest.(check (option (pair string string))) ("parse output for " ^ x) (parse_line x) y) tests + let tests = + [ + ("", None) + ; ("# Foo", None) + ; ("whatever", None) + ; ("foo=true", Some ("foo", "true")) + ; ("n=2 # and no more", Some ("n", "2")) + ; ("n = 2 \t# and no more", Some ("n", "2")) + ; ("n = 'test' # comment", Some ("n", "test")) + ; ("n = \"test\" # comment", Some ("n", "test")) + ; ( " n\t\t \t = 'foo bar baz'\t\t\t # comment" + , Some ("n", "foo bar baz") ) + ; ( " n\t\t \t = foo bar baz\t\t\t # comment" + , Some ("n", "foo bar baz") ) + ; ("n = 'foo bar baz ' # comment", Some ("n", "foo bar baz ")) + ] + in + List.iter + (fun (x, y) -> + Alcotest.(check (option (pair string string))) + ("parse output for " ^ x) (parse_line x) y) + tests -let tests = - [ - "check config file parsing", `Quick, test_config_file; - ] +let tests = [("check config file parsing", `Quick, test_config_file)] diff --git a/lib_test/debug_test.ml b/lib_test/debug_test.ml index 66d761a6..aa606ca2 100644 --- a/lib_test/debug_test.ml +++ b/lib_test/debug_test.ml @@ -1,73 +1,75 @@ - let assert_levels brand (crit, err, warn, info, debug) = - Alcotest.(check bool) (brand ^ " critical") (Debug.is_disabled brand Syslog.Crit) crit; - Alcotest.(check bool) (brand ^ " error") (Debug.is_disabled brand Syslog.Err) err; - Alcotest.(check bool) (brand ^ " warning") (Debug.is_disabled brand Syslog.Warning) warn; - Alcotest.(check bool) (brand ^ " info") (Debug.is_disabled brand Syslog.Info) info; - Alcotest.(check bool) (brand ^ " debug") (Debug.is_disabled brand Syslog.Debug) debug - + Alcotest.(check bool) + (brand ^ " critical") + (Debug.is_disabled brand Syslog.Crit) + crit ; + Alcotest.(check bool) + (brand ^ " error") + (Debug.is_disabled brand Syslog.Err) + err ; + Alcotest.(check bool) + (brand ^ " warning") + (Debug.is_disabled brand Syslog.Warning) + warn ; + Alcotest.(check bool) + (brand ^ " info") + (Debug.is_disabled brand Syslog.Info) + info ; + Alcotest.(check bool) + (brand ^ " debug") + (Debug.is_disabled brand Syslog.Debug) + debug let test_default_levels () = - assert_levels "some unused brand" (false, false, false, false, false); + assert_levels "some unused brand" (false, false, false, false, false) ; assert_levels "some other unused brand" (false, false, false, false, false) - let test_debug_disable () = - Debug.set_level Syslog.Debug; - - Debug.disable "xapi" ~level:Syslog.Info; - assert_levels "xapi" (false, false, false, true, false); - - Debug.disable "xenopsd" ~level:Syslog.Err; - assert_levels "xenopsd" (false, true, false, false, false); + Debug.set_level Syslog.Debug ; + Debug.disable "xapi" ~level:Syslog.Info ; + assert_levels "xapi" (false, false, false, true, false) ; + Debug.disable "xenopsd" ~level:Syslog.Err ; + assert_levels "xenopsd" (false, true, false, false, false) ; assert_levels "xapi" (false, false, false, true, false) - let test_debug_set_level () = - Debug.set_level Syslog.Debug; - assert_levels "brand1" (false, false, false, false, false); - assert_levels "other" (false, false, false, false, false); - - Debug.set_level Syslog.Info; - assert_levels "brand1" (false, false, false, false, true); - assert_levels "other" (false, false, false, false, true); - - Debug.set_level Syslog.Warning; - assert_levels "brand1" (false, false, false, true, true); - assert_levels "other" (false, false, false, true, true); - - Debug.set_level Syslog.Err; - assert_levels "brand1" (false, false, true, true, true); - assert_levels "other" (false, false, true, true, true); - - Debug.set_level Syslog.Crit; - assert_levels "brand1" (false, true, true, true, true); - assert_levels "other" (false, true, true, true, true) - + Debug.set_level Syslog.Debug ; + assert_levels "brand1" (false, false, false, false, false) ; + assert_levels "other" (false, false, false, false, false) ; + Debug.set_level Syslog.Info ; + assert_levels "brand1" (false, false, false, false, true) ; + assert_levels "other" (false, false, false, false, true) ; + Debug.set_level Syslog.Warning ; + assert_levels "brand1" (false, false, false, true, true) ; + assert_levels "other" (false, false, false, true, true) ; + Debug.set_level Syslog.Err ; + assert_levels "brand1" (false, false, true, true, true) ; + assert_levels "other" (false, false, true, true, true) ; + Debug.set_level Syslog.Crit ; + assert_levels "brand1" (false, true, true, true, true) ; + assert_levels "other" (false, true, true, true, true) let test_debug_set_level_multiple_loggers () = - let _ = (module Debug.Make(struct let name = "aaaa" end) : Debug.DEBUG) in - let _ = (module Debug.Make(struct let name = "bbbb" end) : Debug.DEBUG) in - - Debug.set_level Syslog.Debug; - assert_levels "aaaa" (false, false, false, false, false); - assert_levels "bbbb" (false, false, false, false, false); - + let _ = (module Debug.Make (struct let name = "aaaa" end) : Debug.DEBUG) in + let _ = (module Debug.Make (struct let name = "bbbb" end) : Debug.DEBUG) in + Debug.set_level Syslog.Debug ; + assert_levels "aaaa" (false, false, false, false, false) ; + assert_levels "bbbb" (false, false, false, false, false) ; (* Set level explicitly on aaaa *) - Debug.disable ~level:Syslog.Err "aaaa"; - assert_levels "aaaa" (false, true, false, false, false); - assert_levels "bbbb" (false, false, false, false, false); - - (* Set default level. Err should still be disabled for aaaa *) - Debug.set_level Syslog.Warning; - assert_levels "aaaa" (false, true, false, true, true); - assert_levels "bbbb" (false, false, false, true, true) + Debug.disable ~level:Syslog.Err "aaaa" ; + assert_levels "aaaa" (false, true, false, false, false) ; + assert_levels "bbbb" (false, false, false, false, false) ; + (* Set default level. Err should still be disabled for aaaa *) + Debug.set_level Syslog.Warning ; + assert_levels "aaaa" (false, true, false, true, true) ; + assert_levels "bbbb" (false, false, false, true, true) let tests = let open Alcotest in [ - test_case "Test default levels" `Quick test_default_levels; - test_case "Test Debug.disable" `Quick test_debug_disable; - test_case "Test Debug.set_level" `Quick test_debug_set_level; - test_case "Test Debug.set_level (multiple loggers)" `Quick test_debug_set_level_multiple_loggers; - ] \ No newline at end of file + test_case "Test default levels" `Quick test_default_levels + ; test_case "Test Debug.disable" `Quick test_debug_disable + ; test_case "Test Debug.set_level" `Quick test_debug_set_level + ; test_case "Test Debug.set_level (multiple loggers)" `Quick + test_debug_set_level_multiple_loggers + ] diff --git a/lib_test/device_number_test.ml b/lib_test/device_number_test.ml index 5d12dee3..79c662dd 100644 --- a/lib_test/device_number_test.ml +++ b/lib_test/device_number_test.ml @@ -1,70 +1,81 @@ open Device_number -let device_number = Alcotest.testable (Fmt.of_to_string Device_number.to_debug_string) (=) +let device_number = + Alcotest.testable (Fmt.of_to_string Device_number.to_debug_string) ( = ) (* spec * linux string * xenstore key *) -let examples = [ - (Xen, 0, 0), "xvda", 51712; - (Xen, 0, 1), "xvda1", 51713; - (Ide, 0, 0), "hda", 768; - (Ide, 0, 1), "hda1", 769; - (Scsi, 0, 0), "sda", 2048; - (Scsi, 0, 1), "sda1", 2049; - (Scsi, 1, 3), "sdb3", 2067; - (Ide, 2, 2), "hdc2", 5634; - (Xen, 26, 0), "xvdaa", 268442112; -] +let examples = + [ + ((Xen, 0, 0), "xvda", 51712) + ; ((Xen, 0, 1), "xvda1", 51713) + ; ((Ide, 0, 0), "hda", 768) + ; ((Ide, 0, 1), "hda1", 769) + ; ((Scsi, 0, 0), "sda", 2048) + ; ((Scsi, 0, 1), "sda1", 2049) + ; ((Scsi, 1, 3), "sdb3", 2067) + ; ((Ide, 2, 2), "hdc2", 5634) + ; ((Xen, 26, 0), "xvdaa", 268442112) + ] -let deprecated = [ - (Ide, 4, 0), "hde", 8448; - (Ide, 5, 0), "hdf", 8512; - (Ide, 6, 0), "hdg", 8704; - (Ide, 7, 0), "hdh", 8768; - (Ide, 8, 0), "hdi", 14336; - (Ide, 15, 0), "hdp", 22848; -] +let deprecated = + [ + ((Ide, 4, 0), "hde", 8448) + ; ((Ide, 5, 0), "hdf", 8512) + ; ((Ide, 6, 0), "hdg", 8704) + ; ((Ide, 7, 0), "hdh", 8768) + ; ((Ide, 8, 0), "hdi", 14336) + ; ((Ide, 15, 0), "hdp", 22848) + ] let examples_to_test = let using_deprecated_ide = - try ignore(make (Ide, 4, 0)); true with _ -> false in - examples @ (if using_deprecated_ide then deprecated else []) + try + ignore (make (Ide, 4, 0)) ; + true + with _ -> false + in + examples @ if using_deprecated_ide then deprecated else [] -let equivalent = [ - "d0", "xvda"; - "d0", "0"; - "d5", "5"; - "xvdf", "5"; - "d0p0", "xvda"; - "d536p37", "xvdtq37"; -] +let equivalent = + [ + ("d0", "xvda") + ; ("d0", "0") + ; ("d5", "5") + ; ("xvdf", "5") + ; ("d0p0", "xvda") + ; ("d536p37", "xvdtq37") + ] let test_examples = let tests = List.map (fun (spec, linux, xenstore) -> - "test_examples " ^ linux, `Quick, (fun () -> - let of_spec = make spec in - let of_linux = of_linux_device linux in - let of_xenstore = of_xenstore_key xenstore in - Alcotest.check device_number "examples must be equal" - of_spec of_linux; - Alcotest.check device_number "examples must be equal" - of_spec of_xenstore)) + ( "test_examples " ^ linux + , `Quick + , fun () -> + let of_spec = make spec in + let of_linux = of_linux_device linux in + let of_xenstore = of_xenstore_key xenstore in + Alcotest.check device_number "examples must be equal" of_spec + of_linux ; + Alcotest.check device_number "examples must be equal" of_spec + of_xenstore )) examples_to_test in tests (* NB we always understand the deprecated linux/xenstore devices even if we - * don't generate them ourselves *) + don't generate them ourselves *) let test_deprecated = let tests = List.map (fun (_, linux, xenstore) -> - "test_deprecated " ^ linux, `Quick, (fun () -> - let of_linux = of_linux_device linux in - let of_xenstore = of_xenstore_key xenstore in - Alcotest.check device_number "must be equal" - of_linux of_xenstore)) + ( "test_deprecated " ^ linux + , `Quick + , fun () -> + let of_linux = of_linux_device linux in + let of_xenstore = of_xenstore_key xenstore in + Alcotest.check device_number "must be equal" of_linux of_xenstore )) deprecated in tests @@ -73,42 +84,50 @@ let test_equivalent = let tests = List.map (fun (x, y) -> - let test_name = Printf.sprintf "test_equivalent %s=%s" x y in - test_name, `Quick, (fun () -> - let x' = of_string false x in - let y' = of_string false y in - Alcotest.check device_number "must be equal" - x' y')) + let test_name = Printf.sprintf "test_equivalent %s=%s" x y in + ( test_name + , `Quick + , fun () -> + let x' = of_string false x in + let y' = of_string false y in + Alcotest.check device_number "must be equal" x' y' )) equivalent in tests let test_2_way_convert = - (* We now always convert Ide specs into xvd* linux devices, so they - become Xen specs when converted back. *) + (* We now always convert Ide specs into xvd* linux devices, so they become Xen + specs when converted back. *) let equal_linux old_t new_t = - match spec old_t, spec new_t with + match (spec old_t, spec new_t) with | (Ide, disk1, partition1), (Xen, disk2, partition2) - when disk1 = disk2 && partition1 = partition2 -> true - | old_spec, new_spec -> old_spec = new_spec + when disk1 = disk2 && partition1 = partition2 -> + true + | old_spec, new_spec -> + old_spec = new_spec + in + let device_number_equal_linux = + Alcotest.testable + (Fmt.of_to_string Device_number.to_debug_string) + equal_linux in - let device_number_equal_linux = Alcotest.testable (Fmt.of_to_string Device_number.to_debug_string) equal_linux in - ["test_2_way_convert", `Slow, (fun () -> - for disk_number = 0 to ((1 lsl 20) -1) do - List.iter - (fun hvm -> + [ + ( "test_2_way_convert" + , `Slow + , fun () -> + for disk_number = 0 to (1 lsl 20) - 1 do + List.iter + (fun hvm -> let original = of_disk_number hvm disk_number in let of_linux = of_linux_device (to_linux_device original) in let of_xenstore = of_xenstore_key (to_xenstore_key original) in - Alcotest.check device_number_equal_linux "of_linux must be equal to original" - original of_linux; - Alcotest.check device_number "of_xenstore must be equal to original" - original of_xenstore) - [true; false] - done)] + Alcotest.check device_number_equal_linux + "of_linux must be equal to original" original of_linux ; + Alcotest.check device_number + "of_xenstore must be equal to original" original of_xenstore) + [true; false] + done ) + ] let tests = - test_examples @ - test_deprecated @ - test_equivalent @ - test_2_way_convert + test_examples @ test_deprecated @ test_equivalent @ test_2_way_convert diff --git a/lib_test/dune b/lib_test/dune index aea0fcd4..9fd12b09 100644 --- a/lib_test/dune +++ b/lib_test/dune @@ -1,47 +1,23 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - -(executables - (names test) - (flags (:standard -w -39)) - (libraries - alcotest - rpclib.core - rpclib.markdown - threads - xapi-idl - xapi-idl.cluster - xapi-idl.rrd - xapi-idl.memory - xapi-idl.updates - xapi-idl.network - xapi-idl.gpumon - xapi-idl.storage - xapi-idl.varstore.privileged - xapi-idl.varstore.deprivileged - xapi-idl.v6 - xapi-idl.xen - ) - (preprocess (pps ppx_deriving_rpc %s)) -) - -(alias - (name runtest) - (deps (:x test.exe) (source_tree test_data)) - (action (run %%{x})) -) - -(alias - (name runtest-quick) - (deps (:x test.exe) (source_tree test_data)) - (action (run %%{x} -q)) -) - -|} coverage_rewriter +(test + (name test) + (deps (source_tree test_data)) + (flags (:standard -w -39)) + (libraries + alcotest + rpclib.core + rpclib.markdown + threads + xapi-idl + xapi-idl.cluster + xapi-idl.rrd + xapi-idl.memory + xapi-idl.updates + xapi-idl.network + xapi-idl.gpumon + xapi-idl.storage + xapi-idl.varstore.privileged + xapi-idl.varstore.deprivileged + xapi-idl.v6 + xapi-idl.xen + ) + (preprocess (pps ppx_deriving_rpc))) diff --git a/lib_test/gpumon_interface_test.ml b/lib_test/gpumon_interface_test.ml index 1e96643b..95010076 100644 --- a/lib_test/gpumon_interface_test.ml +++ b/lib_test/gpumon_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "gpu_gen" end + module OldPath = struct let test_data_path = "test_data/gpumon" end -module C = Gpumon_interface.RPC_API(GenTestData(GenPath)(TJsonrpc)) -module T = Gpumon_interface.RPC_API(TestOldRpcs(OldPath)(TJsonrpc)) +module C = Gpumon_interface.RPC_API (GenTestData (GenPath) (TJsonrpc)) +module T = Gpumon_interface.RPC_API (TestOldRpcs (OldPath) (TJsonrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/http_test.ml b/lib_test/http_test.ml index eb5b2432..3eb449e0 100644 --- a/lib_test/http_test.ml +++ b/lib_test/http_test.ml @@ -13,20 +13,23 @@ *) let unbuffered_headers () = - (* A miscalculation in the Cohttp_posix_io module can cause the HTTP - status line to be parsed ok but the headers mangled. This can be - surprisingly hard to spot! *) + (* A miscalculation in the Cohttp_posix_io module can cause the HTTP status + line to be parsed ok but the headers mangled. This can be surprisingly hard + to spot! *) let open Cohttp_posix_io.Unbuffered_IO in - let ic = { - header_buffer = Some "HTTP/200 OK\r\nHeader1: Val1\r\nHeader2: Val2\r\n\r\n"; - header_buffer_idx = 0; - fd = Unix.stdin; (* unused *) - } in - Alcotest.(check (option string)) "header line 1" (Some "HTTP/200 OK") (read_line ic); - Alcotest.(check (option string)) "header line 2" (Some "Header1: Val1") (read_line ic); - Alcotest.(check (option string)) "header line 3" (Some "Header2: Val2") (read_line ic) + let ic = + { + header_buffer= Some "HTTP/200 OK\r\nHeader1: Val1\r\nHeader2: Val2\r\n\r\n" + ; header_buffer_idx= 0 + ; (* unused *) + fd= Unix.stdin + } + in + Alcotest.(check (option string)) + "header line 1" (Some "HTTP/200 OK") (read_line ic) ; + Alcotest.(check (option string)) + "header line 2" (Some "Header1: Val1") (read_line ic) ; + Alcotest.(check (option string)) + "header line 3" (Some "Header2: Val2") (read_line ic) -let tests = - [ - "unbuffered_headers", `Quick, unbuffered_headers; - ] +let tests = [("unbuffered_headers", `Quick, unbuffered_headers)] diff --git a/lib_test/idl_test_common.ml b/lib_test/idl_test_common.ml index 39734bb7..df8c2d36 100644 --- a/lib_test/idl_test_common.ml +++ b/lib_test/idl_test_common.ml @@ -14,312 +14,438 @@ let write_str filename str = let oc = open_out filename in - Printf.fprintf oc "%s" str; - close_out oc + Printf.fprintf oc "%s" str ; close_out oc let read_str filename = let ic = open_in filename in let n = in_channel_length ic in let s = Bytes.create n in - really_input ic s 0 n; - close_in ic; - Bytes.unsafe_to_string s + really_input ic s 0 n ; close_in ic ; Bytes.unsafe_to_string s open Idl module type CONFIG = sig val test_data_path : string - (** Path under which we look for or generate requests and responses. For example, - if test_data_path = 'foo', this module will search for or generate requests - matching 'foo/requests/.request.' and responses matching - 'foo/responses/.response.' *) + (** Path under which we look for or generate requests and responses. For + example, if test_data_path = 'foo', this module will search for or + generate requests matching 'foo/requests/.request.' and + responses matching 'foo/responses/.response.' *) end module type MARSHALLER = sig - val string_of_call : Rpc.call -> string + val string_of_call : ?strict:bool -> Rpc.call -> string + val call_of_string : string -> Rpc.call - val string_of_response : Rpc.response -> string + + val string_of_response : ?strict:bool -> Rpc.response -> string + val response_of_string : string -> Rpc.response - val to_string : Rpc.t -> string + + val to_string : ?strict:bool -> Rpc.t -> string + val of_string : string -> Rpc.t end -(* Slightly annoyingly, both RPC modules have a slightly different signature. Fix it here *) +(* Slightly annoyingly, both RPC modules have a slightly different signature. + Fix it here *) module TJsonrpc : MARSHALLER = struct include Jsonrpc + (* there is a ?strict parameter, and the signature would not match *) let of_string s = of_string s + + let to_string ?(strict : _) t = to_string t + let response_of_string r = response_of_string r - let string_of_call call = string_of_call call - let string_of_response response = string_of_response response + + let string_of_call ?(strict : _) call = string_of_call call + + let string_of_response ?(strict : _) response = string_of_response response end module TXmlrpc : MARSHALLER = struct include Xmlrpc + let call_of_string s = call_of_string s + let response_of_string s = response_of_string s + let of_string s = of_string s -end + let to_string ?(strict : _) t = to_string t + + let string_of_call ?(strict : _) call = string_of_call call + let string_of_response ?(strict : _) response = string_of_response response +end -(** The following module implements test cases that write test - RPC requests and responses in JSON that can be used to - verify that subsequent versions of an API can still parse - them. +(** The following module implements test cases that write test RPC requests and + responses in JSON that can be used to verify that subsequent versions of an + API can still parse them. - The test cases are obtained by obtaining the implementation - of the module generated when applying the API functor to - this module. + The test cases are obtained by obtaining the implementation of the module + generated when applying the API functor to this module. - The test data will be written to the path specified in the - CONFIG module passed in *) -module GenTestData (C:CONFIG) (M:MARSHALLER) = struct + The test data will be written to the path specified in the CONFIG module + passed in *) +module GenTestData (C : CONFIG) (M : MARSHALLER) = struct type implementation = unit Alcotest.test_case list ref let tests : unit Alcotest.test_case list ref = ref [] + let description = ref None - let implement x = description := Some x; tests + let implement x = + description := Some x ; + tests + + type ('a, 'b) comp = 'a - type ('a,'b) comp = 'a type 'a res = unit + type _ fn = | Function : 'a Idl.Param.t * 'b fn -> ('a -> 'b) fn | Returning : ('a Idl.Param.t * 'b Idl.Error.t) -> ('a, _) comp fn let returning a err = Returning (a, err) - let (@->) = fun t f -> Function (t, f) + + let ( @-> ) t f = Function (t, f) open M - let declare name _ ty = - let rec inner : type b. (((string * Rpc.t) list * Rpc.t list) list) -> b fn -> unit = fun params -> - function - | Function (t, f) -> begin - let vs = Rpc_genfake.genall 2 (match t.Param.name with Some n -> n | None -> t.Param.typedef.Rpc.Types.name) t.Param.typedef.Rpc.Types.ty in - let marshalled = List.map (fun v -> Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v) vs in - match t.Param.name with - | Some n -> - inner - (List.flatten - (List.map - (fun marshalled -> - match marshalled, t.Param.typedef.Rpc.Types.ty with - | Rpc.Enum [], Rpc.Types.Option _ -> - params - | Rpc.Enum [x], Rpc.Types.Option _ -> - List.map - (fun (named,unnamed) -> - (((n, x)::named),unnamed)) - params - | _, _ -> - List.map - (fun (named,unnamed) -> - (((n,marshalled)::named),unnamed)) - params - ) marshalled + let declare_ response_needed name _ ty = + let rec inner : + type b. ((string * Rpc.t) list * Rpc.t list) list -> b fn -> unit = + fun params -> function + | Function (t, f) -> ( + let vs = + Rpc_genfake.genall 2 + ( match t.Param.name with + | Some n -> + n + | None -> + t.Param.typedef.Rpc.Types.name ) - ) f - | None -> inner (List.flatten (List.map (fun marshalled -> List.map (fun (named,unnamed) -> (named,(marshalled::unnamed))) params) marshalled)) f - end + t.Param.typedef.Rpc.Types.ty + in + let marshalled = + List.map + (fun v -> Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v) + vs + in + match t.Param.name with + | Some n -> + inner + (List.flatten + (List.map + (fun marshalled -> + match (marshalled, t.Param.typedef.Rpc.Types.ty) with + | Rpc.Enum [], Rpc.Types.Option _ -> + params + | Rpc.Enum [x], Rpc.Types.Option _ -> + List.map + (fun (named, unnamed) -> + ((n, x) :: named, unnamed)) + params + | _, _ -> + List.map + (fun (named, unnamed) -> + ((n, marshalled) :: named, unnamed)) + params) + marshalled)) + f + | None -> + inner + (List.flatten + (List.map + (fun marshalled -> + List.map + (fun (named, unnamed) -> + (named, marshalled :: unnamed)) + params) + marshalled)) + f + ) | Returning (t, e) -> - let wire_name = Idl.get_wire_name !description name in - let calls = List.map - (fun (named,unnamed) -> - let args = - match named with - | [] -> List.rev unnamed - | _ -> (Rpc.Dict named) :: List.rev unnamed + let wire_name = Idl.get_wire_name !description name in + let calls = + List.map + (fun (named, unnamed) -> + let args = + match named with + | [] -> + List.rev unnamed + | _ -> + Rpc.Dict named :: List.rev unnamed + in + let rpccall = + if response_needed then Rpc.notification else Rpc.call + in + rpccall wire_name args) + params + in + List.iteri + (fun i call -> + let request_str = string_of_call call in + write_str + (Printf.sprintf "%s/requests/%s.request.%d" C.test_data_path + wire_name i) + request_str) + calls ; + let vs = + Rpc_genfake.genall 2 + ( match t.Param.name with + | Some n -> + n + | None -> + t.Param.typedef.Rpc.Types.name + ) + t.Param.typedef.Rpc.Types.ty + in + let marshalled_vs = + List.map + (fun v -> + Rpc.success (Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v)) + vs + in + let errs = Rpc_genfake.genall 2 "error" e.Error.def.Rpc.Types.ty in + let marshalled_errs = + List.map + (fun err -> + Rpc.failure (Rpcmarshal.marshal e.Error.def.Rpc.Types.ty err)) + errs in - let call = Rpc.call wire_name args in - call) params in - List.iteri (fun i call -> - let request_str = string_of_call call in - write_str - (Printf.sprintf "%s/requests/%s.request.%d" C.test_data_path wire_name i) - request_str) calls; - let vs = Rpc_genfake.genall 2 (match t.Param.name with Some n -> n | None -> t.Param.typedef.Rpc.Types.name) t.Param.typedef.Rpc.Types.ty in - let marshalled_vs = List.map (fun v -> Rpc.success (Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v)) vs in - let errs = Rpc_genfake.genall 2 "error" e.Error.def.Rpc.Types.ty in - let marshalled_errs = List.map (fun err -> Rpc.failure (Rpcmarshal.marshal e.Error.def.Rpc.Types.ty err)) errs in - List.iteri (fun i response -> - let response_str = string_of_response response in - write_str - (Printf.sprintf "%s/responses/%s.response.%d" C.test_data_path wire_name i) - response_str) (marshalled_vs @ marshalled_errs) + List.iteri + (fun i response -> + let response_str = string_of_response response in + write_str + (Printf.sprintf "%s/responses/%s.response.%d" C.test_data_path + wire_name i) + response_str) + (marshalled_vs @ marshalled_errs) in let test_fn () = - let mkdir_safe p = begin try Unix.mkdir p 0o755 with Unix.Unix_error (EEXIST, _, _) -> () end in - mkdir_safe C.test_data_path; - mkdir_safe (Printf.sprintf "%s/requests" C.test_data_path); - mkdir_safe (Printf.sprintf "%s/responses" C.test_data_path); - inner [[],[]] ty in - tests := (Printf.sprintf "Generate test data for '%s'" (Idl.get_wire_name !description name), `Quick, test_fn) :: !tests + let mkdir_safe p = + try Unix.mkdir p 0o755 with Unix.Unix_error (EEXIST, _, _) -> () + in + mkdir_safe C.test_data_path ; + mkdir_safe (Printf.sprintf "%s/requests" C.test_data_path) ; + mkdir_safe (Printf.sprintf "%s/responses" C.test_data_path) ; + inner [([], [])] ty + in + tests := + ( Printf.sprintf "Generate test data for '%s'" + (Idl.get_wire_name !description name) + , `Quick + , test_fn ) + :: !tests + + let declare name desc_list ty = declare_ false name desc_list ty + + let declare_notification name desc_list ty = declare_ true name desc_list ty end let get_arg call has_named name is_opt = - match has_named, name, call.Rpc.params with - | true, Some n, (Rpc.Dict named)::unnamed -> begin - match List.partition (fun (x,_) -> x = n) named with - | (_,arg)::dups,others when is_opt -> - Result.Ok (Rpc.Enum [arg], {call with Rpc.params = (Rpc.Dict (dups @ others))::unnamed }) - | [], _others when is_opt -> Result.Ok (Rpc.Enum [], call) - | (_,arg)::dups,others -> - Result.Ok (arg, {call with Rpc.params = (Rpc.Dict (dups @ others))::unnamed }) - | _,_ -> Result.Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n)) - end - | true, None, (Rpc.Dict named)::unnamed -> begin - match unnamed with - | head::tail -> Result.Ok (head, {call with Rpc.params = (Rpc.Dict named)::tail}) - | _ -> Result.Error (`Msg "Incorrect number of arguments") - end - | true, _, _ -> begin - Result.Error (`Msg "Marshalling error: Expecting dict as first argument when named parameters exist") - end - | false, None, head::tail -> begin - Result.Ok (head, {call with Rpc.params = tail}) - end + match (has_named, name, call.Rpc.params) with + | true, Some n, Rpc.Dict named :: unnamed -> ( + match List.partition (fun (x, _) -> x = n) named with + | (_, arg) :: dups, others when is_opt -> + Result.Ok + ( Rpc.Enum [arg] + , {call with Rpc.params= Rpc.Dict (dups @ others) :: unnamed} ) + | [], _others when is_opt -> + Result.Ok (Rpc.Enum [], call) + | (_, arg) :: dups, others -> + Result.Ok + (arg, {call with Rpc.params= Rpc.Dict (dups @ others) :: unnamed}) + | _, _ -> + Result.Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n)) + ) + | true, None, Rpc.Dict named :: unnamed -> ( + match unnamed with + | head :: tail -> + Result.Ok (head, {call with Rpc.params= Rpc.Dict named :: tail}) + | _ -> + Result.Error (`Msg "Incorrect number of arguments") + ) + | true, _, _ -> + Result.Error + (`Msg + "Marshalling error: Expecting dict as first argument when named \ + parameters exist") + | false, None, head :: tail -> + Result.Ok (head, {call with Rpc.params= tail}) | false, None, [] -> - Result.Error (`Msg "Incorrect number of arguments") + Result.Error (`Msg "Incorrect number of arguments") | false, Some _, _ -> - failwith "Can't happen by construction" + failwith "Can't happen by construction" exception NoDescription -exception MarshalError of string +exception MarshalError of string -(** The following module will generate alcotest test cases to verify - that a set of requests and responses can be successfully parsed. +(** The following module will generate alcotest test cases to verify that a set + of requests and responses can be successfully parsed. The CONFIG module specifies the location for the test data as - `test_data_path`. Requests and responses will be looked up in - this location in the subdirectories `requests` and `responses`. - The actual data must be in files following the naming convention - .request. and .response.. - - The code here closely follows that of the GenServer module to - ensure it accurately represents how the server would parse the - json. - *) + `test_data_path`. Requests and responses will be looked up in this location + in the subdirectories `requests` and `responses`. The actual data must be in + files following the naming convention .request. and + .response.. + + The code here closely follows that of the GenServer module to ensure it + accurately represents how the server would parse the json. *) module TestOldRpcs (C : CONFIG) (M : MARSHALLER) = struct open Rpc + type implementation = unit Alcotest.test_case list ref let tests : implementation = ref [] + let description = ref None - let implement x = description := Some x; tests + let implement x = + description := Some x ; + tests + + type ('a, 'b) comp = unit - type ('a,'b) comp = unit type 'a res = unit type _ fn = | Function : 'a Param.t * 'b fn -> ('a -> 'b) fn | Returning : ('a Param.t * 'b Error.t) -> (_, _) comp fn - let returning a b = Returning (a,b) - let (@->) = fun t f -> Function (t, f) + let returning a b = Returning (a, b) + + let ( @-> ) t f = Function (t, f) open M - let rec has_named_args : type a. a fn -> bool = - function - | Function (t, f) -> begin - match t.Param.name with - | Some _ -> true - | None -> has_named_args f - end + let rec has_named_args : type a. a fn -> bool = function + | Function (t, f) -> ( + match t.Param.name with Some _ -> true | None -> has_named_args f + ) | Returning (_, _) -> - false - - let declare : string -> string list -> 'a fn -> _ res = fun name _ ty -> - begin - (* Sanity check: ensure the description has been set before we declare - any RPCs *) - match !description with - | Some _ -> () - | None -> raise NoDescription - end; - + false + + let declare_ : bool -> string -> string list -> 'a fn -> _ res = + fun _notification name _ ty -> + ( (* Sanity check: ensure the description has been set before we declare any + RPCs *) + match !description with + | Some _ -> + () + | None -> + raise NoDescription + ) ; let wire_name = Idl.get_wire_name !description name in - let rec read_all path extension i = try let call = - read_str (Printf.sprintf "%s/%s/%s.%s.%d" C.test_data_path path wire_name extension i) in - call :: read_all path extension (i+1) + read_str + (Printf.sprintf "%s/%s/%s.%s.%d" C.test_data_path path wire_name + extension i) + in + call :: read_all path extension (i + 1) with _ -> [] in - let calls = read_all "requests" "request" 0 |> List.map call_of_string in - let responses = read_all "responses" "response" 0 |> List.map response_of_string in - - let verify : type a. a Rpc.Types.typ -> Rpc.t -> a = fun typ rpc -> + let responses = + read_all "responses" "response" 0 |> List.map response_of_string + in + let verify : type a. a Rpc.Types.typ -> Rpc.t -> a = + fun typ rpc -> let rec sort_dicts ty = let open Rpc in match ty with | Dict kvs' -> - let kvs = List.map (fun (k,v) -> (k, sort_dicts v)) kvs' in - Dict (List.sort (fun (k1,_) (k2,_) -> String.compare k1 k2) kvs) - | Enum ts -> Enum (List.map sort_dicts ts) - | _ -> ty + let kvs = List.map (fun (k, v) -> (k, sort_dicts v)) kvs' in + Dict (List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) kvs) + | Enum ts -> + Enum (List.map sort_dicts ts) + | _ -> + ty in match Rpcmarshal.unmarshal typ rpc with | Ok x -> - let check = Rpcmarshal.marshal typ x in - if (to_string (sort_dicts check)) <> (to_string (sort_dicts rpc)) then begin - match Rpcmarshal.unmarshal typ check with - | Ok y when y <> x -> - let err = Printf.sprintf "Round-trip failed (OCaml values different too). Before: '%s' After: '%s'" - (to_string rpc) - (to_string check) in - raise (MarshalError err) - | Ok _ -> () - | Error (`Msg m) -> - raise (MarshalError m) - end; - x + let check = Rpcmarshal.marshal typ x in + ( if to_string (sort_dicts check) <> to_string (sort_dicts rpc) then + match Rpcmarshal.unmarshal typ check with + | Ok y when y <> x -> + let err = + Printf.sprintf + "Round-trip failed (OCaml values different too). Before: \ + '%s' After: '%s'" + (to_string rpc) (to_string check) + in + raise (MarshalError err) + | Ok _ -> + () + | Error (`Msg m) -> + raise (MarshalError m) + ) ; + x | Error (`Msg m) -> - raise (MarshalError m) + raise (MarshalError m) in - let testfn call response = let has_named = has_named_args ty in - let rec inner : type a. a fn -> Rpc.call -> unit = fun f call -> + let rec inner : type a. a fn -> Rpc.call -> unit = + fun f call -> match f with - | Function (t, f) -> begin - let (arg_rpc, call') = - let is_opt = match t.Param.typedef.Rpc.Types.ty with Rpc.Types.Option _ -> true | _ -> false in + | Function (t, f) -> + let arg_rpc, call' = + let is_opt = + match t.Param.typedef.Rpc.Types.ty with + | Rpc.Types.Option _ -> + true + | _ -> + false + in match get_arg call has_named t.Param.name is_opt with - | Result.Ok (x,y) -> (x,y) - | Result.Error (`Msg m) -> raise (MarshalError m) + | Result.Ok (x, y) -> + (x, y) + | Result.Error (`Msg m) -> + raise (MarshalError m) in - verify t.Param.typedef.Rpc.Types.ty arg_rpc |> ignore; + verify t.Param.typedef.Rpc.Types.ty arg_rpc |> ignore ; inner f call' - end - | Returning (t,e) -> begin + | Returning (t, e) -> ( match response.success with | true -> - verify t.Param.typedef.Rpc.Types.ty response.contents |> ignore + verify t.Param.typedef.Rpc.Types.ty response.contents |> ignore | false -> - verify e.Error.def.Rpc.Types.ty response.contents |> ignore - end - in inner ty call + verify e.Error.def.Rpc.Types.ty response.contents |> ignore + ) + in + inner ty call in (* Check all calls *) let request_tests = - List.mapi (fun i call -> - let response = List.hd responses in - let name = Printf.sprintf "Check old request for '%s': %d" wire_name i in - (name, `Quick, fun () -> testfn call response)) calls in + List.mapi + (fun i call -> + let response = List.hd responses in + let name = + Printf.sprintf "Check old request for '%s': %d" wire_name i + in + (name, `Quick, fun () -> testfn call response)) + calls + in (* Now check all responses *) let response_tests = - List.mapi (fun i response -> - let call = List.hd calls in - let name = Printf.sprintf "Check old response for '%s': %d" wire_name i in - (name, `Quick, fun () -> testfn call response)) responses in - + List.mapi + (fun i response -> + let call = List.hd calls in + let name = + Printf.sprintf "Check old response for '%s': %d" wire_name i + in + (name, `Quick, fun () -> testfn call response)) + responses + in tests := !tests @ request_tests @ response_tests + let declare name desc_list ty = declare_ false name desc_list ty + + let declare_notification name desc_list ty = declare_ true name desc_list ty end diff --git a/lib_test/memory_interface_test.ml b/lib_test/memory_interface_test.ml index 041d171e..06f7e690 100644 --- a/lib_test/memory_interface_test.ml +++ b/lib_test/memory_interface_test.ml @@ -1,11 +1,10 @@ - open Idl_test_common module GenPath = struct let test_data_path = "mem_gen" end + module OldPath = struct let test_data_path = "test_data/memory" end -module C = Memory_interface.API(GenTestData(GenPath)(TJsonrpc)) -module T = Memory_interface.API(TestOldRpcs(OldPath)(TJsonrpc)) +module C = Memory_interface.API (GenTestData (GenPath) (TJsonrpc)) +module T = Memory_interface.API (TestOldRpcs (OldPath) (TJsonrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/network_interface_test.ml b/lib_test/network_interface_test.ml index ce6744fd..bcb43d91 100644 --- a/lib_test/network_interface_test.ml +++ b/lib_test/network_interface_test.ml @@ -1,12 +1,10 @@ - - open Idl_test_common module GenPath = struct let test_data_path = "net_gen" end + module OldPath = struct let test_data_path = "test_data/network" end -module C = Network_interface.Interface_API(GenTestData(GenPath)(TJsonrpc)) -module T = Network_interface.Interface_API(TestOldRpcs(OldPath)(TJsonrpc)) +module C = Network_interface.Interface_API (GenTestData (GenPath) (TJsonrpc)) +module T = Network_interface.Interface_API (TestOldRpcs (OldPath) (TJsonrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/rrd_interface_test.ml b/lib_test/rrd_interface_test.ml index 9b006c65..b3c7ebf7 100644 --- a/lib_test/rrd_interface_test.ml +++ b/lib_test/rrd_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "rrd_gen" end + module OldPath = struct let test_data_path = "test_data/rrd" end -module C = Rrd_interface.RPC_API(GenTestData(GenPath)(TXmlrpc)) -module T = Rrd_interface.RPC_API(TestOldRpcs(OldPath)(TXmlrpc)) +module C = Rrd_interface.RPC_API (GenTestData (GenPath) (TXmlrpc)) +module T = Rrd_interface.RPC_API (TestOldRpcs (OldPath) (TXmlrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/scheduler_test.ml b/lib_test/scheduler_test.ml index 1d9129cc..f076a668 100644 --- a/lib_test/scheduler_test.ml +++ b/lib_test/scheduler_test.ml @@ -1,4 +1,3 @@ - let assert_bool msg = Alcotest.(check bool) msg true let global_scheduler = Scheduler.make () @@ -8,10 +7,10 @@ let test_delay () = let open Scheduler.Delay in let x = make () in let before = Unix.gettimeofday () in - ignore(wait x 0.5); + ignore (wait x 0.5) ; let after = Unix.gettimeofday () in let elapsed = after -. before in - assert_bool "elapsed_time1" (elapsed < 0.6); + assert_bool "elapsed_time1" (elapsed < 0.6) ; assert_bool "elapsed_time2" (elapsed > 0.4) (* Tests that 'wait' can be cancelled *) @@ -20,89 +19,87 @@ let test_delay_cancel () = let x = make () in let before = Unix.gettimeofday () in let th = Thread.create (fun () -> wait x 0.5) () in - signal x; - Thread.join th; + signal x ; + Thread.join th ; let after = Unix.gettimeofday () in let elapsed = after -. before in assert_bool "elapsed_time1" (elapsed < 0.4) -let timed_wait_callback ~msg ?(time_min = 0.) ?(eps=0.1) ?(time_max = 60.) f = +let timed_wait_callback ~msg ?(time_min = 0.) ?(eps = 0.1) ?(time_max = 60.) f = let rd, wr = Unix.pipe () in - let finally () = - Unix.close rd; - Unix.close wr - in + let finally () = Unix.close rd ; Unix.close wr in Fun.protect ~finally (fun () -> let before = Unix.gettimeofday () in let after = ref None in let callback () = - after := Some (Unix.gettimeofday ()); - let (_:int) = Unix.write_substring wr " " 0 1 in + after := Some (Unix.gettimeofday ()) ; + let (_ : int) = Unix.write_substring wr " " 0 1 in () in - f callback; + f callback ; let ready = Thread.wait_timed_read rd time_max in - match ready, !after with + match (ready, !after) with | true, None -> - Alcotest.fail "pipe ready to read, but after is not set" + Alcotest.fail "pipe ready to read, but after is not set" | false, None -> - Alcotest.fail (Printf.sprintf "%s: callback not invoked within %gs" msg time_max) + Alcotest.fail + (Printf.sprintf "%s: callback not invoked within %gs" msg time_max) | _, Some t -> - let actual_minimum = min (t -. before) time_min in - Alcotest.(check (float eps)) - (Printf.sprintf "%s: callback invoked earlier than expected" msg) time_min actual_minimum) - + let actual_minimum = min (t -. before) time_min in + Alcotest.(check (float eps)) + (Printf.sprintf "%s: callback invoked earlier than expected" msg) + time_min actual_minimum) (* Test the injection of a one-shot function at a time in the future *) let test_one_shot () = timed_wait_callback ~msg:"one_shot_success" ~time_min:1.0 (fun callback -> - ignore @@ Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot" callback) + ignore + @@ Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot" + callback) -(* Test the injection of a one-shot function at an absolute time *) -let test_one_shot_abs () = - timed_wait_callback ~msg:"one_shot_abs_success" ~time_min:1.0 (fun callback -> - let now = Scheduler.now () in - ignore @@ Scheduler.one_shot global_scheduler (Scheduler.Absolute (Int64.add 1L now)) "test_one_shot" callback) - -(* Tests that the scheduler still works even after a failure occurs in - the injected function *) +(* Tests that the scheduler still works even after a failure occurs in the + injected function *) let test_one_shot_failure () = timed_wait_callback ~msg:"one_show_failure" ~time_min:1.0 (fun callback -> - let _ = Scheduler.one_shot global_scheduler (Scheduler.Delta 0) "test_one_shot" - (fun () -> failwith "Error") in - ignore @@ Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot" - callback) + let _ = + Scheduler.one_shot global_scheduler (Scheduler.Delta 0) "test_one_shot" + (fun () -> failwith "Error") + in + ignore + @@ Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot" + callback) (* Checks that one-shot functions can cancelled and are then not executed *) let test_one_shot_cancel () = let after = ref None in - let x = Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot_cancel" (fun () -> after := Some (Unix.gettimeofday ())) in - Scheduler.cancel global_scheduler x; - Thread.delay 2.0; - let success = - match !after with - | Some _ -> false - | None -> true + let x = + Scheduler.one_shot global_scheduler (Scheduler.Delta 1) + "test_one_shot_cancel" (fun () -> after := Some (Unix.gettimeofday ())) in + Scheduler.cancel global_scheduler x ; + Thread.delay 2.0 ; + let success = match !after with Some _ -> false | None -> true in assert_bool "one_shot_cancelled" success -(* Check that dumping the state of the scheduler contains a reference to - a test function that has been injected *) +(* Check that dumping the state of the scheduler contains a reference to a test + function that has been injected *) let test_dump () = let after = ref None in let _before = Unix.gettimeofday () in - let _ = Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_dump" - (fun () -> after := Some (Unix.gettimeofday ())) in + let _ = + Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_dump" + (fun () -> after := Some (Unix.gettimeofday ())) + in let dump = Scheduler.Dump.make global_scheduler in - assert_bool "dump_contains_item" (List.exists (fun x -> x.Scheduler.Dump.thing = "test_dump") dump) + assert_bool "dump_contains_item" + (List.exists (fun x -> x.Scheduler.Dump.thing = "test_dump") dump) let tests = [ - "Test Delay", `Slow, test_delay; - "Test Delay cancellation", `Quick, test_delay_cancel; - "Test One shot", `Slow, test_one_shot; - "Test One shot absolute", `Slow, test_one_shot_abs; - "Test One shot failure", `Slow, test_one_shot_failure; - "Test One shot cancellation", `Slow, test_one_shot_cancel; - "Test dump", `Quick, test_dump; + ("Test Delay", `Slow, test_delay) + ; ("Test Delay cancellation", `Quick, test_delay_cancel) + ; ("Test One shot", `Slow, test_one_shot) + ; ("Test One shot failure", `Slow, test_one_shot_failure) + ; ("Test One shot cancellation", `Slow, test_one_shot_cancel) + ; ("Test dump", `Quick, test_dump) ] diff --git a/lib_test/storage_interface_test.ml b/lib_test/storage_interface_test.ml index 203259db..4f057ebd 100644 --- a/lib_test/storage_interface_test.ml +++ b/lib_test/storage_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "storage_gen" end + module OldPath = struct let test_data_path = "test_data/storage" end -module C = Storage_interface.StorageAPI(GenTestData(GenPath)(TXmlrpc)) -module T = Storage_interface.StorageAPI(TestOldRpcs(OldPath)(TXmlrpc)) +module C = Storage_interface.StorageAPI (GenTestData (GenPath) (TXmlrpc)) +module T = Storage_interface.StorageAPI (TestOldRpcs (OldPath) (TXmlrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/syslog_test.ml b/lib_test/syslog_test.ml index 07b00b34..e2e13615 100644 --- a/lib_test/syslog_test.ml +++ b/lib_test/syslog_test.ml @@ -1,24 +1,20 @@ - -(* Test which log levels are masked off by each threshhold level. - Levels are ordered by severity - Err is the highest, Debug the - lowest. If the log threshold is set to Warning, the less - severe levels (Info and Debug) should be masked out. *) +(* Test which log levels are masked off by each threshhold level. Levels are + ordered by severity - Err is the highest, Debug the lowest. If the log + threshold is set to Warning, the less severe levels (Info and Debug) should + be masked out. *) let assert_masked ~threshold (err, warn, info, debug) = - let open Syslog in - assert ((is_masked ~threshold:threshold Err) = err); - assert ((is_masked ~threshold:threshold Warning) = warn); - assert ((is_masked ~threshold:threshold Info) = info); - assert ((is_masked ~threshold:threshold Debug) = debug) + let open Syslog in + assert (is_masked ~threshold Err = err) ; + assert (is_masked ~threshold Warning = warn) ; + assert (is_masked ~threshold Info = info) ; + assert (is_masked ~threshold Debug = debug) let test_is_masked () = - let open Syslog in - assert_masked ~threshold:Debug (false, false, false, false); - assert_masked ~threshold:Info (false, false, false, true); - assert_masked ~threshold:Warning (false, false, true, true); - assert_masked ~threshold:Err (false, true, true, true) + let open Syslog in + assert_masked ~threshold:Debug (false, false, false, false) ; + assert_masked ~threshold:Info (false, false, false, true) ; + assert_masked ~threshold:Warning (false, false, true, true) ; + assert_masked ~threshold:Err (false, true, true, true) -let tests = - [ - "Test Syslog.is_masked", `Quick, test_is_masked; - ] +let tests = [("Test Syslog.is_masked", `Quick, test_is_masked)] diff --git a/lib_test/task_server_test.ml b/lib_test/task_server_test.ml index b58f458e..e8de91c2 100644 --- a/lib_test/task_server_test.ml +++ b/lib_test/task_server_test.ml @@ -1,34 +1,37 @@ - let assert_bool msg = Alcotest.(check bool) msg true module TestInterface = struct let service_name = "test_interface" exception Does_not_exist of (string * string) + exception Cancelled of string - let does_not_exist (a,b) = raise @@ Does_not_exist(a,b) + + let does_not_exist (a, b) = raise @@ Does_not_exist (a, b) + let cancelled a = raise @@ Cancelled a module Task = struct type id = string + type async_result = string [@@deriving rpc] - type completion_t = { - duration : float; - result: async_result option; - } + + type completion_t = {duration: float; result: async_result option} + type state = | Pending of float | Completed of completion_t | Failed of Rpc.t + type t = { - id: id; - dbg: string; - ctime: float; - state: state; - subtasks: (string * state) list; - debug_info: (string * string) list; - backtrace: string; - cancellable: bool; + id: id + ; dbg: string + ; ctime: float + ; state: state + ; subtasks: (string * state) list + ; debug_info: (string * string) list + ; backtrace: string + ; cancellable: bool } end @@ -37,26 +40,36 @@ module TestInterface = struct | Internal_error of string | Does_not_exist of string * string | Cancelled of string - | Unknown of string [@@deriving rpc] + | Unknown of string + [@@deriving rpc] end exception Internal_error of string let exnty_of_exn = function - | Internal_error s -> Exception.Internal_error s - | Cancelled s -> Exception.Cancelled s - | Does_not_exist (x,y) -> Exception.Does_not_exist (x,y) - | e -> Exception.Unknown (Printexc.to_string e) + | Internal_error s -> + Exception.Internal_error s + | Cancelled s -> + Exception.Cancelled s + | Does_not_exist (x, y) -> + Exception.Does_not_exist (x, y) + | e -> + Exception.Unknown (Printexc.to_string e) + let exn_of_exnty = function - | Exception.Internal_error s -> Internal_error s - | Exception.Does_not_exist (x,y) -> Does_not_exist (x,y) - | Exception.Cancelled s -> Cancelled s - | Exception.Unknown s -> Failure s + | Exception.Internal_error s -> + Internal_error s + | Exception.Does_not_exist (x, y) -> + Does_not_exist (x, y) + | Exception.Cancelled s -> + Cancelled s + | Exception.Unknown s -> + Failure s let marshal_exn e = e |> exnty_of_exn |> Exception.rpc_of_exnty end -module T = Task_server.Task(TestInterface) +module T = Task_server.Task (TestInterface) (* Test that we can add a task and retrieve it from the task list *) let test_add () = @@ -69,251 +82,308 @@ let test_add () = let test_destroy () = let t = T.empty () in let task = T.add t "dbg" (fun _task -> Some "done") in - T.destroy task; + T.destroy task ; let ts = T.list t in assert_bool "Task not in task list" (not (List.mem task ts)) -(* Test 'running' a task, and that the various times associated with the - task make sense, and that the task status is correctly completed with - correct result *) +(* Test 'running' a task, and that the various times associated with the task + make sense, and that the task status is correctly completed with correct + result *) let test_run () = let t = T.empty () in let start = Unix.gettimeofday () in - Thread.delay 0.001; - let task = T.add t "dbg" (fun _task -> Thread.delay 0.001; Some "done") in - T.run task; + Thread.delay 0.001 ; + let task = T.add t "dbg" (fun _task -> Thread.delay 0.001 ; Some "done") in + T.run task ; let t' = T.to_interface_task task in - assert_bool "Task ctime" (t'.TestInterface.Task.ctime > start); + assert_bool "Task ctime" (t'.TestInterface.Task.ctime > start) ; assert_bool "Task result" - (match t'.TestInterface.Task.state with - | TestInterface.Task.Completed {TestInterface.Task.result=Some r; duration} -> - r = "done" && duration > 0.0 - | _ -> false) + ( match t'.TestInterface.Task.state with + | TestInterface.Task.Completed {TestInterface.Task.result= Some r; duration} + -> + r = "done" && duration > 0.0 + | _ -> + false + ) (* Test what happens when the function passed to the task server raises an exception. The task result should be failed with the correct exception *) let test_raise () = - Debug.disable "task_server"; + Debug.disable "task_server" ; let t = T.empty () in - let task = T.add t "dbg" (fun _task -> raise (TestInterface.Internal_error "test")) in - T.run task; + let task = + T.add t "dbg" (fun _task -> raise (TestInterface.Internal_error "test")) + in + T.run task ; let t' = T.to_interface_task task in assert_bool "Task result" - (match t'.TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let s = TestInterface.Exception.exnty_of_rpc r in - s = TestInterface.Exception.Internal_error "test" - with _ -> false - end - | _ -> false) + ( match t'.TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let s = TestInterface.Exception.exnty_of_rpc r in + s = TestInterface.Exception.Internal_error "test" + with _ -> false + ) + | _ -> + false + ) -(* Test cancellation of a task, in this case cancelled before the task is - run. The state should be 'failed' with exception 'cancelled' *) +(* Test cancellation of a task, in this case cancelled before the task is run. + The state should be 'failed' with exception 'cancelled' *) let test_cancel () = let t = T.empty () in - let task = T.add t "dbg" (fun task -> T.check_cancelling task; Some "foo") in + let task = T.add t "dbg" (fun task -> T.check_cancelling task ; Some "foo") in let id = T.id_of_handle task in - T.cancel task; - T.run task; + T.cancel task ; + T.run task ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) -(* Tests the 'with_cancel' function. Tests that the cancel function gets - run on cancellation. In this case, the cancellation happens before the - task is run *) +(* Tests the 'with_cancel' function. Tests that the cancel function gets run on + cancellation. In this case, the cancellation happens before the task is run *) let test_with_cancel () = let t = T.empty () in let cancel_fn_run = ref false in - let task = T.add t "dbg" - (fun task -> T.with_cancel task (fun () -> cancel_fn_run := true) (fun () -> Some "foo")) in + let task = + T.add t "dbg" (fun task -> + T.with_cancel task + (fun () -> cancel_fn_run := true) + (fun () -> Some "foo")) + in let id = T.id_of_handle task in - T.cancel task; - T.run task; + T.cancel task ; + T.run task ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false); + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) ; assert_bool "Cancel_fn run" !cancel_fn_run (* Tests what happens when the 'cancel' function passed to 'with_cancel' itself fails. *) let test_with_cancel_failure () = let t = T.empty () in - let task = T.add t "dbg" - (fun task -> T.with_cancel task (fun () -> failwith "moo") (fun () -> Some "foo")) in + let task = + T.add t "dbg" (fun task -> + T.with_cancel task (fun () -> failwith "moo") (fun () -> Some "foo")) + in let id = T.id_of_handle task in - T.cancel task; - T.run task; + T.cancel task ; + T.run task ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) -(* Similar to test_with_cancel, but in this case the cancellation function - is called after the task is started *) +(* Similar to test_with_cancel, but in this case the cancellation function is + called after the task is started *) let test_with_cancel2 () = let t = T.empty () in let delay = Scheduler.Delay.make () in let cancel_fn_run = ref false in - let task = T.add t "dbg" - (fun task -> - T.with_cancel task (fun () -> cancel_fn_run := true) - (fun () -> ignore (Scheduler.Delay.wait delay 1.0); - T.check_cancelling task; Some "foo")) in + let task = + T.add t "dbg" (fun task -> + T.with_cancel task + (fun () -> cancel_fn_run := true) + (fun () -> + ignore (Scheduler.Delay.wait delay 1.0) ; + T.check_cancelling task ; + Some "foo")) + in let id = T.id_of_handle task in let th = Thread.create (fun () -> T.run task) () in - Thread.delay 0.01; - T.cancel task; - Scheduler.Delay.signal delay; - Thread.join th; + Thread.delay 0.01 ; + T.cancel task ; + Scheduler.Delay.signal delay ; + Thread.join th ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false); + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) ; assert_bool "Cancel_fn run" !cancel_fn_run -(* Similar to test_with_cancel_failure, but as above the cancel_fn is - called after the task has started *) +(* Similar to test_with_cancel_failure, but as above the cancel_fn is called + after the task has started *) let test_with_cancel_failure2 () = let t = T.empty () in let delay = Scheduler.Delay.make () in - let task = T.add t "dbg" - (fun task -> - T.with_cancel task (fun () -> failwith "moo") - (fun () -> ignore (Scheduler.Delay.wait delay 1.0); - T.check_cancelling task; Some "foo")) in + let task = + T.add t "dbg" (fun task -> + T.with_cancel task + (fun () -> failwith "moo") + (fun () -> + ignore (Scheduler.Delay.wait delay 1.0) ; + T.check_cancelling task ; + Some "foo")) + in let id = T.id_of_handle task in let th = Thread.create (fun () -> T.run task) () in - Thread.delay 0.01; - T.cancel task; - Scheduler.Delay.signal delay; - Thread.join th; + Thread.delay 0.01 ; + T.cancel task ; + Scheduler.Delay.signal delay ; + Thread.join th ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) -(* Check the 'subtask' functionality. Subtasks are logged in the task - record. *) +(* Check the 'subtask' functionality. Subtasks are logged in the task record. *) let test_subtasks () = let t = T.empty () in - let task = T.add t "dbg" - (fun task -> - let _ : int = T.with_subtask task "subtask1" (fun () -> 0) in - Some "done") in + let task = + T.add t "dbg" (fun task -> + let (_ : int) = T.with_subtask task "subtask1" (fun () -> 0) in + Some "done") + in let _id = T.id_of_handle task in - T.run task; + T.run task ; assert_bool "Subtasks" - ((List.hd (T.to_interface_task task).TestInterface.Task.subtasks |> fst) = "subtask1"); + (List.hd (T.to_interface_task task).TestInterface.Task.subtasks + |> fst + = "subtask1" + ) ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Completed {TestInterface.Task.result=Some r; duration=_} -> - r = "done" - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Completed + {TestInterface.Task.result= Some r; duration= _} -> + r = "done" + | _ -> + false + ) -(* Check what happens when subtasks fail. The whole task should be marked - as failed, and the individual task that caused the problem should be - marked as failed in the task record, with the correct exception. *) +(* Check what happens when subtasks fail. The whole task should be marked as + failed, and the individual task that caused the problem should be marked as + failed in the task record, with the correct exception. *) let test_subtasks_failure () = let t = T.empty () in - let task = T.add t "dbg" - (fun task -> - let _ : int = T.with_subtask task "subtask1" - (fun () -> raise (TestInterface.Internal_error "foo")) in - Some "done") in - T.run task; - let subtask = List.hd (T.to_interface_task task).TestInterface.Task.subtasks in - assert_bool "Subtasks" - (fst subtask = "subtask1"); + let task = + T.add t "dbg" (fun task -> + let (_ : int) = + T.with_subtask task "subtask1" (fun () -> + raise (TestInterface.Internal_error "foo")) + in + Some "done") + in + T.run task ; + let subtask = + List.hd (T.to_interface_task task).TestInterface.Task.subtasks + in + assert_bool "Subtasks" (fst subtask = "subtask1") ; assert_bool "Subtasks" - (match snd subtask with - | TestInterface.Task.Failed r -> - r |> TestInterface.Exception.exnty_of_rpc = TestInterface.Exception.Internal_error "foo" - | _ -> false); + ( match snd subtask with + | TestInterface.Task.Failed r -> + r + |> TestInterface.Exception.exnty_of_rpc + = TestInterface.Exception.Internal_error "foo" + | _ -> + false + ) ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - r |> TestInterface.Exception.exnty_of_rpc = TestInterface.Exception.Internal_error "foo" - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> + r + |> TestInterface.Exception.exnty_of_rpc + = TestInterface.Exception.Internal_error "foo" + | _ -> + false + ) -(* Test the cancellation points functionality. In here, we ask for task 'dbg' - to be cancelled at the 5th time it checks for cancellation. Verify this - succeeds for the task specified, and doesn't for the other task *) +(* Test the cancellation points functionality. In here, we ask for task 'dbg' to + be cancelled at the 5th time it checks for cancellation. Verify this succeeds + for the task specified, and doesn't for the other task *) let test_cancel_trigger () = let t = T.empty () in - T.set_cancel_trigger t "dbg" 5; + T.set_cancel_trigger t "dbg" 5 ; let xxx = ref 0 in let dbg = ref 0 in let fn x task = let rec loop n = - x := n; - if n=0 then () else (T.check_cancelling task; loop (n-1)) - in loop 10; - Some "done" + x := n ; + if n = 0 then + () + else ( + T.check_cancelling task ; + loop (n - 1) + ) + in + loop 10 ; Some "done" in let task1 = T.add t "xxx" (fn xxx) in let task2 = T.add t "dbg" (fn dbg) in let id2 = T.id_of_handle task2 in - T.run task1; - T.run task2; + T.run task1 ; + T.run task2 ; assert_bool "Task result" - (match (T.to_interface_task task2).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id2 - with _ -> false end - | _ -> false); + ( match (T.to_interface_task task2).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id2 + with _ -> false + ) + | _ -> + false + ) ; assert_bool "Task result" - (match (T.to_interface_task task1).TestInterface.Task.state with - | TestInterface.Task.Completed {TestInterface.Task.result=Some r; duration=_} -> - r = "done" - | _ -> false); - assert_bool "cancel points xxx" (!xxx = 0); + ( match (T.to_interface_task task1).TestInterface.Task.state with + | TestInterface.Task.Completed + {TestInterface.Task.result= Some r; duration= _} -> + r = "done" + | _ -> + false + ) ; + assert_bool "cancel points xxx" (!xxx = 0) ; assert_bool "cancel points dbg" (!dbg = 6) let tests = [ - "Test adding a task", `Quick, test_add; - "Test removing a task", `Quick, test_destroy; - "Test run", `Quick, test_run; - "Test raise", `Quick, test_raise; - "Test cancel", `Quick, test_cancel; - "Test with_cancel", `Quick, test_with_cancel; - "Test with_cancel_failure", `Quick, test_with_cancel_failure; - "Test with_cancel 2", `Quick, test_with_cancel2; - "Test with_cancel_failure2", `Quick, test_with_cancel_failure2; - "Test subtasks", `Quick, test_subtasks; - "Test subtask failure", `Quick, test_subtasks_failure; - "Test cancel trigger", `Quick, test_cancel_trigger; + ("Test adding a task", `Quick, test_add) + ; ("Test removing a task", `Quick, test_destroy) + ; ("Test run", `Quick, test_run) + ; ("Test raise", `Quick, test_raise) + ; ("Test cancel", `Quick, test_cancel) + ; ("Test with_cancel", `Quick, test_with_cancel) + ; ("Test with_cancel_failure", `Quick, test_with_cancel_failure) + ; ("Test with_cancel 2", `Quick, test_with_cancel2) + ; ("Test with_cancel_failure2", `Quick, test_with_cancel_failure2) + ; ("Test subtasks", `Quick, test_subtasks) + ; ("Test subtask failure", `Quick, test_subtasks_failure) + ; ("Test cancel trigger", `Quick, test_cancel_trigger) ] diff --git a/lib_test/test.ml b/lib_test/test.ml index bc0f0d48..32779202 100644 --- a/lib_test/test.ml +++ b/lib_test/test.ml @@ -1,27 +1,28 @@ let () = Alcotest.run "Base suite" - [ (* interface tests *) - "Test memory interface", Memory_interface_test.tests; - "Test network interface", Network_interface_test.tests; - "Test Gpumon interface", Gpumon_interface_test.tests; - "Test RRD interface", Rrd_interface_test.tests; - "Test Storage interface", Storage_interface_test.tests; - "Test cluster interface", Cluster_interface_test.tests; - "Test varstore privileged interfaces", Varstore_interfaces_test.Privileged.tests; - "Test varstore deprivileged interfaces", Varstore_interfaces_test.Deprivileged.tests; - "Test v6 interface", V6_interface_test.tests; - - (* custom tests *) - "Test Debug module", Debug_test.tests; - "Task_server tests", Task_server_test.tests; - "Udpates tests", Updates_test.tests; - "Scheduler tests", Scheduler_test.tests; - "Syslog tests", Syslog_test.tests; - "Cohttp_posix_io tests", Http_test.tests; - "Xenops_interface tests", Xen_test.tests; - "Device_number tests", Device_number_test.tests; - "xcp-config-file tests", Config_file_test.tests; - (* "xcp-channel-test", Channel_test.tests; TODO: Turn these on when the code works. *) + [ + (* interface tests *) + ("Test memory interface", Memory_interface_test.tests) + ; ("Test network interface", Network_interface_test.tests) + ; ("Test Gpumon interface", Gpumon_interface_test.tests) + ; ("Test RRD interface", Rrd_interface_test.tests) + ; ("Test Storage interface", Storage_interface_test.tests) + ; ("Test cluster interface", Cluster_interface_test.tests) + ; ( "Test varstore privileged interfaces" + , Varstore_interfaces_test.Privileged.tests ) + ; ( "Test varstore deprivileged interfaces" + , Varstore_interfaces_test.Deprivileged.tests ) + ; ("Test v6 interface", V6_interface_test.tests) + ; (* custom tests *) + ("Test Debug module", Debug_test.tests) + ; ("Task_server tests", Task_server_test.tests) + ; ("Udpates tests", Updates_test.tests) + ; ("Scheduler tests", Scheduler_test.tests) + ; ("Syslog tests", Syslog_test.tests) + ; ("Cohttp_posix_io tests", Http_test.tests) + ; ("Xenops_interface tests", Xen_test.tests) + ; ("Device_number tests", Device_number_test.tests) + ; ("xcp-config-file tests", Config_file_test.tests) + (* "xcp-channel-test", Channel_test.tests; TODO: Turn these on when the + code works. *) ] - - diff --git a/lib_test/updates_test.ml b/lib_test/updates_test.ml index a34d0259..28845cea 100644 --- a/lib_test/updates_test.ml +++ b/lib_test/updates_test.ml @@ -2,211 +2,232 @@ let assert_bool msg = Alcotest.(check bool) msg true -let rpc = Alcotest.testable (Fmt.of_to_string Rpc.to_string) (=) +let rpc = Alcotest.testable (Fmt.of_to_string Rpc.to_string) ( = ) (* See xen/xenops_interface.ml for a real example *) module TestInterface = struct let service_name = "test_updates" module Dynamic = struct - type id = Foo of string | Bar of string - [@@deriving rpc] + type id = Foo of string | Bar of string [@@deriving rpc] end end let scheduler = Scheduler.make () + let update_a = TestInterface.Dynamic.Foo "a" + let update_b = TestInterface.Dynamic.Foo "b" + let update_c = TestInterface.Dynamic.Foo "c" -module M = Updates.Updates(TestInterface) +module M = Updates.Updates (TestInterface) (* Tests adding and getting an update *) let test_add () = let u = M.empty scheduler in - M.add update_a u; - let (_barriers,updates,_id) = M.get "dbg" None (Some 0) u in - assert_bool "Update returned" (List.length updates = 1 && List.exists (fun x -> x=update_a) updates) + M.add update_a u ; + let _barriers, updates, _id = M.get "dbg" None (Some 0) u in + assert_bool "Update returned" + (List.length updates = 1 && List.exists (fun x -> x = update_a) updates) (* Tests that no updates are returned if none exist *) let test_noadd () = let u = M.empty scheduler in - let (_barriers,updates,_id) = M.get "dbg" None (Some 0) u in + let _barriers, updates, _id = M.get "dbg" None (Some 0) u in assert_bool "Update returned" (List.length updates = 0) (* Tests that we can remove an update, and that it's not then returned by 'get' *) let test_remove () = let u = M.empty scheduler in - M.add update_a u; - M.remove update_a u; - let (_barriers,updates,_id) = M.get "dbg" None (Some 0) u in + M.add update_a u ; + M.remove update_a u ; + let _barriers, updates, _id = M.get "dbg" None (Some 0) u in assert_bool "Update returned" (List.length updates = 0) -(* Tests that, if we specify a timeout, the 'get' call returns the empty - list after that timeout. *) +(* Tests that, if we specify a timeout, the 'get' call returns the empty list + after that timeout. *) let test_timeout () = let u = M.empty scheduler in let before = Unix.gettimeofday () in - let (_,l,_) = M.get "dbg" None (Some 1) u in + let _, l, _ = M.get "dbg" None (Some 1) u in let duration = Unix.gettimeofday () -. before in - assert_bool "Duration greater than 1 sec" (duration > 1.0 && duration < 2.0); + assert_bool "Duration greater than 1 sec" (duration > 1.0 && duration < 2.0) ; assert_bool "Returned list was empty" (List.length l = 0) -(* Checks that if we add an event after a blocking 'get' call that the call - is unblocked. Verifies that the call returns immediately and that the - correct update was returned. *) +(* Checks that if we add an event after a blocking 'get' call that the call is + unblocked. Verifies that the call returns immediately and that the correct + update was returned. *) let test_add_after_get () = let u = M.empty scheduler in let ok = ref false in let before = Unix.gettimeofday () in - let th = Thread.create (fun () -> - let (_,updates,_) = M.get "dbg" None (Some 0) u in - ok := List.length updates = 1 && List.exists (fun x -> x=update_a) updates) () in - M.add update_a u; - Thread.join th; + let th = + Thread.create + (fun () -> + let _, updates, _ = M.get "dbg" None (Some 0) u in + ok := + List.length updates = 1 && List.exists (fun x -> x = update_a) updates) + () + in + M.add update_a u ; + Thread.join th ; let duration = Unix.gettimeofday () -. before in assert_bool "Update returned" (!ok && duration < 0.1) -(* Test injecting a barrier. Adds two updates before injecting a barrier, - then adds two more events. Checks that the barrier is returned and contains - the expected 2 updates from before the barrier was injected. Also checks - that the updates returned from the 'get' contain all 3 updates in the - correct order *) +(* Test injecting a barrier. Adds two updates before injecting a barrier, then + adds two more events. Checks that the barrier is returned and contains the + expected 2 updates from before the barrier was injected. Also checks that the + updates returned from the 'get' contain all 3 updates in the correct order *) let test_inject_barrier () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; - M.inject_barrier 1 (fun _ _ -> true) u; - M.add update_a u; - M.add update_c u; - let (barriers,updates,_id) = M.get "dbg" None (Some 1) u in - assert_bool "Barrier returned" (List.length barriers = 1); - assert_bool "Barriers contains our barrier" (List.exists (fun x -> fst x = 1) barriers); + M.add update_a u ; + M.add update_b u ; + M.inject_barrier 1 (fun _ _ -> true) u ; + M.add update_a u ; + M.add update_c u ; + let barriers, updates, _id = M.get "dbg" None (Some 1) u in + assert_bool "Barrier returned" (List.length barriers = 1) ; + assert_bool "Barriers contains our barrier" + (List.exists (fun x -> fst x = 1) barriers) ; let our_barrier = List.hd barriers in let barrier_contains u = List.mem u (snd our_barrier) in assert_bool "Our barrier contains Foo 'a' and Foo 'b'" - (barrier_contains update_a && barrier_contains update_b); + (barrier_contains update_a && barrier_contains update_b) ; assert_bool "Updates contain all updates" - (List.nth updates 0 = update_b && - List.nth updates 1 = update_a && - List.nth updates 2 = update_c) + (List.nth updates 0 = update_b + && List.nth updates 1 = update_a + && List.nth updates 2 = update_c + ) -(* Test the removal of a barrier. Adds a barrier as above, then removes - it and makes sure it doesn't show up in a subsequent 'get' *) +(* Test the removal of a barrier. Adds a barrier as above, then removes it and + makes sure it doesn't show up in a subsequent 'get' *) let test_remove_barrier () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; - M.inject_barrier 1 (fun _ _ -> true) u; - M.add update_a u; - M.add update_c u; - M.remove_barrier 1 u; - let (barriers,updates,_id) = M.get "dbg" None (Some 1) u in - assert_bool "Barrier returned" (List.length barriers = 0); + M.add update_a u ; + M.add update_b u ; + M.inject_barrier 1 (fun _ _ -> true) u ; + M.add update_a u ; + M.add update_c u ; + M.remove_barrier 1 u ; + let barriers, updates, _id = M.get "dbg" None (Some 1) u in + assert_bool "Barrier returned" (List.length barriers = 0) ; assert_bool "Updates contain all updates" - (List.nth updates 0 = update_b && - List.nth updates 1 = update_a && - List.nth updates 2 = update_c) + (List.nth updates 0 = update_b + && List.nth updates 1 = update_a + && List.nth updates 2 = update_c + ) -(* This is a similar check to the above, but round-trips through an - Rpc.t to verify the hand-written t_of_rpc and rpc_of_t functions are - correct *) +(* This is a similar check to the above, but round-trips through an Rpc.t to + verify the hand-written t_of_rpc and rpc_of_t functions are correct *) let test_inject_barrier_rpc () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; - M.inject_barrier 1 (fun _ _ -> true) u; - M.add update_a u; - M.add update_c u; - let (barriers,updates,_id) = M.get "dbg" None (Some 1) u in - assert_bool "Barrier returned" (List.length barriers = 1); - assert_bool "Barriers contains our barrier" (List.exists (fun x -> fst x = 1) barriers); + M.add update_a u ; + M.add update_b u ; + M.inject_barrier 1 (fun _ _ -> true) u ; + M.add update_a u ; + M.add update_c u ; + let barriers, updates, _id = M.get "dbg" None (Some 1) u in + assert_bool "Barrier returned" (List.length barriers = 1) ; + assert_bool "Barriers contains our barrier" + (List.exists (fun x -> fst x = 1) barriers) ; let our_barrier = List.hd barriers in let barrier_contains u = List.mem u (snd our_barrier) in assert_bool "Our barrier contains Foo 'a' and Foo 'b'" - (barrier_contains update_a && barrier_contains update_b); + (barrier_contains update_a && barrier_contains update_b) ; assert_bool "Updates contain all updates" - (List.nth updates 0 = update_b && - List.nth updates 1 = update_a && - List.nth updates 2 = update_c) + (List.nth updates 0 = update_b + && List.nth updates 1 = update_a + && List.nth updates 2 = update_c + ) (* Check that the token returned by the first 'get' can be passed to a - subsequent 'get' invocation. This second one should return only events - that happend after the first 'get' *) + subsequent 'get' invocation. This second one should return only events that + happend after the first 'get' *) let test_multiple_gets () = let u = M.empty scheduler in - M.add update_a u; - let (_,updates1,id) = M.get "dbg" None (Some 1) u in - M.add update_b u; - let (_,updates2,_) = M.get "dbg" (Some id) (Some 1) u in + M.add update_a u ; + let _, updates1, id = M.get "dbg" None (Some 1) u in + M.add update_b u ; + let _, updates2, _ = M.get "dbg" (Some id) (Some 1) u in assert_bool "Updates contain correct updates" - (List.nth updates1 0 = update_a && - List.nth updates2 0 = update_b && - List.length updates1 = 1 && - List.length updates2 = 1) - -(* Test the filter function for filtering out events. Here we add events - 'a' and 'b', then filter out everything but 'a', and check that a - subsequent 'get' call returns only update 'a' *) + (List.nth updates1 0 = update_a + && List.nth updates2 0 = update_b + && List.length updates1 = 1 + && List.length updates2 = 1 + ) + +(* Test the filter function for filtering out events. Here we add events 'a' and + 'b', then filter out everything but 'a', and check that a subsequent 'get' + call returns only update 'a' *) let test_filter () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; - M.filter (function | Foo "a" -> true | _ -> false) u; - let (_,updates1,_id) = M.get "dbg" None (Some 1) u in + M.add update_a u ; + M.add update_b u ; + M.filter (function Foo "a" -> true | _ -> false) u ; + let _, updates1, _id = M.get "dbg" None (Some 1) u in assert_bool "Updates contain correct updates" - (List.nth updates1 0 = update_a && - List.length updates1 = 1) + (List.nth updates1 0 = update_a && List.length updates1 = 1) -(* Check that a dumped updates.t value has the correct Rpc representation. - Note that the dumped Rpc contains embedded strings containing json... *) +(* Check that a dumped updates.t value has the correct Rpc representation. Note + that the dumped Rpc contains embedded strings containing json... *) let test_dump () = let u = M.empty scheduler in - M.add update_a u; - M.inject_barrier 1 (fun _ _ -> true) u; + M.add update_a u ; + M.inject_barrier 1 (fun _ _ -> true) u ; let dump = M.Dump.make u in let dumped_rpc = M.Dump.rpc_of_dump dump in - let expected_rpc = Rpc.Dict - [("updates", - Rpc.Enum - [Rpc.Dict [("id", Rpc.Int 1L); ("v", Rpc.String "[\"Foo\",\"a\"]")]]); - ("barriers", - Rpc.Enum - [Rpc.Enum - [Rpc.Int 1L; Rpc.Int 2L; + let expected_rpc = + Rpc.Dict + [ + ( "updates" + , Rpc.Enum + [Rpc.Dict [("id", Rpc.Int 1L); ("v", Rpc.String "[\"Foo\",\"a\"]")]] + ) + ; ( "barriers" + , Rpc.Enum + [ Rpc.Enum - [Rpc.Dict - [ ("id", Rpc.Int 1L) - ; ("v", Rpc.String "[\"Foo\",\"a\"]") - ]]]] - )] + [ + Rpc.Int 1L + ; Rpc.Int 2L + ; Rpc.Enum + [ + Rpc.Dict + [ + ("id", Rpc.Int 1L); ("v", Rpc.String "[\"Foo\",\"a\"]") + ] + ] + ] + ] ) + ] in Alcotest.check rpc "same RPC value" dumped_rpc expected_rpc -(* Test that last_id returns a token that can be passed to 'get'. This get call should - then only return events that were added _after_ the call to 'last_id' *) +(* Test that last_id returns a token that can be passed to 'get'. This get call + should then only return events that were added _after_ the call to 'last_id' *) let test_last_id () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; + M.add update_a u ; + M.add update_b u ; let id = M.last_id "dbg" u in - M.add update_c u; - let (_,updates,_) = M.get "dbg" (Some id) (Some 1) u in + M.add update_c u ; + let _, updates, _ = M.get "dbg" (Some id) (Some 1) u in assert_bool "Only later events returned" - (List.length updates = 1 && List.exists (fun x -> x=update_c) updates) + (List.length updates = 1 && List.exists (fun x -> x = update_c) updates) let tests = [ - "Test no add", `Quick, test_noadd; - "Test add", `Quick, test_add; - "Test remove", `Quick, test_remove; - "Test timeout", `Slow, test_timeout; - "Test add after get", `Quick, test_add_after_get; - "Test inject barrier", `Quick, test_inject_barrier; - "Test remove barrier", `Quick, test_remove_barrier; - "Test inject barrier with rpc", `Quick, test_inject_barrier_rpc; - "Test multiple gets", `Quick, test_multiple_gets; - "Test filter", `Quick, test_filter; - "Test dump", `Quick, test_dump; - "Test last_id", `Quick, test_last_id; + ("Test no add", `Quick, test_noadd) + ; ("Test add", `Quick, test_add) + ; ("Test remove", `Quick, test_remove) + ; ("Test timeout", `Slow, test_timeout) + ; ("Test add after get", `Quick, test_add_after_get) + ; ("Test inject barrier", `Quick, test_inject_barrier) + ; ("Test remove barrier", `Quick, test_remove_barrier) + ; ("Test inject barrier with rpc", `Quick, test_inject_barrier_rpc) + ; ("Test multiple gets", `Quick, test_multiple_gets) + ; ("Test filter", `Quick, test_filter) + ; ("Test dump", `Quick, test_dump) + ; ("Test last_id", `Quick, test_last_id) ] diff --git a/lib_test/v6_interface_test.ml b/lib_test/v6_interface_test.ml index 96968e01..c546fa29 100644 --- a/lib_test/v6_interface_test.ml +++ b/lib_test/v6_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "v6_gen" end + module OldPath = struct let test_data_path = "test_data/v6" end -module C = V6_interface.RPC_API(GenTestData(GenPath)(TXmlrpc)) -module T = V6_interface.RPC_API(TestOldRpcs(OldPath)(TXmlrpc)) +module C = V6_interface.RPC_API (GenTestData (GenPath) (TXmlrpc)) +module T = V6_interface.RPC_API (TestOldRpcs (OldPath) (TXmlrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/varstore_interfaces_test.ml b/lib_test/varstore_interfaces_test.ml index 7956cc13..29c47e07 100644 --- a/lib_test/varstore_interfaces_test.ml +++ b/lib_test/varstore_interfaces_test.ml @@ -2,21 +2,30 @@ open Idl_test_common module Privileged = struct module GenPath = struct let test_data_path = "varstore_privileged_gen" end - module OldPath = struct let test_data_path = "test_data/varstore/privileged" end - module C = Varstore_privileged_interface.RPC_API(GenTestData(GenPath)(TXmlrpc)) - module T = Varstore_privileged_interface.RPC_API(TestOldRpcs(OldPath)(TXmlrpc)) + module OldPath = struct + let test_data_path = "test_data/varstore/privileged" + end - let tests = - !C.implementation @ !T.implementation + module C = + Varstore_privileged_interface.RPC_API (GenTestData (GenPath) (TXmlrpc)) + module T = + Varstore_privileged_interface.RPC_API (TestOldRpcs (OldPath) (TXmlrpc)) + + let tests = !C.implementation @ !T.implementation end + module Deprivileged = struct module GenPath = struct let test_data_path = "varstore_deprivileged_gen" end - module OldPath = struct let test_data_path = "test_data/varstore/deprivileged" end - module C = Varstore_deprivileged_interface.RPC_API(GenTestData(GenPath)(TXmlrpc)) - module T = Varstore_deprivileged_interface.RPC_API(TestOldRpcs(OldPath)(TXmlrpc)) + module OldPath = struct + let test_data_path = "test_data/varstore/deprivileged" + end + + module C = + Varstore_deprivileged_interface.RPC_API (GenTestData (GenPath) (TXmlrpc)) + module T = + Varstore_deprivileged_interface.RPC_API (TestOldRpcs (OldPath) (TXmlrpc)) - let tests = - !C.implementation @ !T.implementation + let tests = !C.implementation @ !T.implementation end diff --git a/lib_test/xen_test.ml b/lib_test/xen_test.ml index f4aeb420..ce02702b 100644 --- a/lib_test/xen_test.ml +++ b/lib_test/xen_test.ml @@ -1,23 +1,43 @@ - -(* This was created on a creedence host. I have deliberately removed the field *) -(* *) -(* "name": "foo" *) -(* *) +(* This was created on a creedence host. I have deliberately removed the field *) +(* *) +(* "name": "foo" *) +(* *) (* from just after the 'id' field. This is to test that the field gets defaulted *) -(* to the value specified in the idl. *) +(* to the value specified in the idl. *) -let old_vm_t = "{\"id\": \"bc6b8e8a-f0a5-4746-6489-2745756f21b2\", \"ssidref\": 0, \"xsdata\": {\"vm-data\": \"\"}, \"platformdata\": {\"generation-id\": \"\", \"timeoffset\": \"0\", \"usb\": \"true\", \"usb_tablet\": \"true\"}, \"bios_strings\": {\"bios-vendor\": \"Xen\", \"bios-version\": \"\", \"system-manufacturer\": \"Xen\", \"system-product-name\": \"HVM domU\", \"system-version\": \"\", \"system-serial-number\": \"\", \"hp-rombios\": \"\", \"oem-1\":\"Xen\", \"oem-2\": \"MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d\"}, \"ty\": [\"HVM\", {\"hap\": true, \"shadow_multiplier\": 1.000000, \"timeoffset\": \"0\", \"video_mib\": 4, \"video\": \"Cirrus\", \"acpi\": true, \"serial\": \"pty\", \"keymap\": \"en-us\", \"pci_emulations\": [], \"pci_passthrough\": false, \"boot_order\": \"cd\", \"qemu_disk_cmdline\": false, \"qemu_stubdom\": false}], \"suppress_spurious_page_faults\": false, \"memory_static_max\": 268435456, \"memory_dynamic_max\": 268435456, \"memory_dynamic_min\": 134217728, \"vcpu_max\": 1, \"vcpus\": 1, \"scheduler_params\": {\"priority\": [256, 0], \"affinity\": []}, \"on_crash\": [\"Shutdown\"], \"on_shutdown\": [\"Shutdown\"], \"on_reboot\": [\"Start\"], \"pci_msitranslate\": true, \"pci_power_mgmt\": false}" +let old_vm_t = + "{\"id\": \"bc6b8e8a-f0a5-4746-6489-2745756f21b2\", \"ssidref\": 0, \ + \"xsdata\": {\"vm-data\": \"\"}, \"platformdata\": {\"generation-id\": \ + \"\", \"timeoffset\": \"0\", \"usb\": \"true\", \"usb_tablet\": \"true\"}, \ + \"bios_strings\": {\"bios-vendor\": \"Xen\", \"bios-version\": \"\", \ + \"system-manufacturer\": \"Xen\", \"system-product-name\": \"HVM domU\", \ + \"system-version\": \"\", \"system-serial-number\": \"\", \"hp-rombios\": \ + \"\", \"oem-1\":\"Xen\", \"oem-2\": \ + \"MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d\"}, \"ty\": \ + [\"HVM\", {\"hap\": true, \"shadow_multiplier\": 1.000000, \"timeoffset\": \ + \"0\", \"video_mib\": 4, \"video\": \"Cirrus\", \"acpi\": true, \"serial\": \ + \"pty\", \"keymap\": \"en-us\", \"pci_emulations\": [], \ + \"pci_passthrough\": false, \"boot_order\": \"cd\", \"qemu_disk_cmdline\": \ + false, \"qemu_stubdom\": false}], \"suppress_spurious_page_faults\": false, \ + \"memory_static_max\": 268435456, \"memory_dynamic_max\": 268435456, \ + \"memory_dynamic_min\": 134217728, \"vcpu_max\": 1, \"vcpus\": 1, \ + \"scheduler_params\": {\"priority\": [256, 0], \"affinity\": []}, \ + \"on_crash\": [\"Shutdown\"], \"on_shutdown\": [\"Shutdown\"], \ + \"on_reboot\": [\"Start\"], \"pci_msitranslate\": true, \"pci_power_mgmt\": \ + false}" let test_upgrade_rules () = - let old_json = old_vm_t in - let rpc = Jsonrpc.of_string old_json in - let vm_t = match Rpcmarshal.unmarshal Xenops_interface.Vm.t.Rpc.Types.ty rpc with - | Ok vm -> vm - | Error (`Msg m) -> failwith (Printf.sprintf "Failed to unmarshal: %s" m) + let old_json = old_vm_t in + let rpc = Jsonrpc.of_string old_json in + let vm_t = + match Rpcmarshal.unmarshal Xenops_interface.Vm.t.Rpc.Types.ty rpc with + | Ok vm -> + vm + | Error (`Msg m) -> + failwith (Printf.sprintf "Failed to unmarshal: %s" m) in - Alcotest.(check string) "VM name" vm_t.Xenops_interface.Vm.name "unnamed" (* this value is the default in xenops_interface.ml *) + Alcotest.(check string) "VM name" vm_t.Xenops_interface.Vm.name "unnamed" + +(* this value is the default in xenops_interface.ml *) -let tests = - [ - "check upgrade rule", `Quick, test_upgrade_rules - ] +let tests = [("check upgrade rule", `Quick, test_upgrade_rules)] diff --git a/memory/dune b/memory/dune index cc67c2f9..cf1e39ae 100644 --- a/memory/dune +++ b/memory/dune @@ -1,41 +1,27 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - (library - (name xcp_memory) - (public_name xapi-idl.memory) - (flags (:standard -w -39)) - (modules (:standard \ memory_cli)) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) -) + (name xcp_memory) + (public_name xapi-idl.memory) + (flags (:standard -w -39)) + (modules (:standard \ memory_cli)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name memory_cli) - (modules memory_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.memory - ) -) - -(alias - (name runtest) - (deps (:x memory_cli.exe)) - (action (run %%{x})) -) + (name memory_cli) + (modules memory_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.memory + )) -|} coverage_rewriter +(rule + (alias runtest) + (deps (:x memory_cli.exe)) + (action (run %{x}))) diff --git a/memory/memory.ml b/memory/memory.ml index 38fec636..fedb7591 100644 --- a/memory/memory.ml +++ b/memory/memory.ml @@ -14,190 +14,228 @@ (** Functions relating to memory requirements of Xen domains *) let ( +++ ) = Int64.add + let ( --- ) = Int64.sub + let ( *** ) = Int64.mul + let ( /// ) = Int64.div (* === Memory conversion factors ============================================ *) -let bytes_per_kib = 1024L -let bytes_per_mib = 1048576L +let bytes_per_kib = 1024L + +let bytes_per_mib = 1048576L + let bytes_per_page = 4096L -let kib_per_page = bytes_per_page /// bytes_per_kib -let kib_per_mib = 1024L -let pages_per_mib = bytes_per_mib /// bytes_per_page + +let kib_per_page = bytes_per_page /// bytes_per_kib + +let kib_per_mib = 1024L + +let pages_per_mib = bytes_per_mib /// bytes_per_page (* === Arithmetic functions ================================================= *) (** Returns true if (and only if) the specified argument is a power of 2. *) -let is_power_of_2 n = - (n > 0) && (n land (0 - n) = n) +let is_power_of_2 n = n > 0 && n land (0 - n) = n -let round_down_to_multiple_of x y = - (x /// y) *** y +let round_down_to_multiple_of x y = (x /// y) *** y -let round_up_to_multiple_of x y = - ((x +++ y --- 1L) /// y) *** y +let round_up_to_multiple_of x y = ((x +++ y --- 1L) /// y) *** y (* === Memory rounding functions ============================================ *) let round_up = round_up_to_multiple_of + let round_down = round_down_to_multiple_of let round_bytes_down_to_nearest_page_boundary v = round_down v bytes_per_page -let round_bytes_down_to_nearest_mib v = round_down v bytes_per_mib -let round_kib_down_to_nearest_page_boundary v = round_down v kib_per_page -let round_kib_up_to_nearest_page_boundary v = round_up v kib_per_page -let round_kib_up_to_nearest_mib v = round_up v kib_per_mib -let round_pages_up_to_nearest_mib v = round_up v pages_per_mib + +let round_bytes_down_to_nearest_mib v = round_down v bytes_per_mib + +let round_kib_down_to_nearest_page_boundary v = round_down v kib_per_page + +let round_kib_up_to_nearest_page_boundary v = round_up v kib_per_page + +let round_kib_up_to_nearest_mib v = round_up v kib_per_mib + +let round_pages_up_to_nearest_mib v = round_up v pages_per_mib (* === Division functions =================================================== *) -let divide_rounding_down numerator denominator = - numerator /// denominator +let divide_rounding_down numerator denominator = numerator /// denominator let divide_rounding_up numerator denominator = (numerator +++ denominator --- 1L) /// denominator (* === Memory unit conversion functions ===================================== *) -let bytes_of_kib value = value *** bytes_per_kib +let bytes_of_kib value = value *** bytes_per_kib + let bytes_of_pages value = value *** bytes_per_page -let bytes_of_mib value = value *** bytes_per_mib -let kib_of_mib value = value *** kib_per_mib -let kib_of_pages value = value *** kib_per_page -let pages_of_mib value = value *** pages_per_mib -let kib_of_bytes_free value = divide_rounding_down value bytes_per_kib +let bytes_of_mib value = value *** bytes_per_mib + +let kib_of_mib value = value *** kib_per_mib + +let kib_of_pages value = value *** kib_per_page + +let pages_of_mib value = value *** pages_per_mib + +let kib_of_bytes_free value = divide_rounding_down value bytes_per_kib + let pages_of_bytes_free value = divide_rounding_down value bytes_per_page -let pages_of_kib_free value = divide_rounding_down value kib_per_page -let mib_of_bytes_free value = divide_rounding_down value bytes_per_mib -let mib_of_kib_free value = divide_rounding_down value kib_per_mib -let mib_of_pages_free value = divide_rounding_down value pages_per_mib -let kib_of_bytes_used value = divide_rounding_up value bytes_per_kib +let pages_of_kib_free value = divide_rounding_down value kib_per_page + +let mib_of_bytes_free value = divide_rounding_down value bytes_per_mib + +let mib_of_kib_free value = divide_rounding_down value kib_per_mib + +let mib_of_pages_free value = divide_rounding_down value pages_per_mib + +let kib_of_bytes_used value = divide_rounding_up value bytes_per_kib + let pages_of_bytes_used value = divide_rounding_up value bytes_per_page -let pages_of_kib_used value = divide_rounding_up value kib_per_page -let mib_of_bytes_used value = divide_rounding_up value bytes_per_mib -let mib_of_kib_used value = divide_rounding_up value kib_per_mib -let mib_of_pages_used value = divide_rounding_up value pages_per_mib - -(* === Domain memory breakdown ======================================================= *) - -(* ╤ ╔══════════╗ ╤ *) -(* │ ║ shadow ║ │ *) -(* │ ╠══════════╣ │ *) -(* overhead │ ║ extra ║ │ *) -(* │ ║ external ║ │ *) -(* │ ╠══════════╣ ╤ │ *) -(* │ ║ extra ║ │ │ *) -(* │ ║ internal ║ │ │ *) -(* │ ╠══════════╣ ╤ ╤ ╤ │ │ footprint *) -(* │ ║ shim ║ │ │ │ │ │ *) -(* ╪ ╠══════════╣ ╧ ╧ ╤ │ │ xen │ *) -(* │ ║ video ║ │ │ actual │ maximum │ *) -(* │ ╠══════════╣ ╤ ╤ │ │ / │ │ *) -(* │ ║ ║ │ │ build │ target │ total │ │ *) -(* │ ║ guest ║ │ │ start │ │ │ │ *) -(* static │ ║ ║ │ │ │ │ │ │ *) -(* maximum │ ╟──────────╢ │ ╧ ╧ ╧ ╧ ╧ *) -(* │ ║ ║ │ *) -(* │ ║ ║ │ *) -(* │ ║ balloon ║ │ build *) -(* │ ║ ║ │ maximum *) -(* │ ║ ║ │ *) -(* ╧ ╚══════════╝ ╧ *) - -(* === Domain memory breakdown: HVM guests =========================================== *) + +let pages_of_kib_used value = divide_rounding_up value kib_per_page + +let mib_of_bytes_used value = divide_rounding_up value bytes_per_mib + +let mib_of_kib_used value = divide_rounding_up value kib_per_mib + +let mib_of_pages_used value = + divide_rounding_up value pages_per_mib + (* === Domain memory breakdown + ======================================================= *) + + (* + ╤ ╔══════════╗ ╤ + │ ║ shadow ║ │ + │ ╠══════════╣ │ + overhead │ ║ extra ║ │ + │ ║ external ║ │ + │ ╠══════════╣ ╤ │ + │ ║ extra ║ │ │ + │ ║ internal ║ │ │ + │ ╠══════════╣ ╤ ╤ ╤ │ │ footprint + │ ║ shim ║ │ │ │ │ │ + ╪ ╠══════════╣ ╧ ╧ ╤ │ │ xen │ + │ ║ video ║ │ │ actual │ maximum │ + │ ╠══════════╣ ╤ ╤ │ │ / │ │ + │ ║ ║ │ │ build │ target │ total │ │ + │ ║ guest ║ │ │ start │ │ │ │ + static │ ║ ║ │ │ │ │ │ │ + maximum │ ╟──────────╢ │ ╧ ╧ ╧ ╧ ╧ + │ ║ ║ │ + │ ║ ║ │ + │ ║ balloon ║ │ build + │ ║ ║ │ maximum + │ ║ ║ │ + ╧ ╚══════════╝ ╧ + *) + [@@ocamlformat "wrap-comments=false"] + +(* === Domain memory breakdown: HVM guests + =========================================== *) module type MEMORY_MODEL_DATA = sig val extra_internal_mib : int64 + val extra_external_mib : int64 + val shim_mib : int64 -> int64 + val can_start_ballooned_down : bool end module HVM_memory_model_data : MEMORY_MODEL_DATA = struct let extra_internal_mib = 1L + let extra_external_mib = 1L + let shim_mib _ = 0L + let can_start_ballooned_down = true end module Linux_memory_model_data : MEMORY_MODEL_DATA = struct let extra_internal_mib = 0L + let extra_external_mib = 1L + let shim_mib _ = 0L + let can_start_ballooned_down = true end module PVinPVH_memory_model_data : MEMORY_MODEL_DATA = struct let extra_internal_mib = 1L + let extra_external_mib = 1L + let shim_mib static_max_mib = 23L +++ (static_max_mib /// 90L) + let can_start_ballooned_down = true end type memory_config = { - build_max_mib : int64; - build_start_mib : int64; - xen_max_mib : int64; - shadow_mib : int64; - required_host_free_mib : int64; - overhead_mib : int64; + build_max_mib: int64 + ; build_start_mib: int64 + ; xen_max_mib: int64 + ; shadow_mib: int64 + ; required_host_free_mib: int64 + ; overhead_mib: int64 } module Memory_model (D : MEMORY_MODEL_DATA) = struct - let build_max_mib static_max_mib video_mib = - static_max_mib --- - (Int64.of_int video_mib) +++ - (D.shim_mib static_max_mib) + static_max_mib --- Int64.of_int video_mib +++ D.shim_mib static_max_mib let build_start_mib static_max_mib target_mib video_mib = if D.can_start_ballooned_down then - target_mib --- - (Int64.of_int video_mib) +++ - (D.shim_mib target_mib) + target_mib --- Int64.of_int video_mib +++ D.shim_mib target_mib else build_max_mib static_max_mib video_mib let xen_max_offset_mib = D.extra_internal_mib let xen_max_mib static_max_mib = - static_max_mib +++ - xen_max_offset_mib +++ - (D.shim_mib static_max_mib) + static_max_mib +++ xen_max_offset_mib +++ D.shim_mib static_max_mib let shadow_mib static_max_mib vcpu_count multiplier = - let vcpu_pages = 256L *** (Int64.of_int vcpu_count) in + let vcpu_pages = 256L *** Int64.of_int vcpu_count in let p2m_map_pages = static_max_mib in let shadow_resident_pages = static_max_mib in - let total_mib = mib_of_pages_used - (vcpu_pages +++ p2m_map_pages +++ shadow_resident_pages) in + let total_mib = + mib_of_pages_used (vcpu_pages +++ p2m_map_pages +++ shadow_resident_pages) + in let total_mib_multiplied = - Int64.of_float ((Int64.to_float total_mib) *. multiplier) in + Int64.of_float (Int64.to_float total_mib *. multiplier) + in max 1L total_mib_multiplied let overhead_mib static_max_mib vcpu_count multiplier = - D.extra_internal_mib +++ - D.extra_external_mib +++ - (shadow_mib static_max_mib vcpu_count multiplier) +++ - (D.shim_mib static_max_mib) + D.extra_internal_mib + +++ D.extra_external_mib + +++ shadow_mib static_max_mib vcpu_count multiplier + +++ D.shim_mib static_max_mib let footprint_mib target_mib static_max_mib vcpu_count multiplier = - target_mib +++ (overhead_mib static_max_mib vcpu_count multiplier) + target_mib +++ overhead_mib static_max_mib vcpu_count multiplier let shadow_multiplier_default = 1.0 let full_config static_max_mib video_mib target_mib vcpus shadow_multiplier = { - build_max_mib = build_max_mib static_max_mib video_mib; - build_start_mib = build_start_mib static_max_mib target_mib video_mib; - xen_max_mib = xen_max_mib static_max_mib; - shadow_mib = shadow_mib static_max_mib vcpus shadow_multiplier; - required_host_free_mib = footprint_mib target_mib static_max_mib vcpus shadow_multiplier; - overhead_mib = overhead_mib static_max_mib vcpus shadow_multiplier; + build_max_mib= build_max_mib static_max_mib video_mib + ; build_start_mib= build_start_mib static_max_mib target_mib video_mib + ; xen_max_mib= xen_max_mib static_max_mib + ; shadow_mib= shadow_mib static_max_mib vcpus shadow_multiplier + ; required_host_free_mib= + footprint_mib target_mib static_max_mib vcpus shadow_multiplier + ; overhead_mib= overhead_mib static_max_mib vcpus shadow_multiplier } end diff --git a/memory/memory_cli.ml b/memory/memory_cli.ml index 2d19dfc1..29f20dd4 100644 --- a/memory/memory_cli.ml +++ b/memory/memory_cli.ml @@ -2,24 +2,34 @@ open Memory_interface -module Cmds = API(Cmdlinergen.Gen ()) +module Cmds = API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the memory API. This allows scripting of the squeeze daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "memory_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the memory API. This allows scripting of the squeeze daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "memory_cli" ~version:(version_str Cmds.description) ~doc + ) let cli () = let rpc = Memory_client.rpc in - match Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) with - | `Ok f -> f () - | _ -> () + match + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) + with + | `Ok f -> + f () + | _ -> + () let _ = cli () diff --git a/memory/memory_client.ml b/memory/memory_client.ml index c19df5c5..c627ffa3 100644 --- a/memory/memory_client.ml +++ b/memory/memory_client.ml @@ -16,12 +16,15 @@ open Memory_interface open Xcp_client let json_url () = "file:" ^ json_path + let xml_url () = "file:" ^ xml_path let rpc call = - if !use_switch - then json_switch_rpc queue_name call - else xml_http_rpc ~srcstr:"xenops" ~dststr:"squeezed" xml_url call - -module Client = Memory_interface.API(Idl.Exn.GenClient(struct let rpc=rpc end)) + if !use_switch then + json_switch_rpc queue_name call + else + xml_http_rpc ~srcstr:"xenops" ~dststr:"squeezed" xml_url call +module Client = Memory_interface.API (Idl.Exn.GenClient (struct + let rpc = rpc +end)) diff --git a/memory/memory_interface.ml b/memory/memory_interface.ml index e96908f8..a74ec46b 100644 --- a/memory/memory_interface.ml +++ b/memory/memory_interface.ml @@ -11,228 +11,295 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** - * @group Memory -*) + +(** @group Memory *) + open Rpc open Idl -module D = Debug.Make(struct let name = "memory_interface" end) +module D = Debug.Make (struct let name = "memory_interface" end) + open D let service_name = "memory" + let queue_name = Xcp_service.common_prefix ^ service_name + let json_path = "/var/xapi/memory.json" + let xml_path = "/var/xapi/memory" (** The reservation_id is an opaque identifier associated with a block of - memory. It is used to reserve memory for a domain before the domain has - been created. *) -type reservation_id = string -[@@deriving rpcty] + memory. It is used to reserve memory for a domain before the domain has been + created. *) +type reservation_id = string [@@deriving rpcty] (** Domain zero can have a different policy to that used by guest domains. *) type domain_zero_policy = - | Fixed_size of int64 (** Never balloon, use the specified fixed size *) - | Auto_balloon of int64 * int64 (** Balloon between the two sizes specified *) + | Fixed_size of int64 (** Never balloon, use the specified fixed size *) + | Auto_balloon of int64 * int64 + (** Balloon between the two sizes specified *) [@@deriving rpcty] type errors = | Cannot_free_this_much_memory of (int64 * int64) - (** [Cannot_free_this_much_memory (required, free)] is reported if it is not - possible to free [required] kib. [free] is the amount of memory - currently free. *) - | Domains_refused_to_cooperate of (int list) - (** [Domains_refused_to_cooperate (domid list)] is reported if a set of - domains do not respond in a timely manner to the request to balloon. - The uncooperative domain ids are returned. *) - | Unknown_reservation of (reservation_id) - (** [Unknown_reservation (id)] is reported if a the specified - reservation_id is unknown. *) + (** [Cannot_free_this_much_memory (required, free)] is reported if it is + not possible to free [required] kib. [free] is the amount of memory + currently free. *) + | Domains_refused_to_cooperate of int list + (** [Domains_refused_to_cooperate (domid list)] is reported if a set of + domains do not respond in a timely manner to the request to balloon. + The uncooperative domain ids are returned. *) + | Unknown_reservation of reservation_id + (** [Unknown_reservation (id)] is reported if a the specified + reservation_id is unknown. *) | No_reservation - (** [No_reservation] is reported by [query_reservation_of_domain] if the - domain does not have a reservation. *) - | Invalid_memory_value of (int64) - (** [Invalid_memory_value (value)] is reported if a memory value passed is - not valid, e.g. negative. *) - | Internal_error of (string) - (** [Internal_error (value)] is reported if an unexpected error is - triggered by the library. *) - | Unknown_error - (** The default variant for forward compatibility. *) -[@@default Unknown_error] -[@@deriving rpcty] + (** [No_reservation] is reported by [query_reservation_of_domain] if the + domain does not have a reservation. *) + | Invalid_memory_value of int64 + (** [Invalid_memory_value (value)] is reported if a memory value passed is + not valid, e.g. negative. *) + | Internal_error of string + (** [Internal_error (value)] is reported if an unexpected error is + triggered by the library. *) + | Unknown_error (** The default variant for forward compatibility. *) +[@@default Unknown_error] [@@deriving rpcty] exception MemoryError of errors -let () = (* register printer for MemoryError *) +let () = + (* register printer for MemoryError *) let sprintf = Printf.sprintf in let string_of_error e = - Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | MemoryError e -> Some (sprintf "Memory_interface.Memory_error(%s)" (string_of_error e)) - | _ -> None in + | _ -> + None + in Printexc.register_printer printer -let err = Error. - { def = errors - ; raiser = (fun e -> - log_backtrace (); - let exn = MemoryError e in - error "%s (%s)" (Printexc.to_string exn) __LOC__; - raise exn) - ; matcher = (function - | MemoryError e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; +let err = + Error. + { + def= errors + ; raiser= + (fun e -> + log_backtrace () ; + let exn = MemoryError e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) + ; matcher= + (function + | MemoryError e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some (Internal_error (Printexc.to_string exn))) } (** An uninterpreted string associated with the operation. *) -type debug_info = string -[@@deriving rpcty] +type debug_info = string [@@deriving rpcty] -(** An identifier to associate requests with a client. This is - obtained by a call to [login]. *) -type session_id = string -[@@deriving rpcty] +(** An identifier to associate requests with a client. This is obtained by a + call to [login]. *) +type session_id = string [@@deriving rpcty] -type reserve_memory_range_result = reservation_id * int64 -[@@deriving rpcty] +type reserve_memory_range_result = reservation_id * int64 [@@deriving rpcty] -module API(R : RPC) = struct +module API (R : RPC) = struct open R - let description = Interface.{ - name = "Memory"; - namespace = None; - description = [ - "This interface is used by Xapi and Squeezed to manage the "; - "dynamic memory usage of VMs on a host."; - ]; - version=(1,0,0); - } + let description = + Interface. + { + name= "Memory" + ; namespace= None + ; description= + [ + "This interface is used by Xapi and Squeezed to manage the " + ; "dynamic memory usage of VMs on a host." + ] + ; version= (1, 0, 0) + } let implementation = implement description (* General parameters, used by more than one API call *) - let debug_info_p = Param.mk ~description:[ - "An uninterpreted string to associate with the operation." - ] Types.string + let debug_info_p = + Param.mk + ~description:["An uninterpreted string to associate with the operation."] + Types.string - let diagnostics_result_p = Param.mk ~description:[ - "A string containing diagnostic information from the server." - ] Types.string + let diagnostics_result_p = + Param.mk + ~description: + ["A string containing diagnostic information from the server."] + Types.string - let service_name_p = Param.mk ~description:[ - "The name of the service attempting to interact with the squeeze daemon." - ] Types.string + let service_name_p = + Param.mk + ~description: + [ + "The name of the service attempting to interact with the squeeze \ + daemon." + ] + Types.string - let session_id_p = Param.mk ~description:[ - "An identifier to associate requests with a client. This is "; - "obtained by a call to [login]."] + let session_id_p = + Param.mk + ~description: + [ + "An identifier to associate requests with a client. This is " + ; "obtained by a call to [login]." + ] Types.string - let domid_p = Param.mk ~description:[ - "Domain id of a VM." - ] Types.int + let domid_p = Param.mk ~description:["Domain id of a VM."] Types.int - let reservation_id_p = Param.mk ~description:[ - "The reservation_id is the token used to identify a memory allocation." - ] reservation_id + let reservation_id_p = + Param.mk + ~description: + [ + "The reservation_id is the token used to identify a memory allocation." + ] + reservation_id - let size_p = Param.mk ~description:[ - "The size in bytes to reserve"] - Types.int64 + let size_p = + Param.mk ~description:["The size in bytes to reserve"] Types.int64 let unit_p = Param.mk Types.unit (* Individual API calls *) - let get_diagnostics = declare - "get_diagnostics" + let get_diagnostics = + declare "get_diagnostics" ["Gets diagnostic information from the server"] (debug_info_p @-> returning diagnostics_result_p err) - let login = declare - "login" - ["Logs into the squeeze daemon. Any reservations previously made with the "; - "specified service name not yet associated with a domain will be removed."] + let login = + declare "login" + [ + "Logs into the squeeze daemon. Any reservations previously made with \ + the " + ; "specified service name not yet associated with a domain will be \ + removed." + ] (debug_info_p @-> service_name_p @-> returning session_id_p err) - - let reserve_memory = declare - "reserve_memory" - ["[reserve_memory dbg session size] reserves memory for a domain. If necessary, "; - "other domains will be ballooned down to ensure [size] is available. The call "; - "returns a reservation_id that can later be transferred to a domain."] - (debug_info_p @-> session_id_p @-> size_p @-> returning reservation_id_p err) + let reserve_memory = + declare "reserve_memory" + [ + "[reserve_memory dbg session size] reserves memory for a domain. If \ + necessary, " + ; "other domains will be ballooned down to ensure [size] is available. \ + The call " + ; "returns a reservation_id that can later be transferred to a domain." + ] + (debug_info_p + @-> session_id_p + @-> size_p + @-> returning reservation_id_p err + ) let reserve_memory_range = - let result = Param.mk - ~description:[ - "A tuple containing the reservation_id and the amount of memory actually reserved." - ] + let result = + Param.mk + ~description: + [ + "A tuple containing the reservation_id and the amount of memory \ + actually reserved." + ] reserve_memory_range_result in - declare - "reserve_memory_range" - ["[reserve_memory_range dbg session min max] reserves memory for a domain. If necessary, "; - "other domains will be ballooned down to ensure enough memory is available. The amount "; - "of memory will be between [min] and [max] according to the policy in operation. The call "; - "returns a reservation_id and the actual memory amount that can later be transferred to a domain."] - (debug_info_p @-> session_id_p @-> size_p @-> size_p @-> returning result err) - + declare "reserve_memory_range" + [ + "[reserve_memory_range dbg session min max] reserves memory for a \ + domain. If necessary, " + ; "other domains will be ballooned down to ensure enough memory is \ + available. The amount " + ; "of memory will be between [min] and [max] according to the policy in \ + operation. The call " + ; "returns a reservation_id and the actual memory amount that can later \ + be transferred to a domain." + ] + (debug_info_p + @-> session_id_p + @-> size_p + @-> size_p + @-> returning result err + ) let delete_reservation = - declare - "delete_reservation" - ["Deletes a reservation. Note that memory rebalancing is not done synchronously after the "; - "operation has completed."] - (debug_info_p @-> session_id_p @-> reservation_id_p @-> returning unit_p err) + declare "delete_reservation" + [ + "Deletes a reservation. Note that memory rebalancing is not done \ + synchronously after the " + ; "operation has completed." + ] + (debug_info_p + @-> session_id_p + @-> reservation_id_p + @-> returning unit_p err + ) let transfer_reservation_to_domain = - declare - "transfer_reservation_to_domain" - ["Transfers a reservation to a domain. This is called when the domain has been created for "; - "the VM for which the reservation was initially made."] - (debug_info_p @-> session_id_p @-> reservation_id_p @-> domid_p @-> returning unit_p err) + declare "transfer_reservation_to_domain" + [ + "Transfers a reservation to a domain. This is called when the domain \ + has been created for " + ; "the VM for which the reservation was initially made." + ] + (debug_info_p + @-> session_id_p + @-> reservation_id_p + @-> domid_p + @-> returning unit_p err + ) let query_reservation_of_domain = - declare - "query_reservation_of_domain" + declare "query_reservation_of_domain" ["Queries the reservation_id associated with a domain"] - (debug_info_p @-> session_id_p @-> domid_p @-> returning reservation_id_p err) + (debug_info_p + @-> session_id_p + @-> domid_p + @-> returning reservation_id_p err + ) let balance_memory = - declare - "balance_memory" - ["Forces a rebalance of the hosts memory. Blocks until the system is in a stable "; - "state."] + declare "balance_memory" + [ + "Forces a rebalance of the hosts memory. Blocks until the system is in \ + a stable " + ; "state." + ] (debug_info_p @-> returning unit_p err) let get_host_reserved_memory = - declare - "get_host_reserved_memory" - ["Gets the amount of reserved memory in a host. This is the lower limit of memory that "; - "squeezed will ensure remains unused by any domain or reservation."] + declare "get_host_reserved_memory" + [ + "Gets the amount of reserved memory in a host. This is the lower limit \ + of memory that " + ; "squeezed will ensure remains unused by any domain or reservation." + ] (debug_info_p @-> returning size_p err) let get_host_initial_free_memory = - declare - "get_host_initial_free_memory" + declare "get_host_initial_free_memory" ["Gets the amount of initial free memory in a host"] (debug_info_p @-> returning size_p err) let get_domain_zero_policy = - let result_p = Param.mk ~description:["The policy associated with domain 0"] domain_zero_policy in - declare - "get_domain_zero_policy" + let result_p = + Param.mk + ~description:["The policy associated with domain 0"] + domain_zero_policy + in + declare "get_domain_zero_policy" ["Gets the ballooning policy for domain zero."] (debug_info_p @-> returning result_p err) - end diff --git a/misc/channel_helper.ml b/misc/channel_helper.ml index e1c2e05c..53711b2c 100644 --- a/misc/channel_helper.ml +++ b/misc/channel_helper.ml @@ -5,46 +5,47 @@ open Lwt let my_domid = 0 (* TODO: figure this out *) exception Short_write of int * int + exception End_of_file + exception No_useful_protocol let copy_all src dst = let buffer = Bytes.make 16384 '\000' in let rec loop () = Lwt_unix.read src buffer 0 (Bytes.length buffer) >>= fun n -> - if n = 0 - then Lwt.fail End_of_file + if n = 0 then + Lwt.fail End_of_file else Lwt_unix.write dst buffer 0 n >>= fun m -> - if n <> m then Lwt.fail (Short_write(m, n)) - else loop () - in loop () + if n <> m then Lwt.fail (Short_write (m, n)) else loop () + in + loop () let proxy a b = let copy _id src dst = - Lwt.catch (fun () -> copy_all src dst) - (fun _e -> - (try Lwt_unix.shutdown src Lwt_unix.SHUTDOWN_RECEIVE with _ -> ()); - (try Lwt_unix.shutdown dst Lwt_unix.SHUTDOWN_SEND with _ -> ()); - return ()) in - let ts = [ copy "ab" a b; copy "ba" b a ] in + Lwt.catch + (fun () -> copy_all src dst) + (fun _e -> + (try Lwt_unix.shutdown src Lwt_unix.SHUTDOWN_RECEIVE with _ -> ()) ; + (try Lwt_unix.shutdown dst Lwt_unix.SHUTDOWN_SEND with _ -> ()) ; + return ()) + in + let ts = [copy "ab" a b; copy "ba" b a] in Lwt.join ts -let file_descr_of_int (x: int) : Unix.file_descr = - Obj.magic x (* Keep this in sync with ocaml's file_descr type *) +let file_descr_of_int (x : int) : Unix.file_descr = Obj.magic x + +(* Keep this in sync with ocaml's file_descr type *) let ip = ref "127.0.0.1" + let unix = ref "/tmp" module Common = struct - type t = { - verbose: bool; - debug: bool; - port: int; - } [@@deriving rpc] + type t = {verbose: bool; debug: bool; port: int} [@@deriving rpc] - let make verbose debug port = - { verbose; debug; port } + let make verbose debug port = {verbose; debug; port} let to_string x = Jsonrpc.to_string (rpc_of_t x) end @@ -58,127 +59,161 @@ let common_options_t = let docs = _common_options in let debug = let doc = "Give only debug output." in - Arg.(value & flag & info ["debug"] ~docs ~doc) in + Arg.(value & flag & info ["debug"] ~docs ~doc) + in let verb = let doc = "Give verbose output." in - let verbose = true, Arg.info ["v"; "verbose"] ~docs ~doc in - Arg.(last & vflag_all [false] [verbose]) in + let verbose = (true, Arg.info ["v"; "verbose"] ~docs ~doc) in + Arg.(last & vflag_all [false] [verbose]) + in let port = let doc = Printf.sprintf "Specify port to connect to the message switch." in - Arg.(value & opt int 8080 & info ["port"] ~docs ~doc) in + Arg.(value & opt int 8080 & info ["port"] ~docs ~doc) + in Term.(pure Common.make $ debug $ verb $ port) (* Help sections common to all commands *) -let help = [ - `S _common_options; - `P "These options are common to all commands."; - `S "MORE HELP"; - `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."; `Noblank; - `S "BUGS"; `P (Printf.sprintf "Check bug reports at %s" project_url); -] +let help = + [ + `S _common_options + ; `P "These options are common to all commands." + ; `S "MORE HELP" + ; `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command." + ; `Noblank + ; `S "BUGS" + ; `P (Printf.sprintf "Check bug reports at %s" project_url) + ] (* Commands *) let advertise_t _common_options_t proxy_socket = - let s_ip = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in (* INET socket, can't block *) - Lwt_unix.bind s_ip (Lwt_unix.ADDR_INET(Unix.inet_addr_of_string !ip, 0)) >>= fun () -> - Lwt_unix.listen s_ip 5; - let port = match Lwt_unix.getsockname s_ip with - | Unix.ADDR_INET(_, port) -> port - | _ -> assert false in - + Lwt_unix.bind s_ip (Lwt_unix.ADDR_INET (Unix.inet_addr_of_string !ip, 0)) + >>= fun () -> + Lwt_unix.listen s_ip 5 ; + let port = + match Lwt_unix.getsockname s_ip with + | Unix.ADDR_INET (_, port) -> + port + | _ -> + assert false + in let s_unix = Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in - (* Try to avoid polluting the filesystem with unused unix domain sockets *) - let path = Printf.sprintf "%s/%s.%d" !unix - (Filename.basename Sys.argv.(0)) (Unix.getpid ()) in - if Sys.file_exists path then Unix.unlink path; + let path = + Printf.sprintf "%s/%s.%d" !unix + (Filename.basename Sys.argv.(0)) + (Unix.getpid ()) + in + if Sys.file_exists path then Unix.unlink path ; Lwt_unix.bind s_unix (Lwt_unix.ADDR_UNIX path) >>= fun () -> - List.iter (fun signal -> - ignore(Lwt_unix.on_signal signal (fun _ -> Unix.unlink path; exit 1)) - ) [ Sys.sigterm; Sys.sigint ]; - - Lwt_unix.listen s_unix 5; - + List.iter + (fun signal -> + ignore (Lwt_unix.on_signal signal (fun _ -> Unix.unlink path ; exit 1))) + [Sys.sigterm; Sys.sigint] ; + Lwt_unix.listen s_unix 5 ; let token = "token" in let protocols = let open Xcp_channel_protocol in - [ - TCP_proxy(!ip, port); - Unix_sendmsg(my_domid, path, token); - ] in - Printf.fprintf stdout "%s\n%!" (Jsonrpc.to_string (Xcp_channel.rpc_of_protocols protocols)); - + [TCP_proxy (!ip, port); Unix_sendmsg (my_domid, path, token)] + in + Printf.fprintf stdout "%s\n%!" + (Jsonrpc.to_string (Xcp_channel.rpc_of_protocols protocols)) ; let t_ip = Lwt_unix.accept s_ip >>= fun (fd, _peer) -> Lwt_unix.close s_ip >>= fun () -> - proxy fd (Lwt_unix.of_unix_file_descr proxy_socket) in + proxy fd (Lwt_unix.of_unix_file_descr proxy_socket) + in let t_unix = Lwt_unix.accept s_unix >>= fun (fd, _peer) -> let buffer = Bytes.make (String.length token) '\000' in - let io_vector = Lwt_unix.io_vector ~buffer:(Bytes.unsafe_to_string buffer) ~offset:0 ~length:(Bytes.length buffer) in - Lwt_unix.recv_msg ~socket:fd ~io_vectors:[io_vector] >>= fun (n, fds) -> - List.iter Unix.close fds; - let token' = Bytes.sub_string buffer 0 n in - let io_vector' = Lwt_unix.io_vector ~buffer:token' ~offset:0 ~length:(String.length token') in - if token = token' - then - Lwt_unix.send_msg ~socket:fd ~io_vectors:[io_vector'] ~fds:[proxy_socket] >>= fun _ -> return () - else return () in - Lwt.pick [ t_ip; t_unix ] >>= fun () -> - Unix.unlink path; - return () - -let advertise common_options_t fd = match fd with + let io_vector = Lwt_unix.IO_vectors.create () in + Lwt_unix.IO_vectors.append_bytes io_vector buffer 0 (Bytes.length buffer) ; + Lwt_unix.recv_msg ~socket:fd ~io_vectors:io_vector >>= fun (n, fds) -> + List.iter Unix.close fds ; + let token' = Bytes.sub buffer 0 n in + let io_vector' = Lwt_unix.IO_vectors.create () in + Lwt_unix.IO_vectors.append_bytes io_vector' token' 0 (Bytes.length token') ; + if token = Bytes.to_string token' then + Lwt_unix.send_msg ~socket:fd ~io_vectors:io_vector' ~fds:[proxy_socket] + >>= fun _ -> return () + else + return () + in + Lwt.pick [t_ip; t_unix] >>= fun () -> Unix.unlink path ; return () + +let advertise common_options_t fd = + match fd with | Some x -> - Lwt_main.run (advertise_t common_options_t (file_descr_of_int x)); - `Ok () + Lwt_main.run (advertise_t common_options_t (file_descr_of_int x)) ; + `Ok () | None -> - `Error(true, "you must provide a file descriptor to proxy") + `Error (true, "you must provide a file descriptor to proxy") let advertise_cmd = let doc = "advertise a given channel represented as a file-descriptor" in - let man = [ - `S "DESCRIPTION"; - `P "Advertises a given channel over as many protocols as possible, and waits for someone to connect."; - ] @ help in + let man = + [ + `S "DESCRIPTION" + ; `P + "Advertises a given channel over as many protocols as possible, and \ + waits for someone to connect." + ] + @ help + in let fd = let doc = Printf.sprintf "File descriptor to advertise" in - Arg.(value & pos 0 (some int) None & info [] ~docv:"FD" ~doc) in - Term.(ret(pure advertise $ common_options_t $ fd)), - Term.info "advertise" ~sdocs:_common_options ~doc ~man + Arg.(value & pos 0 (some int) None & info [] ~docv:"FD" ~doc) + in + ( Term.(ret (pure advertise $ common_options_t $ fd)) + , Term.info "advertise" ~sdocs:_common_options ~doc ~man ) let connect_t _common_options_t = - Lwt_io.read_line_opt Lwt_io.stdin >>= (function | None -> return "" | Some x -> return x) >>= fun advertisement -> + (Lwt_io.read_line_opt Lwt_io.stdin >>= function + | None -> + return "" + | Some x -> + return x) + >>= fun advertisement -> let open Xcp_channel in - let fd = Lwt_unix.of_unix_file_descr (file_descr_of_t (t_of_rpc (Jsonrpc.of_string advertisement))) in + let fd = + Lwt_unix.of_unix_file_descr + (file_descr_of_t (t_of_rpc (Jsonrpc.of_string advertisement))) + in let a = copy_all Lwt_unix.stdin fd in let b = copy_all fd Lwt_unix.stdout in Lwt.join [a; b] let connect common_options_t = - Lwt_main.run(connect_t common_options_t); + Lwt_main.run (connect_t common_options_t) ; `Ok () let connect_cmd = let doc = "connect to a channel and proxy to the terminal" in - let man = [ - `S "DESCRIPTION"; - `P "Connect to a channel which has been advertised and proxy I/O to the console. The advertisement will be read from stdin as a single line of text."; - ] @ help in - Term.(ret(pure connect $ common_options_t)), - Term.info "connect" ~sdocs:_common_options ~doc ~man + let man = + [ + `S "DESCRIPTION" + ; `P + "Connect to a channel which has been advertised and proxy I/O to the \ + console. The advertisement will be read from stdin as a single line \ + of text." + ] + @ help + in + ( Term.(ret (pure connect $ common_options_t)) + , Term.info "connect" ~sdocs:_common_options ~doc ~man ) let default_cmd = let doc = "channel (file-descriptor) passing helper program" in let man = help in - Term.(ret (pure (fun _ -> `Help (`Pager, None)) $ common_options_t)), - Term.info "proxy" ~version:"1.0.0" ~sdocs:_common_options ~doc ~man + ( Term.(ret (pure (fun _ -> `Help (`Pager, None)) $ common_options_t)) + , Term.info "proxy" ~version:"1.0.0" ~sdocs:_common_options ~doc ~man ) let cmds = [advertise_cmd; connect_cmd] let _ = match Term.eval_choice default_cmd cmds with - | `Error _ -> exit 1 - | _ -> exit 0 + | `Error _ -> + exit 1 + | _ -> + exit 0 diff --git a/misc/dune b/misc/dune index 828e2c25..2bdcd854 100644 --- a/misc/dune +++ b/misc/dune @@ -1,11 +1,13 @@ (executable - (name channel_helper) - (modules channel_helper) - (libraries - cmdliner - lwt - lwt.unix - xapi-idl - ) - (preprocess (pps ppx_deriving_rpc)) -) + (name channel_helper) + (public_name xcp-idl-debugger) + (modules channel_helper) + (package xapi-idl) + (libraries + cmdliner + lwt + lwt.unix + xapi-idl + ) + (flags (:standard -w -39)) + (preprocess (pps ppx_deriving_rpc))) diff --git a/network/dune b/network/dune index f5f2c576..c4f30b67 100644 --- a/network/dune +++ b/network/dune @@ -1,41 +1,27 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - (library - (name xcp_network) - (public_name xapi-idl.network) - (flags (:standard -w -39-33)) - (modules (:standard \ network_cli)) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) -) + (name xcp_network) + (public_name xapi-idl.network) + (flags (:standard -w -39-33)) + (modules (:standard \ network_cli)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name network_cli) - (modules network_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.network - ) -) - -(alias - (name runtest) - (deps (:x network_cli.exe)) - (action (run %%{x})) -) + (name network_cli) + (modules network_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.network + )) -|} coverage_rewriter +(rule + (alias runtest) + (deps (:x network_cli.exe)) + (action (run %{x}))) diff --git a/network/network_cli.ml b/network/network_cli.ml index 385ede93..2cc0e9f1 100644 --- a/network/network_cli.ml +++ b/network/network_cli.ml @@ -2,25 +2,30 @@ open Network_interface -module Cmds = Interface_API(Cmdlinergen.Gen ()) +module Cmds = Interface_API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the network API. This allows scripting of the xcp-networkd daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "network_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the network API. This allows scripting of the xcp-networkd \ + daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "network_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli () = let rpc = Network_client.rpc in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) -let _ = - match cli () with - | `Ok f -> f () - | _ -> () +let _ = match cli () with `Ok f -> f () | _ -> () diff --git a/network/network_client.ml b/network/network_client.ml index 2c2ae140..9161ca11 100644 --- a/network/network_client.ml +++ b/network/network_client.ml @@ -15,26 +15,23 @@ let retry_econnrefused f = let rec loop () = let result = - try - Some (f ()) - with Unix.Unix_error((Unix.ECONNREFUSED | Unix.ENOENT), _, _) -> - Thread.delay 1.; - None in - match result with - | Some x -> x - | None -> loop () in + try Some (f ()) + with Unix.Unix_error ((Unix.ECONNREFUSED | Unix.ENOENT), _, _) -> + Thread.delay 1. ; None + in + match result with Some x -> x | None -> loop () + in loop () let rpc call = - retry_econnrefused - (fun () -> - if !Xcp_client.use_switch - then Xcp_client.json_switch_rpc !Network_interface.queue_name call - else Xcp_client.xml_http_rpc - ~srcstr:(Xcp_client.get_user_agent ()) - ~dststr:"network" - Network_interface.uri - call - ) + retry_econnrefused (fun () -> + if !Xcp_client.use_switch then + Xcp_client.json_switch_rpc !Network_interface.queue_name call + else + Xcp_client.xml_http_rpc + ~srcstr:(Xcp_client.get_user_agent ()) + ~dststr:"network" Network_interface.uri call) -module Client = Network_interface.Interface_API(Idl.Exn.GenClient(struct let rpc=rpc end)) +module Client = Network_interface.Interface_API (Idl.Exn.GenClient (struct + let rpc = rpc +end)) diff --git a/network/network_interface.ml b/network/network_interface.ml index 92c91bb6..3d42cacc 100644 --- a/network/network_interface.ml +++ b/network/network_interface.ml @@ -14,41 +14,34 @@ open Rpc open Idl -module D = Debug.Make(struct let name = "network_interface" end) +module D = Debug.Make (struct let name = "network_interface" end) + open D (** {2 Helper functions} *) let service_name = "networkd" + let queue_name = ref (Xcp_service.common_prefix ^ service_name) let default_sockets_dir = "/var/lib/xcp" + let default_path = ref (Filename.concat default_sockets_dir service_name) let uri () = "file:" ^ !default_path let comp f g x = f (g x) -let (++) f g x = comp f g x + +let ( ++ ) f g x = comp f g x let netmask_to_prefixlen netmask = Scanf.sscanf netmask "%d.%d.%d.%d" (fun a b c d -> - let rec length l x = - if x > 0 then - length (succ l) (x lsr 1) - else - l - in - let masks = List.map ((-) 255) [a; b; c; d] in - 32 - (List.fold_left length 0 masks) - ) + let rec length l x = if x > 0 then length (succ l) (x lsr 1) else l in + let masks = List.map (( - ) 255) [a; b; c; d] in + 32 - List.fold_left length 0 masks) let prefixlen_to_netmask len = let mask l = - if l <= 0 then - 0 - else if l > 8 then - 255 - else - 256 - (1 lsl (8 - l)) + if l <= 0 then 0 else if l > 8 then 255 else 256 - (1 lsl (8 - l)) in let lens = [len; len - 8; len - 16; len - 24] in let masks = List.map (string_of_int ++ mask) lens in @@ -56,294 +49,339 @@ let prefixlen_to_netmask len = module Unix = struct include Unix - let typ_of_inet_addr = Rpc.Types.Abstract ({ - aname = "inet_addr"; - test_data = [Unix.inet_addr_of_string "127.0.0.1"]; - rpc_of = (fun t -> Rpc.String (Unix.string_of_inet_addr t)); - of_rpc = (function - | Rpc.String s -> Ok (Unix.inet_addr_of_string s) - | r -> Error (`Msg (Printf.sprintf "typ_of_inet_addr: expectd rpc string but got %s" (Rpc.to_string r)))); - }) + + let typ_of_inet_addr = + Rpc.Types.Abstract + { + aname= "inet_addr" + ; test_data= [Unix.inet_addr_of_string "127.0.0.1"] + ; rpc_of= (fun t -> Rpc.String (Unix.string_of_inet_addr t)) + ; of_rpc= + (function + | Rpc.String s -> + Ok (Unix.inet_addr_of_string s) + | r -> + Error + (`Msg + (Printf.sprintf + "typ_of_inet_addr: expectd rpc string but got %s" + (Rpc.to_string r)))) + } end (** {2 Types} *) type debug_info = string [@@deriving rpcty] + type iface = string [@@deriving rpcty] + type port = string [@@deriving rpcty] + type bridge = string [@@deriving rpcty] + (* rpcty cannot handle polymorphic variant, so change the definition to variant *) type dhcp_options = Set_gateway | Set_dns [@@deriving rpcty] -type ipv4 = None4 | DHCP4 | Static4 of (Unix.inet_addr * int) list [@@deriving rpcty] -type ipv6 = None6 | Linklocal6 | DHCP6 | Autoconf6 | Static6 of (Unix.inet_addr * int) list [@@deriving rpcty] - -type duplex = - | Duplex_unknown - | Duplex_half - | Duplex_full -[@@default Duplex_unknown] + +type ipv4 = None4 | DHCP4 | Static4 of (Unix.inet_addr * int) list [@@deriving rpcty] +type ipv6 = + | None6 + | Linklocal6 + | DHCP6 + | Autoconf6 + | Static6 of (Unix.inet_addr * int) list +[@@deriving rpcty] + +type duplex = Duplex_unknown | Duplex_half | Duplex_full +[@@default Duplex_unknown] [@@deriving rpcty] + let string_of_duplex = function - | Duplex_unknown -> "unknown" - | Duplex_half -> "half" - | Duplex_full -> "full" + | Duplex_unknown -> + "unknown" + | Duplex_half -> + "half" + | Duplex_full -> + "full" let duplex_of_string = function - | "full" -> Duplex_full - | "half" -> Duplex_half - | _ -> Duplex_unknown + | "full" -> + Duplex_full + | "half" -> + Duplex_half + | _ -> + Duplex_unknown (* `Basic` is conflict with Rpc.Basic so rename it to `Basic_port`*) -type port_kind = - | Basic_port - | PVS_proxy -[@@deriving rpcty] +type port_kind = Basic_port | PVS_proxy [@@deriving rpcty] let string_of_port_kind = function - | Basic_port -> "basic" - | PVS_proxy -> "PVS proxy" + | Basic_port -> + "basic" + | PVS_proxy -> + "PVS proxy" type ipv4_route_t = { - subnet : Unix.inet_addr; - netmask : int; - gateway : Unix.inet_addr; -} [@@deriving rpcty] + subnet: Unix.inet_addr + ; netmask: int + ; gateway: Unix.inet_addr +} +[@@deriving rpcty] type kind = Openvswitch | Bridge [@@deriving rpcty] let string_of_kind = function - | Openvswitch -> "openvswitch" - | Bridge -> "bridge" + | Openvswitch -> + "openvswitch" + | Bridge -> + "bridge" type bond_mode = Balance_slb | Active_backup | Lacp [@@deriving rpcty] + type fail_mode = Standalone | Secure [@@deriving rpcty] type interface_config_t = { - ipv4_conf: ipv4 [@default None4]; - ipv4_gateway: Unix.inet_addr option [@default None]; - ipv6_conf: ipv6 [@default None6]; - ipv6_gateway: Unix.inet_addr option [@default None]; - ipv4_routes: ipv4_route_t list [@default []]; - dns: Unix.inet_addr list * string list [@default [], []]; - mtu: int [@default 1500]; - ethtool_settings: (string * string) list [@default []]; - ethtool_offload: (string * string) list [@default ["lro", "off"]]; - persistent_i: bool [@default false]; -} [@@deriving rpcty] + ipv4_conf: ipv4 [@default None4] + ; ipv4_gateway: Unix.inet_addr option [@default None] + ; ipv6_conf: ipv6 [@default None6] + ; ipv6_gateway: Unix.inet_addr option [@default None] + ; ipv4_routes: ipv4_route_t list [@default []] + ; dns: Unix.inet_addr list * string list [@default [], []] + ; mtu: int [@default 1500] + ; ethtool_settings: (string * string) list [@default []] + ; ethtool_offload: (string * string) list [@default [("lro", "off")]] + ; persistent_i: bool [@default false] +} +[@@deriving rpcty] type port_config_t = { - interfaces: iface list [@default []]; - bond_properties: (string * string) list [@default []]; - bond_mac: string option [@default None]; - kind: port_kind [@default Basic_port]; -} [@@deriving rpcty] - -type bridge_config_t = { - ports: (port * port_config_t) list [@default []]; - vlan: (bridge * int) option [@default None]; - bridge_mac: string option [@default None]; - igmp_snooping: bool option [@default None]; - other_config: (string * string) list [@default []]; - persistent_b: bool [@default false]; -} [@@deriving rpcty] - -type config_t = { - interface_config: (iface * interface_config_t) list [@default []]; - bridge_config: (bridge * bridge_config_t) list [@default []]; - gateway_interface: iface option [@default None]; - dns_interface: iface option [@default None]; -} [@@deriving rpcty] - -(** {2 Default configuration} *) -let default_interface = { - ipv4_conf = None4; - ipv4_gateway = None; - ipv6_conf = None6; - ipv6_gateway = None; - ipv4_routes = []; - dns = [], []; - mtu = 1500; - ethtool_settings = []; - ethtool_offload = ["lro", "off"]; - persistent_i = false; + interfaces: iface list [@default []] + ; bond_properties: (string * string) list [@default []] + ; bond_mac: string option [@default None] + ; kind: port_kind [@default Basic_port] } +[@@deriving rpcty] -let default_bridge = { - ports = []; - vlan = None; - bridge_mac = None; - igmp_snooping = None; - other_config = []; - persistent_b = false; +type bridge_config_t = { + ports: (port * port_config_t) list [@default []] + ; vlan: (bridge * int) option [@default None] + ; bridge_mac: string option [@default None] + ; igmp_snooping: bool option [@default None] + ; other_config: (string * string) list [@default []] + ; persistent_b: bool [@default false] } +[@@deriving rpcty] -let default_port = { - interfaces = []; - bond_properties = []; - bond_mac = None; - kind = Basic_port; +type config_t = { + interface_config: (iface * interface_config_t) list [@default []] + ; bridge_config: (bridge * bridge_config_t) list [@default []] + ; gateway_interface: iface option [@default None] + ; dns_interface: iface option [@default None] } +[@@deriving rpcty] -let default_config = { - interface_config = []; - bridge_config = []; - gateway_interface = None; - dns_interface = None -} +(** {2 Default configuration} *) +let default_interface = + { + ipv4_conf= None4 + ; ipv4_gateway= None + ; ipv6_conf= None6 + ; ipv6_gateway= None + ; ipv4_routes= [] + ; dns= ([], []) + ; mtu= 1500 + ; ethtool_settings= [] + ; ethtool_offload= [("lro", "off")] + ; persistent_i= false + } + +let default_bridge = + { + ports= [] + ; vlan= None + ; bridge_mac= None + ; igmp_snooping= None + ; other_config= [] + ; persistent_b= false + } + +let default_port = + {interfaces= []; bond_properties= []; bond_mac= None; kind= Basic_port} + +let default_config = + { + interface_config= [] + ; bridge_config= [] + ; gateway_interface= None + ; dns_interface= None + } (** {2 Configuration manipulation} *) let get_config config default name = - try - List.assoc name config - with _ -> default + try List.assoc name config with _ -> default -let remove_config config name = - List.remove_assoc name config +let remove_config config name = List.remove_assoc name config let update_config config name data = let replace_assoc key new_value existing = - (key, new_value) :: (List.filter (fun (k, _) -> k <> key) existing) in - - if List.mem_assoc name config then begin + (key, new_value) :: List.filter (fun (k, _) -> k <> key) existing + in + if List.mem_assoc name config then replace_assoc name data config - end else + else (name, data) :: config (** {2 Exceptions} *) type errors = - | Script_missing of string (** [Script_missing (script)] is reported if unable to find [script] *) - | Script_error of (string * string) list (** [Script_error ([(key * value); ...])] is reported when error occurs when executing script, the [key] and [value] indicates the information about the script and the error *) - | Read_error of string (** [Read_error (file)] is reported when error occurs when reading [file] *) - | Write_error of string (** [Write_error (file)] is reported when error occurs when writing [file] *) - | Not_implemented (** [Not_implemented] is reported if the interface is not implemented *) - | Vlan_in_use of (string * int) (** [Vlan_in_use (bridge, vlan_id)] is reported when [vlan_id] on [bridge] is inuse *) - | PVS_proxy_connection_error (** [PVS_proxy_connection_error] is reported when unable to connect PVS proxy *) - | Interface_does_not_exist of string (** The named network interface does not exist *) - | Bridge_does_not_exist of string (** The named bridge does not exist *) + | Script_missing of string + (** [Script_missing (script)] is reported if unable to find [script] *) + | Script_error of (string * string) list + (** [Script_error ([(key * value); ...])] is reported when error occurs + when executing script, the [key] and [value] indicates the information + about the script and the error *) + | Read_error of string + (** [Read_error (file)] is reported when error occurs when reading [file] *) + | Write_error of string + (** [Write_error (file)] is reported when error occurs when writing [file] *) + | Not_implemented + (** [Not_implemented] is reported if the interface is not implemented *) + | Vlan_in_use of (string * int) + (** [Vlan_in_use (bridge, vlan_id)] is reported when [vlan_id] on [bridge] + is inuse *) + | PVS_proxy_connection_error + (** [PVS_proxy_connection_error] is reported when unable to connect PVS + proxy *) + | Interface_does_not_exist of string + (** The named network interface does not exist *) + | Bridge_does_not_exist of string (** The named bridge does not exist *) | Internal_error of string - | Unknown_error (** The default variant for forward compatibility. *) -[@@default Unknown_error] -[@@deriving rpcty] + | Unknown_error (** The default variant for forward compatibility. *) +[@@default Unknown_error] [@@deriving rpcty] exception Network_error of errors -let () = (* register printer *) +let () = + (* register printer *) let sprintf = Printf.sprintf in let string_of_error e = - Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | Network_error e -> Some (sprintf "Network_interface.Network_error(%s)" (string_of_error e)) - | _ -> None in + | _ -> + None + in Printexc.register_printer printer -let err = Error. - { def = errors - ; raiser = (fun e -> - log_backtrace (); - let exn = Network_error e in - error "%s (%s)" (Printexc.to_string exn) __LOC__; - raise exn) - ; matcher = (function - | Network_error e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; +let err = + Error. + { + def= errors + ; raiser= + (fun e -> + log_backtrace () ; + let exn = Network_error e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) + ; matcher= + (function + | Network_error e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some (Internal_error (Printexc.to_string exn))) } (** {2 API functions} *) -module Interface_API(R : RPC) = struct +module Interface_API (R : RPC) = struct open R (* Define this module here because we will reuse the name `Interface` *) module Idl_Interface = Interface - let description = Idl_Interface.{ - name = "Network"; - namespace = Some "Network"; - description = [ - "This interface is used by Xapi and networkd to manage "; - "Xenserver network bridges and devices ."; - ]; - version=(1,0,0); - } + let description = + Idl_Interface. + { + name= "Network" + ; namespace= Some "Network" + ; description= + [ + "This interface is used by Xapi and networkd to manage " + ; "Xenserver network bridges and devices ." + ] + ; version= (1, 0, 0) + } let implementation = implement description - let debug_info_p = Param.mk ~description:[ - "an uninterpreted string to associate with the operation." - ] Types.string + let debug_info_p = + Param.mk + ~description:["an uninterpreted string to associate with the operation."] + Types.string let unit_p = Param.mk Types.unit - let clear_state = declare - "clear_state" + let clear_state = + declare "clear_state" ["Clear configuration state"] (unit_p @-> returning unit_p err) - let reset_state = declare - "reset_state" + let reset_state = + declare "reset_state" ["Reset configuration state"] (unit_p @-> returning unit_p err) let set_gateway_interface = let name_p = Param.mk ~name:"name" ~description:["gateway name"] iface in - declare - "set_gateway_interface" - ["Set gateway interface"] + declare "set_gateway_interface" ["Set gateway interface"] (debug_info_p @-> name_p @-> returning unit_p err) let set_dns_interface = let name_p = Param.mk ~name:"name" ~description:["gateway name"] iface in - declare - "set_dns_interface" - ["Set dns interface"] + declare "set_dns_interface" ["Set dns interface"] (debug_info_p @-> name_p @-> returning unit_p err) module Interface = struct - let iface_name_p = Param.mk ~name:"name" ~description:["interface name"] iface + let iface_name_p = + Param.mk ~name:"name" ~description:["interface name"] iface let get_all = let module T = struct type _iface_list_t = iface list [@@deriving rpcty] end in - let iface_list_p = Param.mk ~description:["interface list"] T._iface_list_t in - declare - "Interface.get_all" + let iface_list_p = + Param.mk ~description:["interface list"] T._iface_list_t + in + declare "Interface.get_all" ["Get list of all interface names"] (debug_info_p @-> unit_p @-> returning iface_list_p err) let exists = let result = Param.mk ~description:["existence"] Types.bool in - declare - "Interface.exists" + declare "Interface.exists" ["Check interface existence"] (debug_info_p @-> iface_name_p @-> returning result err) let get_pci_bus_path = let result = Param.mk ~description:["PCI bus path"] Types.string in - declare - "Interface.get_pci_bus_path" + declare "Interface.get_pci_bus_path" ["Get PCI bus path of the interface"] (debug_info_p @-> iface_name_p @-> returning result err) let get_mac = let result = Param.mk ~description:["MAC address"] Types.string in - declare - "Interface.get_mac" + declare "Interface.get_mac" ["Get Mac address of the interface"] (debug_info_p @-> iface_name_p @-> returning result err) let is_up = let result = Param.mk ~description:["interface is up"] Types.bool in - declare - "Interface.is_up" + declare "Interface.is_up" ["Check whether the interface is up"] (debug_info_p @-> iface_name_p @-> returning result err) @@ -351,54 +389,55 @@ module Interface_API(R : RPC) = struct let module T = struct type _ip_addr_list_t = (Unix.inet_addr * int) list [@@deriving rpcty] end in - let result = Param.mk ~description:["list of interface IPv4 addresses"] T._ip_addr_list_t in - declare - "Interface.get_ipv4_addr" + let result = + Param.mk + ~description:["list of interface IPv4 addresses"] + T._ip_addr_list_t + in + declare "Interface.get_ipv4_addr" ["Get list of IPv4 addresses of the interface"] (debug_info_p @-> iface_name_p @-> returning result err) let set_ipv4_conf = let conf_p = Param.mk ~description:["IPv4 configuration type"] ipv4 in - declare - "Interface.set_ipv4_conf" - ["Set IPv4 configuration"] + declare "Interface.set_ipv4_conf" ["Set IPv4 configuration"] (debug_info_p @-> iface_name_p @-> conf_p @-> returning unit_p err) let get_ipv4_gateway = let module T = struct type _inet_addr_opt_t = Unix.inet_addr option [@@deriving rpcty] end in - let result = Param.mk ~description:["gateway address if exists"] T._inet_addr_opt_t in - declare - "Interface.get_ipv4_gateway" - ["Get IPv4 gateway"] + let result = + Param.mk ~description:["gateway address if exists"] T._inet_addr_opt_t + in + declare "Interface.get_ipv4_gateway" ["Get IPv4 gateway"] (debug_info_p @-> iface_name_p @-> returning result err) let get_ipv6_addr = let module T = struct type _ip_addr_list_t = (Unix.inet_addr * int) list [@@deriving rpcty] end in - let result = Param.mk ~description:["list of interface IPv6 addresses"] T._ip_addr_list_t in - declare - "Interface.get_ipv6_addr" - ["Get IPv6 address"] + let result = + Param.mk + ~description:["list of interface IPv6 addresses"] + T._ip_addr_list_t + in + declare "Interface.get_ipv6_addr" ["Get IPv6 address"] (debug_info_p @-> iface_name_p @-> returning result err) let get_dns = let module T = struct type _dns_info_t = Unix.inet_addr list * string list [@@deriving rpcty] end in - let result = Param.mk ~description:["DNS servers information"] T._dns_info_t in - declare - "Interface.get_dns" - ["Get DNS"] + let result = + Param.mk ~description:["DNS servers information"] T._dns_info_t + in + declare "Interface.get_dns" ["Get DNS"] (debug_info_p @-> iface_name_p @-> returning result err) let get_mtu = let result = Param.mk ~description:["MTU"] Types.int in - declare - "Interface.get_mtu" - ["Get MTU"] + declare "Interface.get_mtu" ["Get MTU"] (debug_info_p @-> iface_name_p @-> returning result err) let get_capabilities = @@ -406,55 +445,64 @@ module Interface_API(R : RPC) = struct type _capabilities_t = string list [@@deriving rpcty] end in let result = Param.mk ~description:["capabilities"] T._capabilities_t in - declare - "Interface.get_capabilities" + declare "Interface.get_capabilities" ["Get capabilities on the interface"] (debug_info_p @-> iface_name_p @-> returning result err) let is_connected = - let result = Param.mk ~description:["whether interface is connected"] Types.bool in - declare - "Interface.is_connected" + let result = + Param.mk ~description:["whether interface is connected"] Types.bool + in + declare "Interface.is_connected" ["Check whether interface is connected"] (debug_info_p @-> iface_name_p @-> returning result err) let is_physical = - let result = Param.mk ~description:["whether interface is physical"] Types.bool in - declare - "Interface.is_physical" + let result = + Param.mk ~description:["whether interface is physical"] Types.bool + in + declare "Interface.is_physical" ["Check whether interface is physical"] (debug_info_p @-> iface_name_p @-> returning result err) let has_vlan = let vlan_p = Param.mk ~name:"vlan" ~description:["vlan id"] Types.int in - let result = Param.mk ~description:["whether interface has vlan"] Types.bool in - declare - "Interface.has_vlan" + let result = + Param.mk ~description:["whether interface has vlan"] Types.bool + in + declare "Interface.has_vlan" ["Check whether interface has vlan"] (debug_info_p @-> iface_name_p @-> vlan_p @-> returning result err) let bring_down = - declare - "Interface.bring_down" - ["Bring PIF down"] + declare "Interface.bring_down" ["Bring PIF down"] (debug_info_p @-> iface_name_p @-> returning unit_p err) let set_persistent = - let value_p = Param.mk ~name:"value" ~description:["persistent or not"] Types.bool in - declare - "Interface.set_persistent" + let value_p = + Param.mk ~name:"value" ~description:["persistent or not"] Types.bool + in + declare "Interface.set_persistent" ["Make PIF to persistent or not"] (debug_info_p @-> iface_name_p @-> value_p @-> returning unit_p err) let make_config = let module T = struct type _conservative_t = bool [@@deriving rpcty] - type _iface_config_list_t = (iface * interface_config_t) list [@@deriving rpcty] + + type _iface_config_list_t = (iface * interface_config_t) list + [@@deriving rpcty] end in - let conservative_p = Param.mk ~name:"conservative" ~description:["conservative"] T._conservative_t in - let config_p = Param.mk ~name:"config" ~description:["list of interface configuration"] T._iface_config_list_t in - declare - "Interface.make_config" + let conservative_p = + Param.mk ~name:"conservative" ~description:["conservative"] + T._conservative_t + in + let config_p = + Param.mk ~name:"config" + ~description:["list of interface configuration"] + T._iface_config_list_t + in + declare "Interface.make_config" ["Make interface configuration"] (debug_info_p @-> conservative_p @-> config_p @-> returning unit_p err) end @@ -465,102 +513,133 @@ module Interface_API(R : RPC) = struct type _bridge_list_t = bridge list [@@deriving rpcty] end in let result = Param.mk ~description:["bridge list"] T._bridge_list_t in - declare - "Bridge.get_all" - ["Get all bridges"] + declare "Bridge.get_all" ["Get all bridges"] (debug_info_p @-> unit_p @-> returning result err) let create = let module T = struct type _vlan_opt_t = (bridge * int) option [@@deriving rpcty] + type _mac_opt_t = string option [@@deriving rpcty] + type _igmp_snooping_opt_t = bool option [@@deriving rpcty] - type _other_config_opt_t = (string * string) list option [@@deriving rpcty] + + type _other_config_opt_t = (string * string) list option + [@@deriving rpcty] end in let vlan_p = Param.mk ~name:"vlan" ~description:["vlan"] T._vlan_opt_t in let mac_p = Param.mk ~name:"mac" ~description:["MAC"] T._mac_opt_t in - let igmp_snooping_p = Param.mk ~name:"igmp_snooping" T._igmp_snooping_opt_t in - let other_config_p = Param.mk ~name:"other_config" T._other_config_opt_t in + let igmp_snooping_p = + Param.mk ~name:"igmp_snooping" T._igmp_snooping_opt_t + in + let other_config_p = + Param.mk ~name:"other_config" T._other_config_opt_t + in let name_p = Param.mk ~name:"name" ~description:["bridge name"] bridge in - declare - "Bridge.create" - ["Create bridge"] - (debug_info_p @-> vlan_p @-> mac_p @-> igmp_snooping_p @-> other_config_p @-> name_p @-> returning unit_p err) + declare "Bridge.create" ["Create bridge"] + (debug_info_p + @-> vlan_p + @-> mac_p + @-> igmp_snooping_p + @-> other_config_p + @-> name_p + @-> returning unit_p err + ) let destroy = - let module T = struct - type _force_t = bool [@@deriving rpcty] - end in + let module T = struct type _force_t = bool [@@deriving rpcty] end in let force_p = Param.mk ~name:"force" ~description:["force"] T._force_t in let name_p = Param.mk ~name:"name" ~description:["name"] bridge in - declare - "Bridge.destroy" - ["Destroy bridge"] + declare "Bridge.destroy" ["Destroy bridge"] (debug_info_p @-> force_p @-> name_p @-> returning unit_p err) let get_kind = let result = Param.mk ~description:["backend kind"] kind in - declare - "Bridge.get_kind" - ["Get backend kind"] + declare "Bridge.get_kind" ["Get backend kind"] (debug_info_p @-> unit_p @-> returning result err) let get_all_ports = let module T = struct type _from_cache_t = bool [@@deriving rpcty] + type _all_ports_t = (port * iface list) list [@@deriving rpcty] end in - let from_cache_p = Param.mk ~name:"from_cache" ~description:["whether from cache"] T._from_cache_t in + let from_cache_p = + Param.mk ~name:"from_cache" ~description:["whether from cache"] + T._from_cache_t + in let result = Param.mk ~description:["all ports"] T._all_ports_t in - declare - "Bridge.get_all_ports" - ["Get all ports"] + declare "Bridge.get_all_ports" ["Get all ports"] (debug_info_p @-> from_cache_p @-> returning result err) let get_all_bonds = let module T = struct type _from_cache_t = bool [@@deriving rpcty] + type _all_bonds_t = (port * iface list) list [@@deriving rpcty] end in - let from_cache_p = Param.mk ~name:"from_cache" ~description:["whether from cache"] T._from_cache_t in + let from_cache_p = + Param.mk ~name:"from_cache" ~description:["whether from cache"] + T._from_cache_t + in let result = Param.mk ~description:["all bonds"] T._all_bonds_t in - declare - "Bridge.get_all_bonds" - ["get all bonds"] + declare "Bridge.get_all_bonds" ["get all bonds"] (debug_info_p @-> from_cache_p @-> returning result err) let set_persistent = let name_p = Param.mk ~name:"name" ~description:["bridge name"] bridge in - let value_p = Param.mk ~name:"value" ~description:["persistent value"] Types.bool in - declare - "Bridge.set_persistent" + let value_p = + Param.mk ~name:"value" ~description:["persistent value"] Types.bool + in + declare "Bridge.set_persistent" ["Make bridge to persistent or not"] (debug_info_p @-> name_p @-> value_p @-> returning unit_p err) let add_port = let module T = struct type _bond_mac_opt_t = string option [@@deriving rpcty] + type _interfaces_t = iface list [@@deriving rpcty] - type _bond_properties_opt_t = (string * string) list option [@@deriving rpcty] + + type _bond_properties_opt_t = (string * string) list option + [@@deriving rpcty] + type _kind_opt_t = port_kind option [@@deriving rpcty] end in - let bond_mac_p = Param.mk ~name:"bond_mac" ~description:["bond MAC"] T._bond_mac_opt_t in - let bridge_p = Param.mk ~name:"bridge" ~description:["bridge name"] bridge in + let bond_mac_p = + Param.mk ~name:"bond_mac" ~description:["bond MAC"] T._bond_mac_opt_t + in + let bridge_p = + Param.mk ~name:"bridge" ~description:["bridge name"] bridge + in let name_p = Param.mk ~name:"name" ~description:["port name"] port in - let interfaces_p = Param.mk ~name:"interfaces" ~description:["interfaces"] T._interfaces_t in - let bond_properties_p = Param.mk ~name:"bond_properties" ~description:["bond properties"] T._bond_properties_opt_t in - let kind_p = Param.mk ~name:"kind" ~description:["port kind"] T._kind_opt_t in - declare - "Bridge.add_port" - ["Add port"] - (debug_info_p @-> bond_mac_p @-> bridge_p @-> name_p @-> interfaces_p @-> bond_properties_p @-> kind_p @-> returning unit_p err) + let interfaces_p = + Param.mk ~name:"interfaces" ~description:["interfaces"] T._interfaces_t + in + let bond_properties_p = + Param.mk ~name:"bond_properties" ~description:["bond properties"] + T._bond_properties_opt_t + in + let kind_p = + Param.mk ~name:"kind" ~description:["port kind"] T._kind_opt_t + in + declare "Bridge.add_port" ["Add port"] + (debug_info_p + @-> bond_mac_p + @-> bridge_p + @-> name_p + @-> interfaces_p + @-> bond_properties_p + @-> kind_p + @-> returning unit_p err + ) let remove_port = - let bridge_p = Param.mk ~name:"bridge" ~description:["bridge name"] bridge in + let bridge_p = + Param.mk ~name:"bridge" ~description:["bridge name"] bridge + in let name_p = Param.mk ~name:"name" ~description:["port name"] port in - declare - "Bridge.remove_port" - ["Remove port"] + declare "Bridge.remove_port" ["Remove port"] (debug_info_p @-> bridge_p @-> name_p @-> returning unit_p err) let get_interfaces = @@ -569,9 +648,7 @@ module Interface_API(R : RPC) = struct end in let name_p = Param.mk ~name:"name" ~description:["bridge name"] bridge in let result = Param.mk ~description:["interface list"] T._iface_list_t in - declare - "Bridge.get_interfaces" - ["Get interfaces"] + declare "Bridge.get_interfaces" ["Get interfaces"] (debug_info_p @-> name_p @-> returning result err) let get_physical_interfaces = @@ -580,20 +657,19 @@ module Interface_API(R : RPC) = struct end in let name_p = Param.mk ~name:"name" ~description:["bridge name"] bridge in let result = Param.mk ~description:["interface list"] T._iface_list_t in - declare - "Bridge.get_physical_interfaces" + declare "Bridge.get_physical_interfaces" ["Get physical interfaces"] (debug_info_p @-> name_p @-> returning result err) let make_config = let module T = struct type _conservative_t = bool [@@deriving rpcty] + type _config_t = (bridge * bridge_config_t) list [@@deriving rpcty] end in let conservative_p = Param.mk ~name:"conservative" T._conservative_t in let config_p = Param.mk ~name:"config" T._config_t in - declare - "Bridge.make_config" + declare "Bridge.make_config" ["Make bridge configuration"] (debug_info_p @-> conservative_p @-> config_p @-> returning unit_p err) end @@ -601,101 +677,92 @@ module Interface_API(R : RPC) = struct module PVS_proxy = struct module Server = struct type t = { - uuid: string; - addresses: Unix.inet_addr list; - first_port: int; - last_port: int; - } [@@deriving rpcty] + uuid: string + ; addresses: Unix.inet_addr list + ; first_port: int + ; last_port: int + } + [@@deriving rpcty] end module Client = struct - type t = { - uuid: string; - mac: string; - interface: string; - prepopulate: bool; - } [@@deriving rpcty] + type t = {uuid: string; mac: string; interface: string; prepopulate: bool} + [@@deriving rpcty] end type t = { - site_uuid: string; - site_name: string; - servers: Server.t list; - clients: Client.t list; - vdi: string; - } [@@deriving rpcty] + site_uuid: string + ; site_name: string + ; servers: Server.t list + ; clients: Client.t list + ; vdi: string + } + [@@deriving rpcty] let configure_site = let pvs_p = Param.mk ~description:["proxy"] t in - declare - "PVS_proxy.configure_site" - ["Configure site"] + declare "PVS_proxy.configure_site" ["Configure site"] (debug_info_p @-> pvs_p @-> returning unit_p err) let remove_site = let site_p = Param.mk ~description:["site name"] Types.string in - declare - "PVS_proxy.remove_site" - ["Remove site"] + declare "PVS_proxy.remove_site" ["Remove site"] (debug_info_p @-> site_p @-> returning unit_p err) end module Sriov = struct type sriov_pci_t = { - mac: string option; - vlan: int64 option; - rate: int64 option; - } [@@deriving rpcty] + mac: string option + ; vlan: int64 option + ; rate: int64 option + } + [@@deriving rpcty] type enable_action_result = | Modprobe_successful_requires_reboot | Modprobe_successful | Sysfs_successful + | Manual_successful [@@deriving rpcty] - type enable_result = - | Ok of enable_action_result - | Error of string + type enable_result = Ok of enable_action_result | Error of string [@@deriving rpcty] - type disable_result = - | Ok - | Error of string - [@@deriving rpcty] + type disable_result = Ok | Error of string [@@deriving rpcty] - type config_error = - | Config_vf_rate_not_supported - | Unknown of string + type config_error = Config_vf_rate_not_supported | Unknown of string [@@deriving rpcty] - type config_result = - | Ok - | Error of config_error - [@@deriving rpcty] + type config_result = Ok | Error of config_error [@@deriving rpcty] - let iface_name_p = Param.mk ~name:"name" ~description:["interface name"] iface + let iface_name_p = + Param.mk ~name:"name" ~description:["interface name"] iface let enable = - let result_p = Param.mk ~description:["SR-IOV enable result"] enable_result in - declare - "Sriov.enable" - ["Enable SR-IOV"] + let result_p = + Param.mk ~description:["SR-IOV enable result"] enable_result + in + declare "Sriov.enable" ["Enable SR-IOV"] (debug_info_p @-> iface_name_p @-> returning result_p err) let disable = - let result_p = Param.mk ~description:["SR-IOV disable result"] disable_result in - declare - "Sriov.disable" - ["Disable SR-IOV"] + let result_p = + Param.mk ~description:["SR-IOV disable result"] disable_result + in + declare "Sriov.disable" ["Disable SR-IOV"] (debug_info_p @-> iface_name_p @-> returning result_p err) let make_vf_config = - let pci_address_p = Param.mk ~description:["pci address"] Xcp_pci.address in + let pci_address_p = + Param.mk ~description:["pci address"] Xcp_pci.address + in let vf_info_p = Param.mk ~description:["vf info"] sriov_pci_t in - let result_t = Param.mk ~description:["SR-IOV make vf configuration result"] config_result in - declare - "Sriov.make_vf_config" - ["Make SR-IOV vf config"] + let result_t = + Param.mk + ~description:["SR-IOV make vf configuration result"] + config_result + in + declare "Sriov.make_vf_config" ["Make SR-IOV vf config"] (debug_info_p @-> pci_address_p @-> vf_info_p @-> returning result_t err) end end diff --git a/network/network_stats.ml b/network/network_stats.ml index 85336f2f..1e10cb8a 100644 --- a/network/network_stats.ml +++ b/network/network_stats.ml @@ -19,56 +19,67 @@ open Network_interface let stats_file = "/dev/shm/network_stats" + let interval = 5. (* seconds *) + let num_retries = 2 + let retry_delay = 0.5 let magic = "xapistat" + let magic_bytes = 8 + let checksum_bytes = 32 + let length_bytes = 8 type iface_stats = { - tx_bytes: int64; (* bytes emitted *) - tx_pkts: int64; (* packets emitted *) - tx_errors: int64; (* error emitted *) - rx_bytes: int64; (* bytes received *) - rx_pkts: int64; (* packets received *) - rx_errors: int64; (* error received *) - carrier: bool; - speed: int; - duplex: duplex; - pci_bus_path: string; - vendor_id: string; - device_id: string; - nb_links: int; - links_up: int; - interfaces: iface list; -} [@@deriving rpcty] - -let default_stats = { - tx_bytes = 0L; - tx_pkts = 0L; - tx_errors = 0L; - rx_bytes = 0L; - rx_pkts = 0L; - rx_errors = 0L; - carrier = false; - speed = 0; - duplex = Duplex_unknown; - pci_bus_path = ""; - vendor_id = ""; - device_id = ""; - nb_links = 0; - links_up = 0; - interfaces = []; + tx_bytes: int64 (** bytes emitted *) + ; tx_pkts: int64 (** packets emitted *) + ; tx_errors: int64 (** error emitted *) + ; rx_bytes: int64 (** bytes received *) + ; rx_pkts: int64 (** packets received *) + ; rx_errors: int64 (** error received *) + ; carrier: bool + ; speed: int + ; duplex: duplex + ; pci_bus_path: string + ; vendor_id: string + ; device_id: string + ; nb_links: int + ; links_up: int + ; interfaces: iface list } +[@@deriving rpcty] + +let default_stats = + { + tx_bytes= 0L + ; tx_pkts= 0L + ; tx_errors= 0L + ; rx_bytes= 0L + ; rx_pkts= 0L + ; rx_errors= 0L + ; carrier= false + ; speed= 0 + ; duplex= Duplex_unknown + ; pci_bus_path= "" + ; vendor_id= "" + ; device_id= "" + ; nb_links= 0 + ; links_up= 0 + ; interfaces= [] + } type stats_t = (iface * iface_stats) list [@@deriving rpcty] exception Read_error + exception Invalid_magic_string + exception Invalid_checksum + exception Invalid_length (* Shamelessly stolen from Unixext. *) @@ -76,28 +87,33 @@ module File_helpers = struct (** open a file, and make sure the close is always done *) let with_file file mode perms f = let fd = Unix.openfile file mode perms in - let r = - try f fd - with exn -> Unix.close fd; raise exn - in - Unix.close fd; - r + let r = try f fd with exn -> Unix.close fd ; raise exn in + Unix.close fd ; r (** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) from the fd [fd] with initial value [start] *) - let fd_blocks_fold block_size f start fd = + let fd_blocks_fold block_size f start fd = let block = Bytes.create block_size in - let rec fold acc = + let rec fold acc = let n = Unix.read fd block 0 block_size in (* Consider making the interface explicitly use Substrings *) - let s = if n = block_size then (Bytes.to_string block) else Bytes.sub_string block 0 n in - if n = 0 then acc else fold (f acc s) in + let s = + if n = block_size then + Bytes.to_string block + else + Bytes.sub_string block 0 n + in + if n = 0 then acc else fold (f acc s) + in fold start - let buffer_of_fd fd = - fd_blocks_fold 1024 (fun b s -> Buffer.add_string b s; b) (Buffer.create 1024) fd + let buffer_of_fd fd = + fd_blocks_fold 1024 + (fun b s -> Buffer.add_string b s ; b) + (Buffer.create 1024) fd - let buffer_of_file file_path = with_file file_path [ Unix.O_RDONLY ] 0 buffer_of_fd + let buffer_of_file file_path = + with_file file_path [Unix.O_RDONLY] 0 buffer_of_fd let string_of_file file_path = Buffer.contents (buffer_of_file file_path) end @@ -106,28 +122,37 @@ let read_stats () = let rec retry n = try let data = File_helpers.string_of_file stats_file in - if String.sub data 0 magic_bytes <> magic then - raise Invalid_magic_string; + if String.sub data 0 magic_bytes <> magic then raise Invalid_magic_string ; let checksum = String.sub data magic_bytes checksum_bytes in let length = - try int_of_string ("0x" ^ (String.sub data (magic_bytes + checksum_bytes) length_bytes)) + try + int_of_string + ("0x" ^ String.sub data (magic_bytes + checksum_bytes) length_bytes) with _ -> raise Invalid_length in - let payload = String.sub data (magic_bytes + checksum_bytes + length_bytes) length in + let payload = + String.sub data (magic_bytes + checksum_bytes + length_bytes) length + in if payload |> Digest.string |> Digest.to_hex <> checksum then raise Invalid_checksum else - match payload |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_stats_t with - | Result.Ok v -> v - | Result.Error _ -> raise Read_error - with e -> - if n > 0 then begin - Thread.delay retry_delay; + match + payload |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_stats_t + with + | Result.Ok v -> + v + | Result.Error _ -> + raise Read_error + with e -> ( + if n > 0 then ( + Thread.delay retry_delay ; retry (n - 1) - end else + ) else match e with - | Invalid_magic_string | Invalid_length | Invalid_checksum -> raise e - | _ -> raise Read_error + | Invalid_magic_string | Invalid_length | Invalid_checksum -> + raise e + | _ -> + raise Read_error + ) in retry num_retries - diff --git a/rrd/data_source.ml b/rrd/data_source.ml index 3151aa62..0bb817fb 100644 --- a/rrd/data_source.ml +++ b/rrd/data_source.ml @@ -13,21 +13,23 @@ *) type t = { - name : string; - description : string; - enabled : bool; - standard : bool; - min : float; - max : float; - units : string -} [@@deriving rpcty] + name: string + ; description: string + ; enabled: bool + ; standard: bool + ; min: float + ; max: float + ; units: string +} +[@@deriving rpcty] -let to_key_value_map ds = [ - "name_label", ds.name; - "name_description", ds.description; - "enabled", string_of_bool ds.enabled; - "standard", string_of_bool ds.standard; - "min", string_of_float ds.min; - "max", string_of_float ds.max; - "units", ds.units; -] +let to_key_value_map ds = + [ + ("name_label", ds.name) + ; ("name_description", ds.description) + ; ("enabled", string_of_bool ds.enabled) + ; ("standard", string_of_bool ds.standard) + ; ("min", string_of_float ds.min) + ; ("max", string_of_float ds.max) + ; ("units", ds.units) + ] diff --git a/rrd/ds.ml b/rrd/ds.ml index 0f0d2588..620ba3fc 100644 --- a/rrd/ds.ml +++ b/rrd/ds.ml @@ -12,31 +12,32 @@ * GNU Lesser General Public License for more details. *) (** Data source - * @group Performance Monitoring - *) + + @group Performance Monitoring *) (** This is used both for updating the DSs and for creating them *) type ds = { - ds_name : string; - ds_description : string; - ds_value : Rrd.ds_value_type; - ds_type : Rrd.ds_type; - ds_default : bool; - ds_min : float; - ds_max : float; - ds_units : string; - ds_pdp_transform_function : float -> float; + ds_name: string + ; ds_description: string + ; ds_value: Rrd.ds_value_type + ; ds_type: Rrd.ds_type + ; ds_default: bool + ; ds_min: float + ; ds_max: float + ; ds_units: string + ; ds_pdp_transform_function: float -> float } -let ds_make ~name ~description ~value ~ty ~default ~units - ?(min = neg_infinity) ?(max = infinity) ?(transform = (fun x -> x)) () = { - ds_name = name; - ds_description = description; - ds_value = value; - ds_type = ty; - ds_default = default; - ds_min = min; - ds_max = max; - ds_units = units; - ds_pdp_transform_function = transform; -} +let ds_make ~name ~description ~value ~ty ~default ~units ?(min = neg_infinity) + ?(max = infinity) ?(transform = fun x -> x) () = + { + ds_name= name + ; ds_description= description + ; ds_value= value + ; ds_type= ty + ; ds_default= default + ; ds_min= min + ; ds_max= max + ; ds_units= units + ; ds_pdp_transform_function= transform + } diff --git a/rrd/dune b/rrd/dune index 90cde1cd..99763bb1 100644 --- a/rrd/dune +++ b/rrd/dune @@ -1,74 +1,59 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - (library - (name xcp_rrd_interface_types) - (public_name xapi-idl.rrd.interface.types) - (modules data_source) - (flags (:standard -w -39)) - (libraries - rpclib.core - xapi-rrd - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) -) + (name xcp_rrd_interface_types) + (public_name xapi-idl.rrd.interface.types) + (modules data_source) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-rrd + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (library - (name xcp_rrd_interface) - (public_name xapi-idl.rrd.interface) - (modules rrd_interface) - (flags (:standard -w -39)) - (libraries - rpclib.core - xapi-rrd - threads - xapi-idl - xapi-idl.rrd.interface.types - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) -) + (name xcp_rrd_interface) + (public_name xapi-idl.rrd.interface) + (modules rrd_interface) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.rrd.interface.types + xapi-rrd + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (library - (name xcp_rrd) - (public_name xapi-idl.rrd) - (modules (:standard \ data_source rrd_interface rrd_cli)) - (flags (:standard -w -39)) - (libraries - rpclib.core - xapi-rrd - threads - xapi-idl - xapi-idl.rrd.interface - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) -) + (name xcp_rrd) + (public_name xapi-idl.rrd) + (modules (:standard \ data_source rrd_interface rrd_cli)) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.rrd.interface + xapi-rrd + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name rrd_cli) - (modules rrd_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.rrd - ) -) + (name rrd_cli) + (modules rrd_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.rrd + )) -(alias - (name runtest) - (deps (:x rrd_cli.exe)) - (action (run %%{x})) -) +(rule + (alias runtest) + (deps (:x rrd_cli.exe)) + (action (run %{x}))) -|} coverage_rewriter coverage_rewriter coverage_rewriter diff --git a/rrd/rrd_cli.ml b/rrd/rrd_cli.ml index 1cdd640f..0046a252 100644 --- a/rrd/rrd_cli.ml +++ b/rrd/rrd_cli.ml @@ -1,23 +1,27 @@ - - (* Rrd CLI *) -module Cmds = Rrd_interface.RPC_API(Cmdlinergen.Gen ()) +module Cmds = Rrd_interface.RPC_API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the Db monitoring API. This allows scripting of the Rrd daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "rrd_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the Db monitoring API. This allows scripting of the Rrd \ + daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "rrd_cli" ~version:(version_str Cmds.description) ~doc ) let cli () = let rpc = Rrd_client.rpc in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) let _ = cli () diff --git a/rrd/rrd_client.ml b/rrd/rrd_client.ml index 79771479..7f831678 100644 --- a/rrd/rrd_client.ml +++ b/rrd/rrd_client.ml @@ -16,28 +16,22 @@ open Rrd_interface open Xcp_client let rec retry_econnrefused f = - try - f () - with - | Unix.Unix_error(Unix.ECONNREFUSED, "connect", _) -> - (* debug "Caught ECONNREFUSED; retrying in 5s"; *) - Thread.delay 5.; - retry_econnrefused f + try f () with + | Unix.Unix_error (Unix.ECONNREFUSED, "connect", _) -> + (* debug "Caught ECONNREFUSED; retrying in 5s"; *) + Thread.delay 5. ; retry_econnrefused f | e -> - (* error "Caught %s: does the rrd service need restarting?" (Printexc.to_string e); *) - - raise e + (* error "Caught %s: does the rrd service need restarting?" + (Printexc.to_string e); *) + raise e let rpc call = - retry_econnrefused - (fun () -> - (* TODO: the message switch doesn't handle raw HTTP very well *) - if (* !use_switch *) false - then json_switch_rpc !queue_name call - else xml_http_rpc - ~srcstr:(get_user_agent ()) - ~dststr:"rrd" - Rrd_interface.uri - call - ) -module Client = RPC_API(Idl.Exn.GenClient(struct let rpc=rpc end)) + retry_econnrefused (fun () -> + (* TODO: the message switch doesn't handle raw HTTP very well *) + if (* !use_switch *) false then + json_switch_rpc !queue_name call + else + xml_http_rpc ~srcstr:(get_user_agent ()) ~dststr:"rrd" Rrd_interface.uri + call) + +module Client = RPC_API (Idl.Exn.GenClient (struct let rpc = rpc end)) diff --git a/rrd/rrd_interface.ml b/rrd/rrd_interface.ml index d8add3ad..9a9c6035 100644 --- a/rrd/rrd_interface.ml +++ b/rrd/rrd_interface.ml @@ -22,15 +22,20 @@ open Rpc open Idl let service_name = "rrd" + let queue_name = ref (Xcp_service.common_prefix ^ service_name) let default_sockets_dir = "/var/lib/xcp" + let daemon_name = "xcp-rrdd" + let default_path = ref (Filename.concat default_sockets_dir daemon_name) -let forwarded_path = ref (Filename.concat default_sockets_dir daemon_name ^ ".forwarded") + +let forwarded_path = + ref (Filename.concat default_sockets_dir daemon_name ^ ".forwarded") let set_sockets_dir x = - default_path := Filename.concat x daemon_name; + default_path := Filename.concat x daemon_name ; forwarded_path := !default_path ^ ".forwarded" let uri () = "file:" ^ !default_path @@ -39,375 +44,549 @@ let uri () = "file:" ^ !default_path type plugin_protocol = | V1 (** Plugin protocol 1 *) | V2 (** Plugin protocol 2 *) -[@@default V2] -[@@deriving rpcty] +[@@default V2] [@@deriving rpcty] (** Domain ID of VM *) -type interdomain_uid = - { name : string; (** VM domain name label *) - frontend_domid : int (** Front-end domain ID number *) - } [@@deriving rpcty] - -(* Note: for types such as rrd_req, which alias - * user-defined types, it is usually not enough - * to add [@@deriving rpcty] to derive RPC types, - * and rpc functions must be declared in the definition. - * However, types such as Rrd.sampling_frequency have - * already been defined as RPC types in their original declarations - * so we are able to derive these type aliases like so *) - -type rrd_freq = Rrd.sampling_frequency = Five_Seconds +type interdomain_uid = { + name: string (** VM domain name label *) + ; frontend_domid: int (** Front-end domain ID number *) +} [@@deriving rpcty] -type statefile_latency = Rrd.Statefile_latency.t = { id: string; latency: float option } -[@@deriving rpcty] +(* Note: for types such as rrd_req, which alias user-defined types, it is + usually not enough to add [@@deriving rpcty] to derive RPC types, and rpc + functions must be declared in the definition. -type sflat_lst = statefile_latency list -[@@deriving rpcty] + However, types such as Rrd.sampling_frequency have already been defined as + RPC types in their original declarations so we are able to derive these + type aliases like so *) -(** Domain database sampling info *) -type interdomain_info = - { frequency : rrd_freq; (** interdomain rrd sampling frequency *) - shared_page_refs : int list (** list of shared page references *) - } [@@deriving rpcty] +type rrd_freq = Rrd.sampling_frequency = Five_Seconds [@@deriving rpcty] -type string_opt = string option +type statefile_latency = Rrd.Statefile_latency.t = { + id: string + ; latency: float option +} [@@deriving rpcty] -type ds_list = Data_source.t list +type sflat_lst = statefile_latency list [@@deriving rpcty] + +(** Domain database sampling info *) +type interdomain_info = { + frequency: rrd_freq (** interdomain rrd sampling frequency *) + ; shared_page_refs: int list (** list of shared page references *) +} [@@deriving rpcty] +type string_opt = string option [@@deriving rpcty] + +type ds_list = Data_source.t list [@@deriving rpcty] (* -- error handling -- *) (** Rrdd error type *) type rrd_errors = - | Archive_failed of string (** Archival failure *) - | Invalid_protocol of string (** Thrown by protocol_of_string if - string does not match plugin protocol *) - | Rrdd_internal_error of string (** Internal Rrdd error *) + | Archive_failed of string (** Archival failure *) + | Invalid_protocol of string + (** Thrown by protocol_of_string if string does not match plugin protocol *) + | Rrdd_internal_error of string (** Internal Rrdd error *) [@@deriving rpcty] exception Rrdd_error of rrd_errors -let () = (* register printer *) +let () = + (* register printer *) let string_of_error e = - Rpcmarshal.marshal rrd_errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal rrd_errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | Rrdd_error e -> - Some (Printf.sprintf "Rrd_interface.Rrdd_error(%s)" (string_of_error e)) - | _ -> None in + Some (Printf.sprintf "Rrd_interface.Rrdd_error(%s)" (string_of_error e)) + | _ -> + None + in Printexc.register_printer printer (** Error handler *) -module RrdErrHandler = Error.Make(struct - type t = rrd_errors - let t = rrd_errors - let internal_error_of e = Some (Rrdd_internal_error (Printexc.to_string e)) - end) +module RrdErrHandler = Error.Make (struct + type t = rrd_errors + + let t = rrd_errors + + let internal_error_of e = Some (Rrdd_internal_error (Printexc.to_string e)) +end) + let rrd_err = RrdErrHandler.error -let string_of_protocol = function - | V1 -> "V1" - | V2 -> "V2" +let string_of_protocol = function V1 -> "V1" | V2 -> "V2" let protocol_of_string = function - | x when x="V1" -> V1 - | x when x="V2" -> V2 - | y -> raise (Rrdd_error (Invalid_protocol(y))) - + | x when x = "V1" -> + V1 + | x when x = "V2" -> + V2 + | y -> + raise (Rrdd_error (Invalid_protocol y)) (* -- RPC generation -- *) -module RPC_API(R : RPC) = struct +module RPC_API (R : RPC) = struct open R let description = - Interface.{ name = "Rrd" - ; namespace = None - ; description = - [ "This interface is used by Xapi and Rrdd to manage " - ; "round robin database sampling of dom0 databases. " ] - ; version=(1,0,0) - } + Interface. + { + name= "Rrd" + ; namespace= None + ; description= + [ + "This interface is used by Xapi and Rrdd to manage " + ; "round robin database sampling of dom0 databases. " + ] + ; version= (1, 0, 0) + } let implementation = implement description (** Common API call parameter definitions *) - let unit_p = Param.mk Types.unit + let unit_p = Param.mk Types.unit + let string_p = Param.mk Types.string - let float_p = Param.mk Types.float - let uuid_p = Param.mk ~name:"uuid" ~description:[ "User ID" ] Types.string - let vm_uuid_p = Param.mk ~name:"vm_uuid" ~description:[ "VM ID" ] Types.string - let domid_p = Param.mk ~name:"domid" ~description:[ "Domain ID of VM" ] Types.int - let sr_uuid_p = Param.mk ~name:"sr_uuid" ~description:[ "SR ID" ] Types.string - let ds_name_p = Param.mk ~name:"ds_name" ~description:[ "Domain server name" ] Types.string - let rem_add_p = Param.mk ~name:"remote_address" ~description:[ "Remote address" ] Types.string + let float_p = Param.mk Types.float + + let uuid_p = Param.mk ~name:"uuid" ~description:["User ID"] Types.string + + let vm_uuid_p = Param.mk ~name:"vm_uuid" ~description:["VM ID"] Types.string - let ds_list_p = Param.mk ~name:"data_source list" - ~description: [ "Datasource list" ] ds_list + let domid_p = + Param.mk ~name:"domid" ~description:["Domain ID of VM"] Types.int + + let sr_uuid_p = Param.mk ~name:"sr_uuid" ~description:["SR ID"] Types.string + + let ds_name_p = + Param.mk ~name:"ds_name" ~description:["Domain server name"] Types.string + + let rem_add_p = + Param.mk ~name:"remote_address" ~description:["Remote address"] Types.string + + let ds_list_p = + Param.mk ~name:"data_source list" ~description:["Datasource list"] ds_list (** API call definitions *) let has_vm_rrd = let bool_p = Param.mk Types.bool in declare "has_vm_rrd" - [ "Returns `true` if xcp-rrdd has an RRD for the specified VM in memory" ] - ( vm_uuid_p @-> returning bool_p rrd_err) - - let push_rrd_local = declare "push_rrd_local" - [ "Loads a VM RRD from local storage, associates it with the specified domid, and"; - "starts recording all data sources related to the VM to that RRD" ] - (vm_uuid_p @-> domid_p @-> returning unit_p rrd_err) - - let push_rrd_remote = declare "push_rrd_remote" - [ "Loads a VM RRD from local storage and pushes it to a remote host" ] - (vm_uuid_p @-> rem_add_p @-> returning unit_p rrd_err) - - let remove_rrd = declare "remove_rrd" - [ "Removes a VM RRD from the local filesystem, if it exists." ] - (uuid_p @-> returning unit_p rrd_err) + ["Returns `true` if xcp-rrdd has an RRD for the specified VM in memory"] + (vm_uuid_p @-> returning bool_p rrd_err) + + let push_rrd_local = + declare "push_rrd_local" + [ + "Loads a VM RRD from local storage, associates it with the specified \ + domid, and" + ; "starts recording all data sources related to the VM to that RRD" + ] + (vm_uuid_p @-> domid_p @-> returning unit_p rrd_err) + + let push_rrd_remote = + declare "push_rrd_remote" + ["Loads a VM RRD from local storage and pushes it to a remote host"] + (vm_uuid_p @-> rem_add_p @-> returning unit_p rrd_err) + + let remove_rrd = + declare "remove_rrd" + ["Removes a VM RRD from the local filesystem, if it exists."] + (uuid_p @-> returning unit_p rrd_err) let migrate_rrd = - let host_uuid_p = Param.mk ~name:"host_uuid" ~description:[ "Unique ID of host" ] Types.string in - let session_id_p = Param.mk ~name:"session_id" ~description:[ "ID of the session" ] string_opt in + let host_uuid_p = + Param.mk ~name:"host_uuid" ~description:["Unique ID of host"] Types.string + in + let session_id_p = + Param.mk ~name:"session_id" ~description:["ID of the session"] string_opt + in declare "migrate_rrd" - [ "Migrate_push - used by the migrate code to push an RRD directly to" + [ + "Migrate_push - used by the migrate code to push an RRD directly to" ; "a remote host without going via the master. If the host is on a" - ; "different pool, you must pass both the remote_address and session_id parameters."] + ; "different pool, you must pass both the remote_address and session_id \ + parameters." + ] (session_id_p - @-> rem_add_p - @-> vm_uuid_p - @-> host_uuid_p - @-> returning unit_p rrd_err) - + @-> rem_add_p + @-> vm_uuid_p + @-> host_uuid_p + @-> returning unit_p rrd_err + ) let send_host_rrd_to_master = - let mast_addr_str = Param.mk ~name:"master_address" ~description:[ "Address of remote" ] Types.string in + let mast_addr_str = + Param.mk ~name:"master_address" ~description:["Address of remote"] + Types.string + in declare "send_host_rrd_to_master" - [ "Called on host shutdown/reboot to send the Host RRD to the master for" - ; "backup." ] + [ + "Called on host shutdown/reboot to send the Host RRD to the master for" + ; "backup." + ] (mast_addr_str @-> returning unit_p rrd_err) - let rem_addr_opt_p = Param.mk ~name:"remote_address" ~description:[ "Address of the remote" ] string_opt - let backup_rrds = declare "backup_rrds" - [ "Backs up RRD data to disk. This should be done periodically to ensure" - ; "that if the host crashes we don't lose too much data." ] - (rem_addr_opt_p @-> unit_p @-> returning unit_p rrd_err) + let rem_addr_opt_p = + Param.mk ~name:"remote_address" ~description:["Address of the remote"] + string_opt - let archive_rrd = declare "archive_rrd" - [ "Sends the VM RRD either to local disk or the remote address if specified," - ; "and removes it from memory. Called on VM shutdown/suspend." ] - (vm_uuid_p @-> rem_addr_opt_p @-> returning unit_p rrd_err) + let backup_rrds = + declare "backup_rrds" + [ + "Backs up RRD data to disk. This should be done periodically to ensure" + ; "that if the host crashes we don't lose too much data." + ] + (rem_addr_opt_p @-> unit_p @-> returning unit_p rrd_err) - let archive_sr_rrd = declare "archive_sr_rrd" - [ "Saves the SR RRD to the local disk. Returns the path to the saved RRD so" - ; "it can be copied onto the SR before it is detached." ] - (sr_uuid_p @-> returning string_p rrd_err) + let archive_rrd = + declare "archive_rrd" + [ + "Sends the VM RRD either to local disk or the remote address if \ + specified," + ; "and removes it from memory. Called on VM shutdown/suspend." + ] + (vm_uuid_p @-> rem_addr_opt_p @-> returning unit_p rrd_err) + + let archive_sr_rrd = + declare "archive_sr_rrd" + [ + "Saves the SR RRD to the local disk. Returns the path to the saved RRD \ + so" + ; "it can be copied onto the SR before it is detached." + ] + (sr_uuid_p @-> returning string_p rrd_err) let push_sr_rrd = - let path_p = Param.mk ~name:"path" ~description:[ "Filepath" ] Types.string in + let path_p = Param.mk ~name:"path" ~description:["Filepath"] Types.string in declare "push_sr_rrd" - [ "Loads the RRD from the path specified on the local disk. Overwrites any" + [ + "Loads the RRD from the path specified on the local disk. Overwrites any" ; "RRD already in memory for the SR. Data sources will subsequently be " - ; "recorded to this RRD." ] + ; "recorded to this RRD." + ] (sr_uuid_p @-> path_p @-> returning unit_p rrd_err) - let add_host_ds = declare "add_host_ds" - [ "Adds a host data source to the host RRD. This causes the data source to be " - ; "recorded if it wasn't a default data source." ] - (ds_name_p @-> returning unit_p rrd_err) - - let forget_host_ds = declare "forget_host_ds" - [ "Forgets the recorded archives for the named data source. Note that if the " - ; "data source is marked as default, new data coming in will cause the archive" - ; "to be recreated." ] - (ds_name_p @-> returning unit_p rrd_err) + let add_host_ds = + declare "add_host_ds" + [ + "Adds a host data source to the host RRD. This causes the data source \ + to be " + ; "recorded if it wasn't a default data source." + ] + (ds_name_p @-> returning unit_p rrd_err) + + let forget_host_ds = + declare "forget_host_ds" + [ + "Forgets the recorded archives for the named data source. Note that if \ + the " + ; "data source is marked as default, new data coming in will cause the \ + archive" + ; "to be recreated." + ] + (ds_name_p @-> returning unit_p rrd_err) let query_possible_host_dss = declare "query_possible_host_dss" - [ "Returns list of possible host DSs. This will include data sources not " - ; "currently being recorded into archives." ] + [ + "Returns list of possible host DSs. This will include data sources not " + ; "currently being recorded into archives." + ] (unit_p @-> returning ds_list_p rrd_err) - let query_host_ds = declare "query_host_ds" - [ "Returns the current value of the named host data source. Note this returns" - ; " the raw data source value, not the smoothed last value of the RRA." ] + let query_host_ds = + declare "query_host_ds" + [ + "Returns the current value of the named host data source. Note this \ + returns" + ; " the raw data source value, not the smoothed last value of the RRA." + ] (ds_name_p @-> returning float_p rrd_err) - - let add_vm_ds = declare "add_vm_ds" - [ "Adds a VM data source to the VM RRD. This causes the data source to be" - ; " recorded if it wasn't a default data source." ] - (vm_uuid_p @-> domid_p @-> ds_name_p @-> returning unit_p rrd_err) - - let forget_vm_ds = declare "forget_vm_ds" - [ "Forgets the recorded archives for the named VM data source. Note that if the" - ; "data source is marked as default, new data coming in will cause the archive" - ; "to be recreated." ] - (vm_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) - - let query_possible_vm_dss = declare "query_possible_vm_dss" - [ "Returns list of possible VM DSs. This will include data sources not" - ; "currently being recorded into archives." ] - (vm_uuid_p @-> returning ds_list_p rrd_err) - - let query_vm_ds = declare "query_vm_ds" - [ "Returns the current value of the named VM data source. Note this returns" - ; "the raw data source value, not the smoothed last value of the RRA." ] - (vm_uuid_p @-> ds_name_p @-> returning float_p rrd_err) - - let add_sr_ds = declare "add_sr_ds" - [ "Adds an SR data source to the SR RRD. This causes the data source to be" - ; "recorded if it wasn't a default data source." ] - (sr_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) - - let forget_sr_ds = declare "forget_sr_ds" - [ "Forgets the recorded archives for the named SR data source. Note that if the" - ; "data source is marked as default, new data coming in will cause the archive" - ; "to be recreated." ] - (sr_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) - - let query_possible_sr_dss = declare "query_possible_sr_dss" - [ "Returns list of possible SR DSs. This will include data sources not" - ; "currently being recorded into archives." ] - (sr_uuid_p @-> returning ds_list_p rrd_err) - - let query_sr_ds = declare "query_sr_ds" - [ "Returns the current value of the named VM data source. Note this returns" - ; "the raw data source value, not the smoothed last value of the RRA." ] - (sr_uuid_p @-> ds_name_p @-> returning float_p rrd_err) + let add_vm_ds = + declare "add_vm_ds" + [ + "Adds a VM data source to the VM RRD. This causes the data source to be" + ; " recorded if it wasn't a default data source." + ] + (vm_uuid_p @-> domid_p @-> ds_name_p @-> returning unit_p rrd_err) + + let forget_vm_ds = + declare "forget_vm_ds" + [ + "Forgets the recorded archives for the named VM data source. Note that \ + if the" + ; "data source is marked as default, new data coming in will cause the \ + archive" + ; "to be recreated." + ] + (vm_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) + + let query_possible_vm_dss = + declare "query_possible_vm_dss" + [ + "Returns list of possible VM DSs. This will include data sources not" + ; "currently being recorded into archives." + ] + (vm_uuid_p @-> returning ds_list_p rrd_err) + + let query_vm_ds = + declare "query_vm_ds" + [ + "Returns the current value of the named VM data source. Note this \ + returns" + ; "the raw data source value, not the smoothed last value of the RRA." + ] + (vm_uuid_p @-> ds_name_p @-> returning float_p rrd_err) + + let add_sr_ds = + declare "add_sr_ds" + [ + "Adds an SR data source to the SR RRD. This causes the data source to be" + ; "recorded if it wasn't a default data source." + ] + (sr_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) + + let forget_sr_ds = + declare "forget_sr_ds" + [ + "Forgets the recorded archives for the named SR data source. Note that \ + if the" + ; "data source is marked as default, new data coming in will cause the \ + archive" + ; "to be recreated." + ] + (sr_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) + + let query_possible_sr_dss = + declare "query_possible_sr_dss" + [ + "Returns list of possible SR DSs. This will include data sources not" + ; "currently being recorded into archives." + ] + (sr_uuid_p @-> returning ds_list_p rrd_err) + + let query_sr_ds = + declare "query_sr_ds" + [ + "Returns the current value of the named VM data source. Note this \ + returns" + ; "the raw data source value, not the smoothed last value of the RRA." + ] + (sr_uuid_p @-> ds_name_p @-> returning float_p rrd_err) let update_use_min_max = - let value_p = Param.mk ~name:"value" ~description:[ "Value dictating whether to use min_max" ] Types.bool in + let value_p = + Param.mk ~name:"value" + ~description:["Value dictating whether to use min_max"] + Types.bool + in declare "update_use_min_max" - [ "Set the value of the `use_min_max` variable. If this is `true`, when creating" - ; "a new RRD, archives for the minimum and maximum observed values will be created" - ; "alongside the standard archive of average values" ] + [ + "Set the value of the `use_min_max` variable. If this is `true`, when \ + creating" + ; "a new RRD, archives for the minimum and maximum observed values will \ + be created" + ; "alongside the standard archive of average values" + ] (value_p @-> returning unit_p rrd_err) let update_vm_memory_target = - let target_p = Param.mk ~name:"target" ~description:[ "VM memory target" ] Types.int64 in + let target_p = + Param.mk ~name:"target" ~description:["VM memory target"] Types.int64 + in declare "update_vm_memory_target" - [ "Sets the `memory_target` value for a VM. This is called by xapi when it is told by" - ; "xenopsd that squeezed has changed the target for a VM." ] + [ + "Sets the `memory_target` value for a VM. This is called by xapi when \ + it is told by" + ; "xenopsd that squeezed has changed the target for a VM." + ] (domid_p @-> target_p @-> returning unit_p rrd_err) - let set_cache_sr = declare "set_cache_sr" - [ "Sets the uuid of the cache SR. If this is set, statistics about the usage of the cache" - ; "will be recorded into the host SR." ] - (sr_uuid_p @-> returning unit_p rrd_err) - - let unset_cache_sr = declare "unset_cache_sr" - [ "Unsets the cache_sr. No futher data will be gathered about cache usage, but existing" - ; "archive data will not be deleted." ] - (unit_p @-> returning unit_p rrd_err) - + let set_cache_sr = + declare "set_cache_sr" + [ + "Sets the uuid of the cache SR. If this is set, statistics about the \ + usage of the cache" + ; "will be recorded into the host SR." + ] + (sr_uuid_p @-> returning unit_p rrd_err) + + let unset_cache_sr = + declare "unset_cache_sr" + [ + "Unsets the cache_sr. No futher data will be gathered about cache \ + usage, but existing" + ; "archive data will not be deleted." + ] + (unit_p @-> returning unit_p rrd_err) module Plugin = struct - - let uid_p = Param.mk ~name:"uid" ~description:[ "Plugin UID" ] Types.string - let info_p = Param.mk ~name:"info" ~description:[ "Interdomain info" ] interdomain_info - let protocol_p = Param.mk ~name:"protocol" ~description:[ "Plugin protocol version" ] plugin_protocol - - let get_header = declare "Plugin.get_header" - [ "Returns header string. This string should be copied exactly to the start" - ; "of the shared memory containing the data source" ] + let uid_p = Param.mk ~name:"uid" ~description:["Plugin UID"] Types.string + + let info_p = + Param.mk ~name:"info" ~description:["Interdomain info"] interdomain_info + + let protocol_p = + Param.mk ~name:"protocol" + ~description:["Plugin protocol version"] + plugin_protocol + + let get_header = + declare "Plugin.get_header" + [ + "Returns header string. This string should be copied exactly to the \ + start" + ; "of the shared memory containing the data source" + ] (unit_p @-> returning string_p rrd_err) - let get_path = declare "Plugin.get_path" - [ "Returns path in the local filesystem to place the data" - ; "source file" ] + let get_path = + declare "Plugin.get_path" + [ + "Returns path in the local filesystem to place the data"; "source file" + ] (uid_p @-> returning string_p rrd_err) module Local = struct let register = - let info_p = Param.mk ~name:"info" ~description:[ "Local rrd info" ] rrd_freq in + let info_p = + Param.mk ~name:"info" ~description:["Local rrd info"] rrd_freq + in declare "Plugin.Local.register" - [ "[Plugin.Local.register uid info protocol] registers a plugin" + [ + "[Plugin.Local.register uid info protocol] registers a plugin" ; "as a source of a set of data-sources. [uid] is a unique identifier" ; "for the plugin, often the name of the plugin. [info] is the RRD" ; "frequency, and [protocol] specifies whether the plugin will be" - ; "using V1 or V2 of the protocol."] + ; "using V1 or V2 of the protocol." + ] (uid_p @-> info_p @-> protocol_p @-> returning float_p rrd_err) - let deregister = declare "Plugin.Local.deregister" - [ "Deregisters a plugin by uid" ] - (uid_p @-> returning unit_p rrd_err) - - let next_reading = declare "Plugin.Local.next_reading" - [ "Returns the number of seconds until the next reading will be taken." ] - (uid_p @-> returning float_p rrd_err) + let deregister = + declare "Plugin.Local.deregister" + ["Deregisters a plugin by uid"] + (uid_p @-> returning unit_p rrd_err) + + let next_reading = + declare "Plugin.Local.next_reading" + [ + "Returns the number of seconds until the next reading will be taken." + ] + (uid_p @-> returning float_p rrd_err) end module Interdomain = struct - - let iduid_p = Param.mk ~name:"uid" ~description:[ "Interdomain ID" ] interdomain_uid + let iduid_p = + Param.mk ~name:"uid" ~description:["Interdomain ID"] interdomain_uid let register = declare "Plugin.Interdomain.register" - [ "[Plugin.Interdomain.register uid info protocol] registers an" + [ + "[Plugin.Interdomain.register uid info protocol] registers an" ; "interdomain plugin. [uid] is the unique identifier of the" ; "plugin, containing both a name and the frontend domain id." ; "[info] contains both the desired sampling frequency and" ; "a list of the grant references of the shared pages. [protocol]" ; "is V1 or V2, and the return value is the time until the next" - ; "reading" ] + ; "reading" + ] (iduid_p @-> info_p @-> protocol_p @-> returning float_p rrd_err) - let deregister = declare "Plugin.Interdomain.deregister" - [ "Deregisters a plugin by uid." ] - (iduid_p @-> returning unit_p rrd_err) + let deregister = + declare "Plugin.Interdomain.deregister" + ["Deregisters a plugin by uid."] + (iduid_p @-> returning unit_p rrd_err) - let next_reading = declare "Plugin.Interdomain.next_reading" - [ "Returns the number of seconds before the next reading." ] - (iduid_p @-> returning float_p rrd_err) + let next_reading = + declare "Plugin.Interdomain.next_reading" + ["Returns the number of seconds before the next reading."] + (iduid_p @-> returning float_p rrd_err) end let register = - let freq_p = Param.mk ~name:"frequency" ~description:[ "Rrd database sampling frequency" ] rrd_freq in + let freq_p = + Param.mk ~name:"frequency" + ~description:["Rrd database sampling frequency"] + rrd_freq + in declare "Plugin.register" - [ "Preserved for backwards compatibility. Equivalent to a Local" - ; "plugin registration with V1 protocol." ] + [ + "Preserved for backwards compatibility. Equivalent to a Local" + ; "plugin registration with V1 protocol." + ] (uid_p @-> freq_p @-> returning float_p rrd_err) - let deregister = declare "Plugin.deregister" - [ "Preserved for backwards compatibility. Deregesters a local plugin." ] - (uid_p @-> returning unit_p rrd_err) + let deregister = + declare "Plugin.deregister" + ["Preserved for backwards compatibility. Deregesters a local plugin."] + (uid_p @-> returning unit_p rrd_err) - let next_reading = declare "Plugin.next_reading" - [ "Returns the time until the next reading." ] - (uid_p @-> returning float_p rrd_err) + let next_reading = + declare "Plugin.next_reading" + ["Returns the time until the next reading."] + (uid_p @-> returning float_p rrd_err) end (** High availability module *) module HA = struct - let enable_and_update = - let heartb_lat_p = Param.mk ~name:"heartbeat_latency" ~description:[ "Time taken for heartbeat signal to travel" ] Types.float in - let xapi_lat_p = Param.mk ~name:"xapi_latency" ~description:[ "Time taken for Xapi to respond" ] Types.float in - let stfile_lats_p = Param.mk ~name:"statefile_latencies" ~description:[ "Time taken for statefiles to update" ] sflat_lst in + let heartb_lat_p = + Param.mk ~name:"heartbeat_latency" + ~description:["Time taken for heartbeat signal to travel"] + Types.float + in + let xapi_lat_p = + Param.mk ~name:"xapi_latency" + ~description:["Time taken for Xapi to respond"] + Types.float + in + let stfile_lats_p = + Param.mk ~name:"statefile_latencies" + ~description:["Time taken for statefiles to update"] + sflat_lst + in declare "HA.enable_and_update" - [ "Enables the gathering of HA metrics, a built-in function of xcp-rrdd." ] - (stfile_lats_p @-> heartb_lat_p @-> xapi_lat_p @-> returning unit_p rrd_err) - - let disable = declare "HA.disable" - [ "Disables the HA metrics." ] - (unit_p @-> returning unit_p rrd_err) + [ + "Enables the gathering of HA metrics, a built-in function of xcp-rrdd." + ] + (stfile_lats_p + @-> heartb_lat_p + @-> xapi_lat_p + @-> returning unit_p rrd_err + ) + + let disable = + declare "HA.disable" + ["Disables the HA metrics."] + (unit_p @-> returning unit_p rrd_err) end module Deprecated = struct - let load_rrd = - let timescale_int_p = Param.mk ~name:"timescale" ~description:[ "Speed of round-robin database loading" ] Types.int in - let mast_addr_opt_p = Param.mk ~name:"master address" ~description:[ "Master address to load rrd from" ] string_opt in - declare "Deprecated.load_rrd" - [ "Deprecated call." ] + let timescale_int_p = + Param.mk ~name:"timescale" + ~description:["Speed of round-robin database loading"] + Types.int + in + let mast_addr_opt_p = + Param.mk ~name:"master address" + ~description:["Master address to load rrd from"] + string_opt + in + declare "Deprecated.load_rrd" ["Deprecated call."] (uuid_p - @-> timescale_int_p - @-> mast_addr_opt_p - @-> returning unit_p rrd_err) + @-> timescale_int_p + @-> mast_addr_opt_p + @-> returning unit_p rrd_err + ) end end diff --git a/storage/dune b/storage/dune index 4706982d..855e79d5 100644 --- a/storage/dune +++ b/storage/dune @@ -1,76 +1,68 @@ (library - (name xcp_storage_interface_types) - (public_name xapi-idl.storage.interface.types) - (flags (:standard -w -39)) - (modules vdi_automaton) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc)) -) + (name xcp_storage_interface_types) + (public_name xapi-idl.storage.interface.types) + (flags (:standard -w -39)) + (modules vdi_automaton) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) (library - (name xcp_storage_interface) - (public_name xapi-idl.storage.interface) - (flags (:standard -w -39)) - (modules storage_interface) - (libraries - astring - rpclib.core - threads - xapi-stdext-date - xapi-idl - xapi-idl.storage.interface.types - ) - (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc)) -) + (name xcp_storage_interface) + (public_name xapi-idl.storage.interface) + (flags (:standard -w -39)) + (modules storage_interface) + (libraries + astring + rpclib.core + threads + xapi-stdext-date + xapi-idl + xapi-idl.storage.interface.types + ) + (wrapped false) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) (library - (name xcp_storage) - (public_name xapi-idl.storage) - (flags (:standard -w -39)) - (modules (:standard \ storage_interface storage_test vdi_automaton suite vdi_automaton_test)) - (libraries - rpclib.core - threads - xapi-stdext-date - xapi-idl - xapi-idl.storage.interface - ) - (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc)) -) + (name xcp_storage) + (public_name xapi-idl.storage) + (flags (:standard -w -39)) + (modules + (:standard \ storage_interface storage_test vdi_automaton suite + vdi_automaton_test)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.storage.interface + xapi-stdext-date + ) + (wrapped false) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) (executable - (name storage_test) - (flags (:standard -w -39)) - (modules storage_test) - (libraries - cmdliner - alcotest - xapi-idl - xapi-idl.storage - ) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc)) -) + (name storage_test) + (flags (:standard -w -39)) + (modules storage_test) + (libraries + alcotest + cmdliner + xapi-idl + xapi-idl.storage + ) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) -(executable - (name suite) - (flags (:standard -w -39)) - (modules suite vdi_automaton_test) - (libraries - alcotest - xapi-idl.storage.interface - xapi-idl.storage.interface.types - ) -) - -(alias - (name runtest) - (deps (:x suite.exe) storage_test.exe) - (action (run %{x})) -) +(test + (name suite) + (flags (:standard -w -39)) + (modules suite vdi_automaton_test) + (libraries + alcotest + xapi-idl.storage.interface + xapi-idl.storage.interface.types + ) + (deps storage_test.exe)) diff --git a/storage/storage_client.ml b/storage/storage_client.ml index 3fdf330f..7bf40378 100644 --- a/storage/storage_client.ml +++ b/storage/storage_client.ml @@ -16,28 +16,21 @@ open Storage_interface open Xcp_client let rec retry_econnrefused f = - try - f () - with - | Unix.Unix_error(Unix.ECONNREFUSED, "connect", _) -> + try f () with + | Unix.Unix_error (Unix.ECONNREFUSED, "connect", _) -> (* debug "Caught ECONNREFUSED; retrying in 5s"; *) - Thread.delay 5.; - retry_econnrefused f + Thread.delay 5. ; retry_econnrefused f | e -> - (* error "Caught %s: does the storage service need restarting?" (Printexc.to_string e); *) + (* error "Caught %s: does the storage service need restarting?" + (Printexc.to_string e); *) raise e -module Client = Storage_interface.StorageAPI(Idl.Exn.GenClient(struct +module Client = Storage_interface.StorageAPI (Idl.Exn.GenClient (struct let rpc call = - retry_econnrefused - (fun () -> - if !use_switch - then json_switch_rpc !queue_name call - else xml_http_rpc - ~srcstr:(get_user_agent ()) - ~dststr:"storage" - Storage_interface.uri - call - ) + retry_econnrefused (fun () -> + if !use_switch then + json_switch_rpc !queue_name call + else + xml_http_rpc ~srcstr:(get_user_agent ()) ~dststr:"storage" + Storage_interface.uri call) end)) - diff --git a/storage/storage_interface.ml b/storage/storage_interface.ml index 4d2ce17a..6762b3e5 100644 --- a/storage/storage_interface.ml +++ b/storage/storage_interface.ml @@ -11,15 +11,14 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** - * @group Storage -*) + +(** @group Storage *) + open Rpc open Idl -module D = Debug.Make (struct - let name = "storage_interface" - end) +module D = Debug.Make (struct let name = "storage_interface" end) + open D type rpc_t = Rpc.t @@ -27,101 +26,130 @@ type rpc_t = Rpc.t let typ_of_rpc_t = let open Types in Abstract - { aname= "Rpc.t" + { + aname= "Rpc.t" ; test_data= [Null] ; rpc_of= (fun x -> x) - ; of_rpc= (fun x -> Ok x) } - - + ; of_rpc= (fun x -> Ok x) + } module TypeCombinators = struct - let option ?name ?(description= []) d = + let option ?name ?(description = []) d = let open Rpc.Types in let name = match name with Some n -> n | None -> Printf.sprintf "%s option" d.name in {name; description; ty= Option d.ty} - let list ?name ?(description= []) d = + let list ?name ?(description = []) d = let open Rpc.Types in let name = match name with - | Some n -> n - | None -> Printf.sprintf "list of %ss" d.name + | Some n -> + n + | None -> + Printf.sprintf "list of %ss" d.name in {name; description; ty= List d.ty} - let pair ?name ?(description= []) (p1, p2) = + let pair ?name ?(description = []) (p1, p2) = let open Rpc.Types in let name = match name with - | Some n -> n - | None -> Printf.sprintf "pair of %s and %s" p1.name p2.name + | Some n -> + n + | None -> + Printf.sprintf "pair of %s and %s" p1.name p2.name in {name; description; ty= Tuple (p1.ty, p2.ty)} - let triple ?name ?(description= []) (p1, p2, p3) = + let triple ?name ?(description = []) (p1, p2, p3) = let open Rpc.Types in let name = match name with - | Some n -> n + | Some n -> + n | None -> - Printf.sprintf "triple of %s, %s and %s" p1.name p2.name p3.name + Printf.sprintf "triple of %s, %s and %s" p1.name p2.name p3.name in {name; description; ty= Tuple3 (p1.ty, p2.ty, p3.ty)} end -let service_name="storage" +let service_name = "storage" + let queue_name = ref (Xcp_service.common_prefix ^ service_name) let default_sockets_dir = "/var/lib/xcp" + let default_path = ref (Filename.concat default_sockets_dir service_name) -let set_sockets_dir x = - default_path := Filename.concat x service_name +let set_sockets_dir x = default_path := Filename.concat x service_name let uri () = "file:" ^ !default_path let rpc_of t x = Rpcmarshal.marshal t.Rpc.Types.ty x -let of_rpc t x = match Rpcmarshal.unmarshal t.Rpc.Types.ty x with | Ok y -> y | Error (`Msg m) -> failwith (Printf.sprintf "Error unmarshalling type %s: %s" t.Rpc.Types.name m) + +let of_rpc t x = + match Rpcmarshal.unmarshal t.Rpc.Types.ty x with + | Ok y -> + y + | Error (`Msg m) -> + failwith + (Printf.sprintf "Error unmarshalling type %s: %s" t.Rpc.Types.name m) (** Primary key identifying the SR *) module type WRAPPEDSTRING = sig type t + val typ_of : t Rpc.Types.typ + val t : t Rpc.Types.def + val string_of : t -> string + val of_string : string -> t end module Sr : WRAPPEDSTRING = struct type t = string [@@deriving rpcty] + let string_of x = x + let of_string x = x end type sr = Sr.t -let sr_pp : Format.formatter -> sr -> unit = fun ppf sr -> Format.fprintf ppf "%s" (Sr.string_of sr) + +let sr_pp : Format.formatter -> sr -> unit = + fun ppf sr -> Format.fprintf ppf "%s" (Sr.string_of sr) (** Primary key identifying a VDI within an SR *) module Vdi : WRAPPEDSTRING = struct type t = string [@@deriving rpcty] + let string_of x = x + let of_string x = x end type vdi = Vdi.t -let vdi_pp : Format.formatter -> vdi -> unit = fun ppf vdi -> Format.fprintf ppf "%s" (Vdi.string_of vdi) + +let vdi_pp : Format.formatter -> vdi -> unit = + fun ppf vdi -> Format.fprintf ppf "%s" (Vdi.string_of vdi) module Vm : WRAPPEDSTRING = struct (* This is the domid. *) type t = string [@@deriving rpcty] + let string_of x = x + let of_string x = x end type vm = Vm.t -let vm_pp : Format.formatter -> vm -> unit = fun ppf vm -> Format.fprintf ppf "%s" (Vm.string_of vm) + +let vm_pp : Format.formatter -> vm -> unit = + fun ppf vm -> Format.fprintf ppf "%s" (Vm.string_of vm) (** Opaque identifier used by the client to identify a particular operation *) type debug_info = string [@@deriving rpcty] @@ -129,152 +157,156 @@ type debug_info = string [@@deriving rpcty] (** The result of a successful call to the deprecated VDI.attach: this information (eg) can be used to connect a VBD backend to a VBD frontend *) type attach_info = { - params : string; - o_direct: bool; - o_direct_reason : string; - xenstore_data : (string * string) list; -} [@@deriving rpcty] + params: string + ; o_direct: bool + ; o_direct_reason: string + ; xenstore_data: (string * string) list +} +[@@deriving rpcty] type xendisk = { - params: string; (** Put into the "params" key in xenstore *) - - extra: (string * string) list; - (** Key-value pairs to be put into the "extra" subdirectory underneath the - xenstore backend *) - - backend_type: string; -} [@@deriving rpcty] - -type block_device = { - path: string; (** Path to the block device *) -} [@@deriving rpcty] - + params: string (** Put into the "params" key in xenstore *) + ; extra: (string * string) list + (** Key-value pairs to be put into the "extra" subdirectory underneath + the xenstore backend *) + ; backend_type: string +} +[@@deriving rpcty] -type file = { - path: string; (** Path to the raw file *) -} [@@deriving rpcty] +type block_device = {path: string (** Path to the block device *)} +[@@deriving rpcty] +type file = {path: string (** Path to the raw file *)} [@@deriving rpcty] type nbd = { - uri: string; - (** NBD URI of the form nbd:unix::exportname= (this - format is used by qemu-system: - https://manpages.debian.org/stretch/qemu-system-x86/qemu-system-x86_64.1.en.html) *) -} [@@deriving rpcty] - + uri: string + (** NBD URI of the form nbd:unix::exportname= (this + format is used by qemu-system: + https://manpages.debian.org/stretch/qemu-system-x86/qemu-system-x86_64.1.en.html) *) +} +[@@deriving rpcty] type implementation = | XenDisk of xendisk | BlockDevice of block_device | File of file - | Nbd of nbd [@@deriving rpcty] - -type backend = { - implementations: implementation list; -} [@@deriving rpcty] + | Nbd of nbd +[@@deriving rpcty] +type backend = {implementations: implementation list} [@@deriving rpcty] (** Extracts the UNIX domain socket path and the export name from the NBD URI in - the NBD information returned from the VDI.attach2 SMAPIv2 call. - This has the format nbd:unix::exportname= *) + the NBD information returned from the VDI.attach2 SMAPIv2 call. This has the + format nbd:unix::exportname= *) let parse_nbd_uri nbd = - let { uri } = nbd in + let {uri} = nbd in let fail () = - failwith ("Could not parse NBD URI returned from the storage backend: " ^ uri) + failwith + ("Could not parse NBD URI returned from the storage backend: " ^ uri) in match String.split_on_char ':' uri with - | ["nbd"; "unix"; socket; exportname] -> begin + | ["nbd"; "unix"; socket; exportname] -> ( let prefix = "exportname=" in - if not (Astring.String.is_prefix ~affix:prefix exportname) then fail (); + if not (Astring.String.is_prefix ~affix:prefix exportname) then fail () ; match Astring.String.cuts ~empty:false ~sep:prefix exportname with | [exportname] -> - (socket, exportname) - | _ -> fail () - end - | _ -> fail () + (socket, exportname) + | _ -> + fail () + ) + | _ -> + fail () -(** Separates the implementations of the given backend returned from - the VDI.attach2 SMAPIv2 call based on their type *) +(** Separates the implementations of the given backend returned from the + VDI.attach2 SMAPIv2 call based on their type *) let implementations_of_backend backend = List.fold_left (fun (xendisks, blockdevices, files, nbds) implementation -> - match implementation with - | XenDisk xendisk -> (xendisk::xendisks, blockdevices, files, nbds) - | BlockDevice blockdevice -> (xendisks, blockdevice::blockdevices, files, nbds) - | File file -> (xendisks, blockdevices, file::files, nbds) - | Nbd nbd -> (xendisks, blockdevices, files, nbd::nbds) - ) - ([], [], [], []) - backend.implementations + match implementation with + | XenDisk xendisk -> + (xendisk :: xendisks, blockdevices, files, nbds) + | BlockDevice blockdevice -> + (xendisks, blockdevice :: blockdevices, files, nbds) + | File file -> + (xendisks, blockdevices, file :: files, nbds) + | Nbd nbd -> + (xendisks, blockdevices, files, nbd :: nbds)) + ([], [], [], []) backend.implementations (** Uniquely identifies the contents of a VDI *) type content_id = string [@@deriving rpcty] - (** The result of an operation which creates or examines a VDI *) type vdi_info = { - vdi: Vdi.t; - uuid: string option [@default None]; - content_id: content_id [@default ""]; - name_label: string; - name_description: string [@default ""]; - ty: string [@default "user"]; - (* sm_config: workaround via XenAPI *) - metadata_of_pool: string [@default ""]; - is_a_snapshot: bool [@default false]; - snapshot_time: string [@default Xapi_stdext_date.Date.to_string Xapi_stdext_date.Date.never]; - snapshot_of: Vdi.t [@default (Vdi.of_string "")]; - (* managed: workaround via XenAPI *) - read_only: bool [@default false]; - cbt_enabled: bool [@default false]; - (* missing: workaround via XenAPI *) - virtual_size: int64 [@default 0L]; - physical_utilisation: int64 [@default 0L]; - (* xenstore_data: workaround via XenAPI *) - persistent: bool [@default true]; - sharable: bool [@default false]; - sm_config: (string * string) list [@default []]; -} [@@deriving rpcty] + vdi: Vdi.t + ; uuid: string option [@default None] + ; content_id: content_id [@default ""] + ; name_label: string + ; name_description: string [@default ""] + ; ty: string [@default "user"] + ; (* sm_config: workaround via XenAPI *) + metadata_of_pool: string [@default ""] + ; is_a_snapshot: bool [@default false] + ; snapshot_time: string + [@default Xapi_stdext_date.Date.to_string Xapi_stdext_date.Date.never] + ; snapshot_of: Vdi.t [@default Vdi.of_string ""] + ; (* managed: workaround via XenAPI *) + read_only: bool [@default false] + ; cbt_enabled: bool [@default false] + ; (* missing: workaround via XenAPI *) + virtual_size: int64 [@default 0L] + ; physical_utilisation: int64 [@default 0L] + ; (* xenstore_data: workaround via XenAPI *) + persistent: bool [@default true] + ; sharable: bool [@default false] + ; sm_config: (string * string) list [@default []] +} +[@@deriving rpcty] let default_vdi_info = match - Rpcmarshal.unmarshal - vdi_info.Rpc.Types.ty - Rpc.(Dict ["vdi",String ""; - "name_label",String "default"]) + Rpcmarshal.unmarshal vdi_info.Rpc.Types.ty + Rpc.(Dict [("vdi", String ""); ("name_label", String "default")]) with - | Ok x -> x | Error (`Msg m) -> failwith (Printf.sprintf "Error creating default_vdi_info: %s" m) + | Ok x -> + x + | Error (`Msg m) -> + failwith (Printf.sprintf "Error creating default_vdi_info: %s" m) type sr_health = Healthy | Recovering [@@deriving rpcty] type sr_info = { - sr_uuid: string option; - name_label: string; - name_description: string; - total_space: int64; (** total number of bytes on the storage substrate *) - free_space: int64; (** current free space on the storage substrate *) - clustered: bool; - health: sr_health; -} [@@deriving rpcty] - -let string_of_vdi_info (x: vdi_info) = Jsonrpc.to_string (rpc_of vdi_info x) - -(** Each VDI is associated with one or more "attached" or "activated" "datapaths". *) + sr_uuid: string option + ; name_label: string + ; name_description: string + ; total_space: int64 (** total number of bytes on the storage substrate *) + ; free_space: int64 (** current free space on the storage substrate *) + ; clustered: bool + ; health: sr_health +} +[@@deriving rpcty] + +let string_of_vdi_info (x : vdi_info) = Jsonrpc.to_string (rpc_of vdi_info x) + +(** Each VDI is associated with one or more "attached" or "activated" + "datapaths". *) type dp = string [@@deriving rpcty] type dp_stat_t = { - superstate: Vdi_automaton.state; - dps: (string * Vdi_automaton.state) list; -} [@@deriving rpcty] + superstate: Vdi_automaton.state + ; dps: (string * Vdi_automaton.state) list +} +[@@deriving rpcty] -let string_of_dp_stat_t (x: dp_stat_t) = Jsonrpc.to_string (rpc_of dp_stat_t x) +let string_of_dp_stat_t (x : dp_stat_t) = Jsonrpc.to_string (rpc_of dp_stat_t x) type probe = { - configuration: (string * string) list; - complete: bool; - sr: sr_info option; - extra_info: (string * string) list; -} [@@deriving rpcty] + configuration: (string * string) list + ; complete: bool + ; sr: sr_info option + ; extra_info: (string * string) list +} +[@@deriving rpcty] type probe_result = | Raw of string (* SMAPIv1 adapters return arbitrary data *) @@ -284,77 +316,55 @@ type probe_result = module Mirror = struct type id = string [@@deriving rpcty] - type state = - | Receiving - | Sending - | Copying - [@@deriving rpcty] + type state = Receiving | Sending | Copying [@@deriving rpcty] - type t = { - source_vdi : Vdi.t; - dest_vdi : Vdi.t; - state : state list; - failed : bool; - } [@@deriving rpcty] + type t = {source_vdi: Vdi.t; dest_vdi: Vdi.t; state: state list; failed: bool} + [@@deriving rpcty] type mirror_receive_result_vhd_t = { - mirror_vdi : vdi_info; - mirror_datapath : dp; - copy_diffs_from : content_id option; - copy_diffs_to : Vdi.t; - dummy_vdi : Vdi.t; - } [@@deriving rpcty] - - type mirror_receive_result = - | Vhd_mirror of mirror_receive_result_vhd_t + mirror_vdi: vdi_info + ; mirror_datapath: dp + ; copy_diffs_from: content_id option + ; copy_diffs_to: Vdi.t + ; dummy_vdi: Vdi.t + } + [@@deriving rpcty] + + type mirror_receive_result = Vhd_mirror of mirror_receive_result_vhd_t [@@deriving rpcty] type similars = content_id list [@@deriving rpcty] end -type async_result_t = - | Vdi_info of vdi_info - | Mirror_id of Mirror.id +type async_result_t = Vdi_info of vdi_info | Mirror_id of Mirror.id [@@deriving rpcty] - - module Task = struct - type id = string - [@@deriving rpcty] + type id = string [@@deriving rpcty] - type async_result = async_result_t - [@@deriving rpcty] + type async_result = async_result_t [@@deriving rpcty] - type completion_t = { - duration : float; - result : async_result option - } [@@deriving rpcty] + type completion_t = {duration: float; result: async_result option} + [@@deriving rpcty] - type state = - | Pending of float - | Completed of completion_t - | Failed of rpc_t + type state = Pending of float | Completed of completion_t | Failed of rpc_t [@@deriving rpcty] type t = { - id: id; - dbg: string; - ctime: float; - state: state; - subtasks: (string * state) list; - debug_info: (string * string) list; - backtrace: string; - cancellable: bool [@default false]; - } [@@deriving rpcty] + id: id + ; dbg: string + ; ctime: float + ; state: state + ; subtasks: (string * state) list + ; debug_info: (string * string) list + ; backtrace: string + ; cancellable: bool [@default false] + } + [@@deriving rpcty] end module Dynamic = struct - type id = - | Task of Task.id - | Vdi of Vdi.t - | Dp of dp - | Mirror of Mirror.id + type id = Task of Task.id | Vdi of Vdi.t | Dp of dp | Mirror of Mirror.id [@@deriving rpcty] type t = @@ -371,11 +381,15 @@ type uuid = string [@@deriving rpcty] module Errors = struct type error = - | Backend_error_with_backtrace of (string * (string list)) (** name * params *) - | Sr_not_attached of string (** error: SR must be attached to access VDIs *) - | Vdi_does_not_exist of string (** error: the VDI is unknown *) - | Illegal_transition of (Vdi_automaton.state * Vdi_automaton.state) (** This operation implies an illegal state transition *) - | Backend_error of (string * (string list)) (** error: of the form SR_BACKEND_FAILURE *) + | Backend_error_with_backtrace of (string * string list) + (** name * params *) + | Sr_not_attached of string + (** error: SR must be attached to access VDIs *) + | Vdi_does_not_exist of string (** error: the VDI is unknown *) + | Illegal_transition of (Vdi_automaton.state * Vdi_automaton.state) + (** This operation implies an illegal state transition *) + | Backend_error of (string * string list) + (** error: of the form SR_BACKEND_FAILURE *) | Does_not_exist of (string * string) | Cancelled of string | Redirect of string option @@ -387,7 +401,8 @@ module Errors = struct | Content_ids_do_not_match of (string * string) | Missing_configuration_parameter of string | Internal_error of string - | Unknown_error [@@default Unknown_error] [@@deriving rpcty] + | Unknown_error + [@@default Unknown_error] [@@deriving rpcty] end exception Storage_error of Errors.error @@ -400,80 +415,101 @@ let () = in let printer = function | Storage_error e -> - Some - (sprintf "Storage_error (%s)" (string_of_error e)) - | _ -> None + Some (sprintf "Storage_error (%s)" (string_of_error e)) + | _ -> + None in Printexc.register_printer printer let err = let open Idl.Error in - { def= Errors.error + { + def= Errors.error ; raiser= (fun e -> - let exn = Storage_error e in - error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - raise exn ) + let exn = Storage_error e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) ; matcher= (function - | Storage_error e as exn -> + | Storage_error e as exn -> error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> + | exn -> error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - Some (Internal_error (Printexc.to_string exn))) } + Some (Internal_error (Printexc.to_string exn))) + } type query_result = { - driver: string; - name: string; - description: string; - vendor: string; - copyright: string; - version: string; - required_api_version: string; - features: string list; - configuration: (string * string) list; - required_cluster_stack: string list; -} [@@deriving rpcty] + driver: string + ; name: string + ; description: string + ; vendor: string + ; copyright: string + ; version: string + ; required_api_version: string + ; features: string list + ; configuration: (string * string) list + ; required_cluster_stack: string list +} +[@@deriving rpcty] module StorageAPI (R : RPC) = struct open R let description = let open Interface in - { name= "Storage" + { + name= "Storage" ; namespace= None - ; description= ["This interface is used by xapi to talk to the storage backends"] - ; version= (1, 0, 0) } + ; description= + ["This interface is used by xapi to talk to the storage backends"] + ; version= (1, 0, 0) + } let implementation = implement description let dbg_p = Param.mk ~name:"dbg" debug_info + let unit_p = Param.mk ~name:"unit" Types.unit + let sr_p = Param.mk ~name:"sr" Sr.t + let vdi_p = Param.mk ~name:"vdi" Vdi.t + let vm_p = Param.mk ~name:"vm" Vm.t + let dp_p = Param.mk ~name:"dp" dp - let device_config_p = Param.mk ~name:"device_config" ~description: - ["Backend-specific keys to specify the storage for the SR"] - TypeCombinators.(list (pair (Types.string,Types.string))) - let sm_config_p = Param.mk ~name:"sm_config" ~description: - ["Backend-private key-value pairs"] - TypeCombinators.(list (pair (Types.string,Types.string))) + + let device_config_p = + Param.mk ~name:"device_config" + ~description:["Backend-specific keys to specify the storage for the SR"] + TypeCombinators.(list (pair (Types.string, Types.string))) + + let sm_config_p = + Param.mk ~name:"sm_config" + ~description:["Backend-private key-value pairs"] + TypeCombinators.(list (pair (Types.string, Types.string))) + let new_name_label_p = Param.mk ~name:"new_name_label" Types.string - let new_name_description_p = Param.mk ~name:"new_name_description" Types.string + let new_name_description_p = + Param.mk ~name:"new_name_description" Types.string module Query = struct (** [query ()] returns information about this storage driver *) let query = let query_result_p = Param.mk ~name:"query_result" query_result in - declare "Query.query" ["Query the SM backend"] (dbg_p @-> returning query_result_p err) + declare "Query.query" ["Query the SM backend"] + (dbg_p @-> returning query_result_p err) - (** [diagnostics ()] returns diagnostic information about this storage driver *) + (** [diagnostics ()] returns diagnostic information about this storage + driver *) let diagnostics = let result_p = Param.mk Types.string in - declare "Query.diagnostics" ["Get diagnostic info from the SM backend"] (dbg_p @-> returning result_p err) + declare "Query.diagnostics" + ["Get diagnostic info from the SM backend"] + (dbg_p @-> returning result_p err) end module DP = struct @@ -481,89 +517,123 @@ module StorageAPI (R : RPC) = struct let create = let id_p = Param.mk ~name:"id" Types.string in - declare - "DP.create" + declare "DP.create" ["[DP.create dbg id]: creates and returns a dp"] (dbg_p @-> id_p @-> returning dp_p err) let destroy = let allow_leak_p = Param.mk ~name:"allow_leak" Types.bool in - declare - "DP.destroy" - ["[DP.destroy dbg id]: frees any resources associated with [id] and destroys it."; - "This will typically do any needed VDI.detach, VDI.deactivate cleanup."] + declare "DP.destroy" + [ + "[DP.destroy dbg id]: frees any resources associated with [id] and \ + destroys it." + ; "This will typically do any needed VDI.detach, VDI.deactivate \ + cleanup." + ] (dbg_p @-> dp_p @-> allow_leak_p @-> returning unit_p err) - let attach_info = let backend_p = Param.mk ~name:"backend" backend in - declare - "DP.attach_info" - ["[DP.attach_info sr vdi dp]: returns the params of the dp (the return value of VDI.attach2)"] + declare "DP.attach_info" + [ + "[DP.attach_info sr vdi dp]: returns the params of the dp (the \ + return value of VDI.attach2)" + ] (dbg_p @-> sr_p @-> vdi_p @-> dp_p @-> returning backend_p err) (** *) let diagnostics = let diagnostics_p = Param.mk ~name:"diagnostics" Types.string in - declare - "DP.diagnostics" - ["[DP.diagnostics ()]: returns a printable set of diagnostic information,"; - "typically including lists of all registered datapaths and their allocated"; - "resources."] + declare "DP.diagnostics" + [ + "[DP.diagnostics ()]: returns a printable set of diagnostic \ + information," + ; "typically including lists of all registered datapaths and their \ + allocated" + ; "resources." + ] (unit_p @-> returning diagnostics_p err) let stat_vdi = let dp_stat_p = Param.mk ~name:"dp_stat" dp_stat_t in - declare "DP.stat_vdi" ["[DP.stat_vdi task sr vdi ()] returns the state of the given VDI from the point of view of each dp as well as the overall superstate."] (dbg_p @-> sr_p @-> vdi_p @-> unit_p @-> returning dp_stat_p err) + declare "DP.stat_vdi" + [ + "[DP.stat_vdi task sr vdi ()] returns the state of the given VDI \ + from the point of view of each dp as well as the overall \ + superstate." + ] + (dbg_p @-> sr_p @-> vdi_p @-> unit_p @-> returning dp_stat_p err) end module SR = struct (** Functions which manipulate SRs *) let create = - let name_label_p = Param.mk ~name:"name_label" ~description: - ["Human-readable name for the SR"] Types.string + let name_label_p = + Param.mk ~name:"name_label" + ~description:["Human-readable name for the SR"] + Types.string in - let name_description_p = Param.mk ~name:"name_description" ~description: - ["Human-readable description for the SR"] Types.string + let name_description_p = + Param.mk ~name:"name_description" + ~description:["Human-readable description for the SR"] + Types.string in let size_p = Param.mk ~name:"physical_size" Types.int64 in declare "SR.create" - ["[SR.create dbg sr name description device_config physical_size]: creates a fresh SR"] - (dbg_p @-> sr_p @-> name_label_p @-> name_description_p @-> device_config_p @-> size_p @-> returning device_config_p err) - + [ + "[SR.create dbg sr name description device_config physical_size]: \ + creates a fresh SR" + ] + (dbg_p + @-> sr_p + @-> name_label_p + @-> name_description_p + @-> device_config_p + @-> size_p + @-> returning device_config_p err + ) (** [set_name_label sr new_name_label] updates the name_label of SR [sr]. *) let set_name_label = - declare "SR.set_name_label" [] (dbg_p @-> sr_p @-> new_name_label_p @-> returning unit_p err) + declare "SR.set_name_label" [] + (dbg_p @-> sr_p @-> new_name_label_p @-> returning unit_p err) - (** [set_name_description sr new_name_description] updates the name_description of SR [sr]. *) + (** [set_name_description sr new_name_description] updates the + name_description of SR [sr]. *) let set_name_description = - declare "SR.set_name_description" [] (dbg_p @-> sr_p @-> new_name_description_p @-> returning unit_p err) + declare "SR.set_name_description" [] + (dbg_p @-> sr_p @-> new_name_description_p @-> returning unit_p err) - (** [probe dbg queue device_config sm_config] searches on the storage device for SRs of queue [queue] *) + (** [probe dbg queue device_config sm_config] searches on the storage device + for SRs of queue [queue] *) let probe = let queue_p = Param.mk ~name:"queue" Types.string in let probe_result_p = Param.mk ~name:"result" probe_result in - declare "SR.probe" [] (dbg_p @-> queue_p @-> device_config_p @-> sm_config_p @-> returning probe_result_p err) + declare "SR.probe" [] + (dbg_p + @-> queue_p + @-> device_config_p + @-> sm_config_p + @-> returning probe_result_p err + ) (** [attach task sr]: attaches the SR *) let attach = - declare "SR.attach" [] (dbg_p @-> sr_p @-> device_config_p @-> returning unit_p err) + declare "SR.attach" [] + (dbg_p @-> sr_p @-> device_config_p @-> returning unit_p err) - (** [detach task sr]: detaches the SR, first detaching and/or deactivating any - active VDIs. This may fail with Sr_not_attached, or any error from VDI.detach - or VDI.deactivate. *) - let detach = - declare "SR.detach" [] (dbg_p @-> sr_p @-> returning unit_p err) + (** [detach task sr]: detaches the SR, first detaching and/or deactivating + any active VDIs. This may fail with Sr_not_attached, or any error from + VDI.detach or VDI.deactivate. *) + let detach = declare "SR.detach" [] (dbg_p @-> sr_p @-> returning unit_p err) (** [reset task sr]: declares that the SR has been completely reset, e.g. by - rebooting the VM hosting the SR backend. *) - let reset = - declare "SR.reset" [] (dbg_p @-> sr_p @-> returning unit_p err) + rebooting the VM hosting the SR backend. *) + let reset = declare "SR.reset" [] (dbg_p @-> sr_p @-> returning unit_p err) - (** [destroy sr]: destroys (i.e. makes unattachable and unprobeable) the [sr], - first detaching and/or deactivating any active VDIs. This may fail with - Sr_not_attached, or any error from VDI.detach or VDI.deactivate. *) + (** [destroy sr]: destroys (i.e. makes unattachable and unprobeable) the + [sr], first detaching and/or deactivating any active VDIs. This may fail + with Sr_not_attached, or any error from VDI.detach or VDI.deactivate. *) let destroy = declare "SR.destroy" [] (dbg_p @-> sr_p @-> returning unit_p err) @@ -573,27 +643,47 @@ module StorageAPI (R : RPC) = struct let result = Param.mk ~name:"result" (list vdi_info) in declare "SR.scan" [] (dbg_p @-> sr_p @-> returning result err) - (** [update_snapshot_info_src sr vdi url dest dest_vdi snapshot_pairs] - * updates the fields is_a_snapshot, snapshot_time and snapshot_of for a - * list of snapshots on a remote SR. *) + (** [update_snapshot_info_src sr vdi url dest dest_vdi snapshot_pairs] * + updates the fields is_a_snapshot, snapshot_time and snapshot_of for a * + list of snapshots on a remote SR. *) let update_snapshot_info_src = let url_p = Param.mk ~name:"url" Types.string in let dest_p = Param.mk ~name:"dest" Sr.t in let dest_vdi_p = Param.mk ~name:"dest_vdi" Vdi.t in - let snapshot_pairs_p = Param.mk ~name:"snapshot_pairs" TypeCombinators.(list (pair (Vdi.t, Vdi.t))) in + let snapshot_pairs_p = + Param.mk ~name:"snapshot_pairs" + TypeCombinators.(list (pair (Vdi.t, Vdi.t))) + in declare "SR.update_snapshot_info_src" [] - (dbg_p @-> sr_p @-> vdi_p @-> url_p @-> dest_p @-> dest_vdi_p @-> snapshot_pairs_p @-> returning unit_p err) - - (** [update_snapshot_info_dest sr vdi dest src_vdi snapshot_pairs] - * updates the fields is_a_snapshot, snapshot_time and snapshot_of for a - * list of snapshots on a local SR. Typically, vdi will be a mirror of - * src_vdi, and for each item in snapshot_pairs the first will be a copy - * of the second. *) + (dbg_p + @-> sr_p + @-> vdi_p + @-> url_p + @-> dest_p + @-> dest_vdi_p + @-> snapshot_pairs_p + @-> returning unit_p err + ) + + (** [update_snapshot_info_dest sr vdi dest src_vdi snapshot_pairs] updates + the fields is_a_snapshot, snapshot_time and snapshot_of for a list of + snapshots on a local SR. Typically, vdi will be a mirror of src_vdi, + and for each item in snapshot_pairs the first will be a copy of the + second. *) let update_snapshot_info_dest = let src_vdi_p = Param.mk ~name:"src_vdi" vdi_info in - let snapshot_pairs_p = Param.mk ~name:"snapshot_pairs" TypeCombinators.(list (pair (Vdi.t, vdi_info))) in + let snapshot_pairs_p = + Param.mk ~name:"snapshot_pairs" + TypeCombinators.(list (pair (Vdi.t, vdi_info))) + in declare "SR.update_snapshot_info_dest" [] - (dbg_p @-> sr_p @-> vdi_p @-> src_vdi_p @-> snapshot_pairs_p @-> returning unit_p err) + (dbg_p + @-> sr_p + @-> vdi_p + @-> src_vdi_p + @-> snapshot_pairs_p + @-> returning unit_p err + ) (** [stat task sr] returns instantaneous SR-level statistics *) let stat = @@ -607,206 +697,315 @@ module StorageAPI (R : RPC) = struct end module VDI = struct - (** Functions which operate on particular VDIs. - These functions are all idempotent from the point of view of a given [dp]. *) + (** Functions which operate on particular VDIs. These functions are all + idempotent from the point of view of a given [dp]. *) let vdi_info_p = Param.mk ~name:"vdi_info" vdi_info - (** [create task sr vdi_info] creates a new VDI in [sr] using [vdi_info]. Some - fields in the [vdi_info] may be modified (e.g. rounded up), so the function - returns the vdi_info which was used. *) + (** [create task sr vdi_info] creates a new VDI in [sr] using [vdi_info]. + Some fields in the [vdi_info] may be modified (e.g. rounded up), so the + function returns the vdi_info which was used. *) let create = - declare "VDI.create" [] (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) + declare "VDI.create" [] + (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) - (** [set_name_label sr vdi new_name_label] updates the name_label of VDI [vdi] in SR [sr]. *) + (** [set_name_label sr vdi new_name_label] updates the name_label of VDI + [vdi] in SR [sr]. *) let set_name_label = - declare "VDI.set_name_label" [] (dbg_p @-> sr_p @-> vdi_p @-> new_name_label_p @-> returning unit_p err) + declare "VDI.set_name_label" [] + (dbg_p @-> sr_p @-> vdi_p @-> new_name_label_p @-> returning unit_p err) - (** [set_name_description sr vdi new_name_description] updates the name_description of VDI [vdi] in SR [sr]. *) + (** [set_name_description sr vdi new_name_description] updates the + name_description of VDI [vdi] in SR [sr]. *) let set_name_description = - declare "VDI.set_name_description" [] (dbg_p @-> sr_p @-> vdi_p @-> new_name_description_p @-> returning unit_p err) - - (** [snapshot task sr vdi_info] creates a new VDI which is a snapshot of [vdi_info] in [sr] *) + declare "VDI.set_name_description" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> new_name_description_p + @-> returning unit_p err + ) + + (** [snapshot task sr vdi_info] creates a new VDI which is a snapshot of + [vdi_info] in [sr] *) let snapshot = - declare "VDI.snapshot" [] (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) + declare "VDI.snapshot" [] + (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) - (** [clone task sr vdi_info] creates a new VDI which is a clone of [vdi_info] in [sr] *) + (** [clone task sr vdi_info] creates a new VDI which is a clone of + [vdi_info] in [sr] *) let clone = - declare "VDI.clone" [] (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) + declare "VDI.clone" [] + (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) - (** [resize task sr vdi new_size] makes a VDI's virtual_size at least [new_size] bytes. - The function returns the new virtual_size which may be bigger (but not less than) - requested. *) + (** [resize task sr vdi new_size] makes a VDI's virtual_size at least + [new_size] bytes. The function returns the new virtual_size which may be + bigger (but not less than) requested. *) let resize = let new_size_p = Param.mk ~name:"new_size" Types.int64 in - declare "VDI.resize" [] (dbg_p @-> sr_p @-> vdi_p @-> new_size_p @-> returning new_size_p err) + declare "VDI.resize" [] + (dbg_p @-> sr_p @-> vdi_p @-> new_size_p @-> returning new_size_p err) (** [destroy task sr vdi] removes [vdi] from [sr] *) let destroy = - declare "VDI.destroy" [] (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.destroy" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) (** [stat dbg sr vdi] returns information about VDI [vdi] in SR [sr] *) let stat = - declare "VDI.stat" [] (dbg_p @-> sr_p @-> vdi_p @-> returning vdi_info_p err) + declare "VDI.stat" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning vdi_info_p err) - (** [introduce dbg sr uuid sm_config location] checks that a VDI exists and returns info about it *) + (** [introduce dbg sr uuid sm_config location] checks that a VDI exists and + returns info about it *) let introduce = let uuid_p = Param.mk ~name:"uuid" Types.string in let location_p = Param.mk ~name:"location" Types.string in - declare "VDI.introduce" [] (dbg_p @-> sr_p @-> uuid_p @-> sm_config_p @-> location_p @-> returning vdi_info_p err) + declare "VDI.introduce" [] + (dbg_p + @-> sr_p + @-> uuid_p + @-> sm_config_p + @-> location_p + @-> returning vdi_info_p err + ) let persistent_p = Param.mk ~name:"persistent" Types.bool - (** [set_persistent dbg sr vdi persistent] sets [vdi]'s persistent flag to [persistent] *) + (** [set_persistent dbg sr vdi persistent] sets [vdi]'s persistent flag to + [persistent] *) let set_persistent = - declare "VDI.set_persistent" [] (dbg_p @-> sr_p @-> vdi_p @-> persistent_p @-> returning unit_p err) + declare "VDI.set_persistent" [] + (dbg_p @-> sr_p @-> vdi_p @-> persistent_p @-> returning unit_p err) - (** [epoch_begin sr vdi persistent] declares that [vdi] is about to be added to a starting/rebooting VM. - This is not called over suspend/resume or migrate. - If [persistent] is false, then changes to the disk will be erased when the VM shuts down. *) + (** [epoch_begin sr vdi persistent] declares that [vdi] is about to be added + to a starting/rebooting VM. This is not called over suspend/resume or + migrate. If [persistent] is false, then changes to the disk will be + erased when the VM shuts down. *) let epoch_begin = - declare "VDI.epoch_begin" [] (dbg_p @-> sr_p @-> vdi_p @-> vm_p @-> persistent_p @-> returning unit_p err) + declare "VDI.epoch_begin" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> vm_p + @-> persistent_p + @-> returning unit_p err + ) let read_write_p = Param.mk ~name:"read_write" Types.bool + (** [attach task dp sr vdi read_write] returns the [params] for a given - [vdi] in [sr] which can be written to if (but not necessarily only if) [read_write] - is true. - @deprecated This function is deprecated, and is only here to keep backward - compatibility with old xapis that call Remote.VDI.attach during SXM. - Use the attach3 function instead. *) + [vdi] in [sr] which can be written to if (but not necessarily only if) + [read_write] is true. @deprecated This function is deprecated, and is + only here to keep backward compatibility with old xapis that call + Remote.VDI.attach during SXM. Use the attach3 function instead. *) let attach = let attach_info_p = Param.mk ~name:"attach_info" attach_info in - declare "VDI.attach" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> read_write_p @-> returning attach_info_p err) + declare "VDI.attach" [] + (dbg_p + @-> dp_p + @-> sr_p + @-> vdi_p + @-> read_write_p + @-> returning attach_info_p err + ) (** [attach2 task dp sr vdi read_write] returns the [params] for a given - [vdi] in [sr] which can be written to if (but not necessarily only if) [read_write] - is true. - @deprecated This function is deprecated, and is only here to keep backward - compatibility with old xapis that call Remote.VDI.attach2 during SXM. - Use the attach3 function instead. *) + [vdi] in [sr] which can be written to if (but not necessarily only if) + [read_write] is true. @deprecated This function is deprecated, and is + only here to keep backward compatibility with old xapis that call + Remote.VDI.attach2 during SXM. Use the attach3 function instead. *) let attach2 = let backend_p = Param.mk ~name:"backend" backend in - declare "VDI.attach2" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> read_write_p @-> returning backend_p err) + declare "VDI.attach2" [] + (dbg_p + @-> dp_p + @-> sr_p + @-> vdi_p + @-> read_write_p + @-> returning backend_p err + ) (** [attach3 task dp sr vdi read_write] returns the [params] for a given - [vdi] in [sr] which can be written to if (but not necessarily only if) [read_write] - is true *) + [vdi] in [sr] which can be written to if (but not necessarily only if) + [read_write] is true *) let attach3 = let backend_p = Param.mk ~name:"backend" backend in - declare "VDI.attach3" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> read_write_p @-> returning backend_p err) + declare "VDI.attach3" [] + (dbg_p + @-> dp_p + @-> sr_p + @-> vdi_p + @-> vm_p + @-> read_write_p + @-> returning backend_p err + ) (** [activate task dp sr vdi] signals the desire to immediately use [vdi]. - This client must have called [attach] on the [vdi] first. - @deprecated This function is deprecated, and is only here to keep backward + This client must have called [attach] on the [vdi] first. @deprecated + This function is deprecated, and is only here to keep backward compatibility with old xapis that call Remote.VDI.activate during SXM. Use the activate3 function instead. *) let activate = - declare "VDI.activate" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.activate" [] + (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> returning unit_p err) (** [activate3 task dp sr vdi] signals the desire to immediately use [vdi]. - This client must have called [attach] on the [vdi] first. *) + This client must have called [attach] on the [vdi] first. *) let activate3 = - declare "VDI.activate3" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) + declare "VDI.activate3" [] + (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) - (** [deactivate task dp sr vdi] signals that this client has stopped reading (and writing) - [vdi]. *) + (** [deactivate task dp sr vdi] signals that this client has stopped reading + (and writing) [vdi]. *) let deactivate = - declare "VDI.deactivate" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) + declare "VDI.deactivate" [] + (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) - (** [detach task dp sr vdi] signals that this client no-longer needs the [attach_info] - to be valid. *) + (** [detach task dp sr vdi] signals that this client no-longer needs the + [attach_info] to be valid. *) let detach = - declare "VDI.detach" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) + declare "VDI.detach" [] + (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) - (** [epoch_end sr vdi] declares that [vdi] is about to be removed from a shutting down/rebooting VM. - This is not called over suspend/resume or migrate. *) + (** [epoch_end sr vdi] declares that [vdi] is about to be removed from a + shutting down/rebooting VM. This is not called over suspend/resume or + migrate. *) let epoch_end = - declare "VDI.epoch_end" [] (dbg_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) + declare "VDI.epoch_end" [] + (dbg_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) - (** [get_url task sr vdi] returns a URL suitable for accessing disk data directly. *) + (** [get_url task sr vdi] returns a URL suitable for accessing disk data + directly. *) let get_url = let result_p = Param.mk ~name:"url" Types.string in - declare "VDI.get_url" [] (dbg_p @-> sr_p @-> vdi_p @-> returning result_p err) + declare "VDI.get_url" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning result_p err) - (** [similar_content task sr vdi] returns a list of VDIs which have similar content to [vdi] *) + (** [similar_content task sr vdi] returns a list of VDIs which have similar + content to [vdi] *) let similar_content = let result = Param.mk ~name:"vdis" TypeCombinators.(list vdi_info) in - declare "VDI.similar_content" [] (dbg_p @-> sr_p @-> vdi_p @-> returning result err) + declare "VDI.similar_content" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning result err) (** [get_by_name task sr name] returns the vdi within [sr] with [name] *) let get_by_name = let name_p = Param.mk ~name:"name" Types.string in - declare "VDI.get_by_name" [] (dbg_p @-> sr_p @-> name_p @-> returning vdi_info_p err) + declare "VDI.get_by_name" [] + (dbg_p @-> sr_p @-> name_p @-> returning vdi_info_p err) - (** [set_content_id task sr vdi content_id] tells the storage backend that a VDI has an updated [content_id] *) + (** [set_content_id task sr vdi content_id] tells the storage backend that a + VDI has an updated [content_id] *) let set_content_id = let content_id_p = Param.mk ~name:"content_id" content_id in - declare "VDI.set_content_id" [] (dbg_p @-> sr_p @-> vdi_p @-> content_id_p @-> returning unit_p err) + declare "VDI.set_content_id" [] + (dbg_p @-> sr_p @-> vdi_p @-> content_id_p @-> returning unit_p err) - (** [compose task sr vdi1 vdi2] layers the updates from [vdi2] onto [vdi1], modifying [vdi2] *) + (** [compose task sr vdi1 vdi2] layers the updates from [vdi2] onto [vdi1], + modifying [vdi2] *) let compose = let vdi1_p = Param.mk ~name:"vdi1" Vdi.t in let vdi2_p = Param.mk ~name:"vdi2" Vdi.t in - declare "VDI.compose" [] (dbg_p @-> sr_p @-> vdi1_p @-> vdi2_p @-> returning unit_p err) + declare "VDI.compose" [] + (dbg_p @-> sr_p @-> vdi1_p @-> vdi2_p @-> returning unit_p err) let key_p = Param.mk ~name:"key" Types.string + let value_p = Param.mk ~name:"value" Types.string - (** [add_to_sm_config dbg sr vdi key value] associates [value] to the [key] in [vdi] sm-config *) + (** [add_to_sm_config dbg sr vdi key value] associates [value] to the [key] + in [vdi] sm-config *) let add_to_sm_config = - declare "VDI.add_to_sm_config" [] (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> value_p @-> returning unit_p err) + declare "VDI.add_to_sm_config" [] + (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> value_p @-> returning unit_p err) (** [remove_from_sm_config dbg sr vdi key] remove [key] from [vdi] sm-config *) let remove_from_sm_config = - declare "VDI.remove_from_sm_config" [] (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> returning unit_p err) + declare "VDI.remove_from_sm_config" [] + (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> returning unit_p err) (** [enable_cbt dbg sr vdi] enables changed block tracking for [vdi] *) let enable_cbt = - declare "VDI.enable_cbt" [] (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.enable_cbt" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) (** [disable_cbt dbg sr vdi] disables changed block tracking for [vdi] *) let disable_cbt = - declare "VDI.disable_cbt" [] (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.disable_cbt" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) - (** [data_destroy dbg sr vdi] deletes the data of the snapshot [vdi] without deleting its changed block tracking metadata *) + (** [data_destroy dbg sr vdi] deletes the data of the snapshot [vdi] without + deleting its changed block tracking metadata *) let data_destroy = - declare "VDI.data_destroy" [] (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.data_destroy" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) - (** [list_changed_blocks dbg sr vdi_from vdi_to] returns the blocks that have changed between [vdi_from] and [vdi_to] as a base64-encoded bitmap string *) + (** [list_changed_blocks dbg sr vdi_from vdi_to] returns the blocks that + have changed between [vdi_from] and [vdi_to] as a base64-encoded bitmap + string *) let list_changed_blocks = let vdi_from_p = Param.mk ~name:"vdi_from" Vdi.t in let vdi_to_p = Param.mk ~name:"vdi_tp" Vdi.t in let result_p = Param.mk ~name:"changed_blocks" Types.string in - declare "VDI.list_changed_blocks" [] (dbg_p @-> sr_p @-> vdi_from_p @-> vdi_to_p @-> returning result_p err) - + declare "VDI.list_changed_blocks" [] + (dbg_p @-> sr_p @-> vdi_from_p @-> vdi_to_p @-> returning result_p err) end (** [get_by_name task name] returns a vdi with [name] (which may be in any SR) *) let get_by_name = let name_p = Param.mk ~name:"name" Types.string in - let result_p = Param.mk ~name:"result" TypeCombinators.(pair (Sr.t, vdi_info)) in + let result_p = + Param.mk ~name:"result" TypeCombinators.(pair (Sr.t, vdi_info)) + in declare "get_by_name" [] (dbg_p @-> name_p @-> returning result_p err) module DATA = struct - let url_p = Param.mk ~name:"url" Types.string + let dest_p = Param.mk ~name:"dest" Sr.t + let task_id_p = Param.mk ~name:"task_id" Task.id - (** [copy_into task sr vdi url sr2] copies the data from [vdi] into a remote system [url]'s [sr2] *) + (** [copy_into task sr vdi url sr2] copies the data from [vdi] into a remote + system [url]'s [sr2] *) let copy_into = let dest_vdi_p = Param.mk ~name:"dest_vdi" Vdi.t in - declare "DATA.copy_into" [] (dbg_p @-> sr_p @-> vdi_p @-> url_p @-> dest_p @-> dest_vdi_p @-> returning task_id_p err) + declare "DATA.copy_into" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> url_p + @-> dest_p + @-> dest_vdi_p + @-> returning task_id_p err + ) let copy = let result_p = Param.mk ~name:"task_id" Task.id in - declare "DATA.copy" [] (dbg_p @-> sr_p @-> vdi_p @-> dp_p @-> url_p @-> dest_p @-> returning result_p err) + declare "DATA.copy" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> dp_p + @-> url_p + @-> dest_p + @-> returning result_p err + ) module MIRROR = struct - (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and writes - data synchronously. It returns the id of the VDI.*) + (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and + writes data synchronously. It returns the id of the VDI.*) let start = - declare "DATA.MIRROR.start" [] (dbg_p @-> sr_p @-> vdi_p @-> dp_p @-> url_p @-> dest_p @-> returning task_id_p err) + declare "DATA.MIRROR.start" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> dp_p + @-> url_p + @-> dest_p + @-> returning task_id_p err + ) let id_p = Param.mk ~name:"id" Mirror.id @@ -822,27 +1021,37 @@ module StorageAPI (R : RPC) = struct let receive_start = let similar_p = Param.mk ~name:"similar" Mirror.similars in let result = Param.mk ~name:"result" Mirror.mirror_receive_result in - declare "DATA.MIRROR.receive_start" [] (dbg_p @-> sr_p @-> VDI.vdi_info_p @-> id_p @-> similar_p @-> returning result err) + declare "DATA.MIRROR.receive_start" [] + (dbg_p + @-> sr_p + @-> VDI.vdi_info_p + @-> id_p + @-> similar_p + @-> returning result err + ) let receive_finalize = - declare "DATA.MIRROR.receive_finalize" [] (dbg_p @-> id_p @-> returning unit_p err) + declare "DATA.MIRROR.receive_finalize" [] + (dbg_p @-> id_p @-> returning unit_p err) let receive_cancel = - declare "DATA.MIRROR.receive_cancel" [] (dbg_p @-> id_p @-> returning unit_p err) + declare "DATA.MIRROR.receive_cancel" [] + (dbg_p @-> id_p @-> returning unit_p err) let list = - let result_p = Param.mk ~name:"mirrors" TypeCombinators.(list (pair Mirror.(id, t))) in + let result_p = + Param.mk ~name:"mirrors" TypeCombinators.(list (pair Mirror.(id, t))) + in declare "DATA.MIRROR.list" [] (dbg_p @-> returning result_p err) end - - end module Policy = struct let get_backend_vm = let vm_p = Param.mk ~name:"vm" Types.string in let result_p = Param.mk ~name:"result" Types.string in - declare "Policy.get_backend_vm" [] (dbg_p @-> vm_p @-> sr_p @-> vdi_p @-> returning result_p err) + declare "Policy.get_backend_vm" [] + (dbg_p @-> vm_p @-> sr_p @-> vdi_p @-> returning result_p err) end module TASK = struct @@ -866,459 +1075,439 @@ module StorageAPI (R : RPC) = struct module UPDATES = struct let get = let from_p = Param.mk ~name:"from" Types.string in - let timeout_p = Param.mk ~name:"timeout" TypeCombinators.(option Types.int) in - let result_p = Param.mk ~name:"updates" TypeCombinators.(pair (list Dynamic.id, Types.string)) in - declare "UPDATES.get" [] (dbg_p @-> from_p @-> timeout_p @-> returning result_p err) + let timeout_p = + Param.mk ~name:"timeout" TypeCombinators.(option Types.int) + in + let result_p = + Param.mk ~name:"updates" + TypeCombinators.(pair (list Dynamic.id, Types.string)) + in + declare "UPDATES.get" [] + (dbg_p @-> from_p @-> timeout_p @-> returning result_p err) end end -module type Server_impl = -sig +module type Server_impl = sig type context = unit - module Query : - sig - val query : context -> dbg: string -> query_result - - val diagnostics : context -> dbg: string -> string + module Query : sig + val query : context -> dbg:string -> query_result + val diagnostics : context -> dbg:string -> string end - module DP : - sig - val create : context -> dbg: debug_info -> id: string -> dp + module DP : sig + val create : context -> dbg:debug_info -> id:string -> dp - val destroy : - context -> dbg: debug_info -> dp: dp -> allow_leak: bool -> unit + val destroy : context -> dbg:debug_info -> dp:dp -> allow_leak:bool -> unit val attach_info : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> dp: dp -> backend + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> dp:dp -> backend val diagnostics : context -> unit -> string val stat_vdi : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> unit -> dp_stat_t - + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit -> dp_stat_t end - module SR : - sig + module SR : sig val create : - context -> - dbg: debug_info -> - sr: sr -> - name_label: string -> - name_description: string -> - device_config: ((string * string) list) -> - physical_size: int64 -> (string * string) list + context + -> dbg:debug_info + -> sr:sr + -> name_label:string + -> name_description:string + -> device_config:(string * string) list + -> physical_size:int64 + -> (string * string) list val set_name_label : - context -> - dbg: debug_info -> sr: sr -> new_name_label: string -> unit + context -> dbg:debug_info -> sr:sr -> new_name_label:string -> unit val set_name_description : - context -> - dbg: debug_info -> sr: sr -> new_name_description: string -> unit + context -> dbg:debug_info -> sr:sr -> new_name_description:string -> unit val probe : - context -> - dbg: debug_info -> - queue: string -> - device_config: ((string * string) list) -> - sm_config: ((string * string) list) -> probe_result + context + -> dbg:debug_info + -> queue:string + -> device_config:(string * string) list + -> sm_config:(string * string) list + -> probe_result val attach : - context -> - dbg: debug_info -> - sr: sr -> device_config: ((string * string) list) -> unit + context + -> dbg:debug_info + -> sr:sr + -> device_config:(string * string) list + -> unit - val detach : context -> dbg: debug_info -> sr: sr -> unit + val detach : context -> dbg:debug_info -> sr:sr -> unit - val reset : context -> dbg: debug_info -> sr: sr -> unit + val reset : context -> dbg:debug_info -> sr:sr -> unit - val destroy : context -> dbg: debug_info -> sr: sr -> unit + val destroy : context -> dbg:debug_info -> sr:sr -> unit - val scan : context -> dbg: debug_info -> sr: sr -> vdi_info list + val scan : context -> dbg:debug_info -> sr:sr -> vdi_info list val update_snapshot_info_src : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> - url: string -> - dest: sr -> - dest_vdi: vdi -> - snapshot_pairs: ((vdi * vdi) list) -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> url:string + -> dest:sr + -> dest_vdi:vdi + -> snapshot_pairs:(vdi * vdi) list + -> unit val update_snapshot_info_dest : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> - src_vdi: vdi_info -> - snapshot_pairs: ((vdi * vdi_info) list) -> unit - - val stat : context -> dbg: debug_info -> sr: sr -> sr_info + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> src_vdi:vdi_info + -> snapshot_pairs:(vdi * vdi_info) list + -> unit - val list : context -> dbg: debug_info -> sr list + val stat : context -> dbg:debug_info -> sr:sr -> sr_info + val list : context -> dbg:debug_info -> sr list end - module VDI : - sig + module VDI : sig val create : - context -> - dbg: debug_info -> sr: sr -> vdi_info: vdi_info -> vdi_info + context -> dbg:debug_info -> sr:sr -> vdi_info:vdi_info -> vdi_info val set_name_label : - context -> - dbg: debug_info -> - sr: sr -> vdi: vdi -> new_name_label: string -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> new_name_label:string + -> unit val set_name_description : - context -> - dbg: debug_info -> - sr: sr -> vdi: vdi -> new_name_description: string -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> new_name_description:string + -> unit val snapshot : - context -> - dbg: debug_info -> sr: sr -> vdi_info: vdi_info -> vdi_info + context -> dbg:debug_info -> sr:sr -> vdi_info:vdi_info -> vdi_info val clone : - context -> - dbg: debug_info -> sr: sr -> vdi_info: vdi_info -> vdi_info + context -> dbg:debug_info -> sr:sr -> vdi_info:vdi_info -> vdi_info val resize : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> new_size: int64 -> int64 + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> new_size:int64 -> int64 - val destroy : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> unit + val destroy : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit - val stat : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> vdi_info + val stat : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> vdi_info val introduce : - context -> - dbg: debug_info -> - sr: sr -> - uuid: string -> - sm_config: ((string * string) list) -> - location: string -> vdi_info + context + -> dbg:debug_info + -> sr:sr + -> uuid:string + -> sm_config:(string * string) list + -> location:string + -> vdi_info val set_persistent : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> persistent: bool -> unit + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> persistent:bool -> unit val epoch_begin : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> vm: vm -> persistent: bool -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> vm:vm + -> persistent:bool + -> unit val attach : - context -> - dbg: debug_info -> - dp: dp -> sr: sr -> vdi: vdi -> read_write: bool -> attach_info + context + -> dbg:debug_info + -> dp:dp + -> sr:sr + -> vdi:vdi + -> read_write:bool + -> attach_info val attach2 : - context -> - dbg: debug_info -> - dp: dp -> sr: sr -> vdi: vdi -> read_write: bool -> backend + context + -> dbg:debug_info + -> dp:dp + -> sr:sr + -> vdi:vdi + -> read_write:bool + -> backend val attach3 : - context -> - dbg: debug_info -> - dp: dp -> sr: sr -> vdi: vdi -> vm: vm -> read_write: bool -> backend + context + -> dbg:debug_info + -> dp:dp + -> sr:sr + -> vdi:vdi + -> vm:vm + -> read_write:bool + -> backend val activate : - context -> dbg: debug_info -> dp: dp -> sr: sr -> vdi: vdi -> unit + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> unit val activate3 : - context -> dbg: debug_info -> dp: dp -> sr: sr -> vdi: vdi -> vm: vm -> unit + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> vm:vm -> unit val deactivate : - context -> dbg: debug_info -> dp: dp -> sr: sr -> vdi: vdi -> vm: vm -> unit + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> vm:vm -> unit val detach : - context -> dbg: debug_info -> dp: dp -> sr: sr -> vdi: vdi -> vm: vm -> unit + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> vm:vm -> unit val epoch_end : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> vm: vm -> unit + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> vm:vm -> unit - val get_url : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> string + val get_url : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> string val similar_content : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> vdi_info list + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> vdi_info list val get_by_name : - context -> dbg: debug_info -> sr: sr -> name: string -> vdi_info + context -> dbg:debug_info -> sr:sr -> name:string -> vdi_info val set_content_id : - context -> - dbg: debug_info -> - sr: sr -> vdi: vdi -> content_id: content_id -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> content_id:content_id + -> unit val compose : - context -> - dbg: debug_info -> sr: sr -> vdi1: vdi -> vdi2: vdi -> unit + context -> dbg:debug_info -> sr:sr -> vdi1:vdi -> vdi2:vdi -> unit val add_to_sm_config : - context -> - dbg: debug_info -> - sr: sr -> vdi: vdi -> key: string -> value: string -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> key:string + -> value:string + -> unit val remove_from_sm_config : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> key: string -> unit + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> key:string -> unit - val enable_cbt : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> unit + val enable_cbt : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit - val disable_cbt : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> unit + val disable_cbt : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit - val data_destroy : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> unit + val data_destroy : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit val list_changed_blocks : - context -> - dbg: debug_info -> - sr: sr -> vdi_from: vdi -> vdi_to: vdi -> string - + context -> dbg:debug_info -> sr:sr -> vdi_from:vdi -> vdi_to:vdi -> string end - val get_by_name : - context -> dbg: debug_info -> name: string -> (sr * vdi_info) + val get_by_name : context -> dbg:debug_info -> name:string -> sr * vdi_info - module DATA : - sig + module DATA : sig val copy_into : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> - url: string -> dest: sr -> dest_vdi: vdi -> Task.id + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> url:string + -> dest:sr + -> dest_vdi:vdi + -> Task.id val copy : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> dp: dp -> url: string -> dest: sr -> Task.id - - module MIRROR : - sig + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> dp:dp + -> url:string + -> dest:sr + -> Task.id + + module MIRROR : sig val start : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> dp: dp -> url: string -> dest: sr -> Task.id + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> dp:dp + -> url:string + -> dest:sr + -> Task.id - val stop : context -> dbg: debug_info -> id: Mirror.id -> unit + val stop : context -> dbg:debug_info -> id:Mirror.id -> unit - val stat : - context -> dbg: debug_info -> id: Mirror.id -> Mirror.t + val stat : context -> dbg:debug_info -> id:Mirror.id -> Mirror.t val receive_start : - context -> - dbg: debug_info -> - sr: sr -> - vdi_info: vdi_info -> - id: Mirror.id -> - similar: Mirror.similars -> Mirror. - mirror_receive_result - - val receive_finalize : - context -> dbg: debug_info -> id: Mirror.id -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi_info:vdi_info + -> id:Mirror.id + -> similar:Mirror.similars + -> Mirror.mirror_receive_result - val receive_cancel : - context -> dbg: debug_info -> id: Mirror.id -> unit + val receive_finalize : context -> dbg:debug_info -> id:Mirror.id -> unit - val list : - context -> dbg: debug_info -> (Mirror.id * Mirror.t) list + val receive_cancel : context -> dbg:debug_info -> id:Mirror.id -> unit + val list : context -> dbg:debug_info -> (Mirror.id * Mirror.t) list end - end - module Policy : - sig + module Policy : sig val get_backend_vm : - context -> - dbg: debug_info -> vm: string -> sr: sr -> vdi: vdi -> string - + context -> dbg:debug_info -> vm:string -> sr:sr -> vdi:vdi -> string end - module TASK : - sig - val stat : context -> dbg: debug_info -> task: Task.id -> Task.t + module TASK : sig + val stat : context -> dbg:debug_info -> task:Task.id -> Task.t - val cancel : context -> dbg: debug_info -> task: Task.id -> unit + val cancel : context -> dbg:debug_info -> task:Task.id -> unit - val destroy : context -> dbg: debug_info -> task: Task.id -> unit - - val list : context -> dbg: debug_info -> Task.t list + val destroy : context -> dbg:debug_info -> task:Task.id -> unit + val list : context -> dbg:debug_info -> Task.t list end - module UPDATES : - sig + module UPDATES : sig val get : - context -> - dbg: debug_info -> - from: string -> - timeout: (int option) -> ((Dynamic.id list) * string) - + context + -> dbg:debug_info + -> from:string + -> timeout:int option + -> Dynamic.id list * string end - end - - module Server (Impl : Server_impl) () = struct - module S = StorageAPI(Idl.Exn.GenServer ()) + module S = StorageAPI (Idl.Exn.GenServer ()) let _ = - S.Query.query (fun dbg -> Impl.Query.query () ~dbg); - S.Query.diagnostics (fun dbg -> Impl.Query.diagnostics () ~dbg); - - S.DP.create (fun dbg id -> Impl.DP.create () ~dbg ~id); - S.DP.destroy (fun dbg dp allow_leak -> Impl.DP.destroy () ~dbg ~dp ~allow_leak); - S.DP.attach_info (fun dbg sr vdi dp -> Impl.DP.attach_info () ~dbg ~sr ~vdi ~dp); - S.DP.diagnostics (fun () -> Impl.DP.diagnostics () ()); - S.DP.stat_vdi (fun dbg sr vdi () -> Impl.DP.stat_vdi () ~dbg ~sr~vdi ()); - - S.SR.create (fun dbg sr name_label name_description device_config physical_size -> - Impl.SR.create () ~dbg ~sr ~name_label ~name_description ~device_config ~physical_size); + S.Query.query (fun dbg -> Impl.Query.query () ~dbg) ; + S.Query.diagnostics (fun dbg -> Impl.Query.diagnostics () ~dbg) ; + S.DP.create (fun dbg id -> Impl.DP.create () ~dbg ~id) ; + S.DP.destroy (fun dbg dp allow_leak -> + Impl.DP.destroy () ~dbg ~dp ~allow_leak) ; + S.DP.attach_info (fun dbg sr vdi dp -> + Impl.DP.attach_info () ~dbg ~sr ~vdi ~dp) ; + S.DP.diagnostics (fun () -> Impl.DP.diagnostics () ()) ; + S.DP.stat_vdi (fun dbg sr vdi () -> Impl.DP.stat_vdi () ~dbg ~sr ~vdi ()) ; + S.SR.create + (fun dbg sr name_label name_description device_config physical_size -> + Impl.SR.create () ~dbg ~sr ~name_label ~name_description ~device_config + ~physical_size) ; S.SR.set_name_label (fun dbg sr new_name_label -> - Impl.SR.set_name_label () ~dbg ~sr ~new_name_label); + Impl.SR.set_name_label () ~dbg ~sr ~new_name_label) ; S.SR.set_name_description (fun dbg sr new_name_description -> - Impl.SR.set_name_description () ~dbg ~sr ~new_name_description); + Impl.SR.set_name_description () ~dbg ~sr ~new_name_description) ; S.SR.probe (fun dbg queue device_config sm_config -> - Impl.SR.probe () ~dbg ~queue ~device_config ~sm_config); + Impl.SR.probe () ~dbg ~queue ~device_config ~sm_config) ; S.SR.attach (fun dbg sr device_config -> - Impl.SR.attach () ~dbg ~sr ~device_config); - S.SR.detach (fun dbg sr -> - Impl.SR.detach () ~dbg ~sr); - S.SR.reset (fun dbg sr -> - Impl.SR.reset () ~dbg ~sr); - S.SR.destroy (fun dbg sr -> - Impl.SR.destroy () ~dbg ~sr); - S.SR.scan (fun dbg sr -> - Impl.SR.scan () ~dbg ~sr); - S.SR.update_snapshot_info_src (fun dbg sr vdi url dest dest_vdi snapshot_pairs -> - Impl.SR.update_snapshot_info_src () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs); + Impl.SR.attach () ~dbg ~sr ~device_config) ; + S.SR.detach (fun dbg sr -> Impl.SR.detach () ~dbg ~sr) ; + S.SR.reset (fun dbg sr -> Impl.SR.reset () ~dbg ~sr) ; + S.SR.destroy (fun dbg sr -> Impl.SR.destroy () ~dbg ~sr) ; + S.SR.scan (fun dbg sr -> Impl.SR.scan () ~dbg ~sr) ; + S.SR.update_snapshot_info_src + (fun dbg sr vdi url dest dest_vdi snapshot_pairs -> + Impl.SR.update_snapshot_info_src () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi + ~snapshot_pairs) ; S.SR.update_snapshot_info_dest (fun dbg sr vdi src_vdi snapshot_pairs -> - Impl.SR.update_snapshot_info_dest () ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs); - S.SR.stat (fun dbg sr -> - Impl.SR.stat () ~dbg ~sr); - S.SR.list (fun dbg -> - Impl.SR.list () ~dbg); - - - S.VDI.create (fun dbg sr vdi_info -> - Impl.VDI.create () ~dbg ~sr ~vdi_info); + Impl.SR.update_snapshot_info_dest () ~dbg ~sr ~vdi ~src_vdi + ~snapshot_pairs) ; + S.SR.stat (fun dbg sr -> Impl.SR.stat () ~dbg ~sr) ; + S.SR.list (fun dbg -> Impl.SR.list () ~dbg) ; + S.VDI.create (fun dbg sr vdi_info -> Impl.VDI.create () ~dbg ~sr ~vdi_info) ; S.VDI.set_name_label (fun dbg sr vdi new_name_label -> - Impl.VDI.set_name_label () ~dbg ~sr ~vdi ~new_name_label); + Impl.VDI.set_name_label () ~dbg ~sr ~vdi ~new_name_label) ; S.VDI.set_name_description (fun dbg sr vdi new_name_description -> - Impl.VDI.set_name_description () ~dbg ~sr ~vdi ~new_name_description); + Impl.VDI.set_name_description () ~dbg ~sr ~vdi ~new_name_description) ; S.VDI.snapshot (fun dbg sr vdi_info -> - Impl.VDI.snapshot () ~dbg ~sr ~vdi_info); - S.VDI.clone (fun dbg sr vdi_info -> - Impl.VDI.clone () ~dbg ~sr ~vdi_info); + Impl.VDI.snapshot () ~dbg ~sr ~vdi_info) ; + S.VDI.clone (fun dbg sr vdi_info -> Impl.VDI.clone () ~dbg ~sr ~vdi_info) ; S.VDI.resize (fun dbg sr vdi new_size -> - Impl.VDI.resize () ~dbg ~sr ~vdi ~new_size); - S.VDI.destroy (fun dbg sr vdi -> - Impl.VDI.destroy () ~dbg ~sr ~vdi); - S.VDI.stat (fun dbg sr vdi -> - Impl.VDI.stat () ~dbg ~sr ~vdi); + Impl.VDI.resize () ~dbg ~sr ~vdi ~new_size) ; + S.VDI.destroy (fun dbg sr vdi -> Impl.VDI.destroy () ~dbg ~sr ~vdi) ; + S.VDI.stat (fun dbg sr vdi -> Impl.VDI.stat () ~dbg ~sr ~vdi) ; S.VDI.introduce (fun dbg sr uuid sm_config location -> - Impl.VDI.introduce () ~dbg ~sr ~uuid ~sm_config ~location); + Impl.VDI.introduce () ~dbg ~sr ~uuid ~sm_config ~location) ; S.VDI.set_persistent (fun dbg sr vdi persistent -> - Impl.VDI.set_persistent () ~dbg ~sr ~vdi ~persistent); + Impl.VDI.set_persistent () ~dbg ~sr ~vdi ~persistent) ; S.VDI.epoch_begin (fun dbg sr vdi vm persistent -> - Impl.VDI.epoch_begin () ~dbg ~sr ~vdi ~vm ~persistent); + Impl.VDI.epoch_begin () ~dbg ~sr ~vdi ~vm ~persistent) ; S.VDI.attach (fun dbg dp sr vdi read_write -> - Impl.VDI.attach () ~dbg ~dp ~sr ~vdi ~read_write); + Impl.VDI.attach () ~dbg ~dp ~sr ~vdi ~read_write) ; S.VDI.attach2 (fun dbg dp sr vdi read_write -> - Impl.VDI.attach2 () ~dbg ~dp ~sr ~vdi ~read_write); + Impl.VDI.attach2 () ~dbg ~dp ~sr ~vdi ~read_write) ; S.VDI.attach3 (fun dbg dp sr vdi vm read_write -> - Impl.VDI.attach3 () ~dbg ~dp ~sr ~vdi ~vm ~read_write); - S.VDI.activate (fun dbg dp sr vdi -> - Impl.VDI.activate () ~dbg ~dp ~sr ~vdi); + Impl.VDI.attach3 () ~dbg ~dp ~sr ~vdi ~vm ~read_write) ; + S.VDI.activate (fun dbg dp sr vdi -> Impl.VDI.activate () ~dbg ~dp ~sr ~vdi) ; S.VDI.activate3 (fun dbg dp sr vdi vm -> - Impl.VDI.activate3 () ~dbg ~dp ~sr ~vdi ~vm); + Impl.VDI.activate3 () ~dbg ~dp ~sr ~vdi ~vm) ; S.VDI.deactivate (fun dbg dp sr vdi vm -> - Impl.VDI.deactivate () ~dbg ~dp ~sr ~vdi ~vm); + Impl.VDI.deactivate () ~dbg ~dp ~sr ~vdi ~vm) ; S.VDI.detach (fun dbg dp sr vdi vm -> - Impl.VDI.detach () ~dbg ~dp ~sr ~vdi ~vm); + Impl.VDI.detach () ~dbg ~dp ~sr ~vdi ~vm) ; S.VDI.epoch_end (fun dbg sr vdi vm -> - Impl.VDI.epoch_end () ~dbg ~sr ~vdi ~vm); - S.VDI.get_url (fun dbg sr vdi -> - Impl.VDI.get_url () ~dbg ~sr ~vdi); + Impl.VDI.epoch_end () ~dbg ~sr ~vdi ~vm) ; + S.VDI.get_url (fun dbg sr vdi -> Impl.VDI.get_url () ~dbg ~sr ~vdi) ; S.VDI.similar_content (fun dbg sr vdi -> - Impl.VDI.similar_content () ~dbg ~sr ~vdi); + Impl.VDI.similar_content () ~dbg ~sr ~vdi) ; S.VDI.get_by_name (fun dbg sr name -> - Impl.VDI.get_by_name () ~dbg ~sr ~name); + Impl.VDI.get_by_name () ~dbg ~sr ~name) ; S.VDI.set_content_id (fun dbg sr vdi content_id -> - Impl.VDI.set_content_id () ~dbg ~sr ~vdi ~content_id); + Impl.VDI.set_content_id () ~dbg ~sr ~vdi ~content_id) ; S.VDI.compose (fun dbg sr vdi1 vdi2 -> - Impl.VDI.compose () ~dbg ~sr ~vdi1 ~vdi2); + Impl.VDI.compose () ~dbg ~sr ~vdi1 ~vdi2) ; S.VDI.add_to_sm_config (fun dbg sr vdi key value -> - Impl.VDI.add_to_sm_config () ~dbg ~sr ~vdi ~key ~value); + Impl.VDI.add_to_sm_config () ~dbg ~sr ~vdi ~key ~value) ; S.VDI.remove_from_sm_config (fun dbg sr vdi key -> - Impl.VDI.remove_from_sm_config () ~dbg ~sr ~vdi ~key); - S.VDI.enable_cbt (fun dbg sr vdi -> - Impl.VDI.enable_cbt () ~dbg ~sr ~vdi); - S.VDI.disable_cbt (fun dbg sr vdi -> - Impl.VDI.disable_cbt () ~dbg ~sr ~vdi); + Impl.VDI.remove_from_sm_config () ~dbg ~sr ~vdi ~key) ; + S.VDI.enable_cbt (fun dbg sr vdi -> Impl.VDI.enable_cbt () ~dbg ~sr ~vdi) ; + S.VDI.disable_cbt (fun dbg sr vdi -> Impl.VDI.disable_cbt () ~dbg ~sr ~vdi) ; S.VDI.data_destroy (fun dbg sr vdi -> - Impl.VDI.data_destroy () ~dbg ~sr ~vdi); + Impl.VDI.data_destroy () ~dbg ~sr ~vdi) ; S.VDI.list_changed_blocks (fun dbg sr vdi_from vdi_to -> - Impl.VDI.list_changed_blocks () ~dbg ~sr ~vdi_from ~vdi_to); - - S.get_by_name (fun dbg name -> - Impl.get_by_name () ~dbg ~name); - + Impl.VDI.list_changed_blocks () ~dbg ~sr ~vdi_from ~vdi_to) ; + S.get_by_name (fun dbg name -> Impl.get_by_name () ~dbg ~name) ; S.DATA.copy_into (fun dbg sr vdi url dest dest_vdi -> - Impl.DATA.copy_into () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi); + Impl.DATA.copy_into () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi) ; S.DATA.copy (fun dbg sr vdi dp url dest -> - Impl.DATA.copy () ~dbg ~sr ~vdi ~dp ~url ~dest); - + Impl.DATA.copy () ~dbg ~sr ~vdi ~dp ~url ~dest) ; S.DATA.MIRROR.start (fun dbg sr vdi dp url dest -> - Impl.DATA.MIRROR.start () ~dbg ~sr ~vdi ~dp ~url ~dest); - S.DATA.MIRROR.stop (fun dbg id -> - Impl.DATA.MIRROR.stop () ~dbg ~id); - S.DATA.MIRROR.stat (fun dbg id -> - Impl.DATA.MIRROR.stat () ~dbg ~id); + Impl.DATA.MIRROR.start () ~dbg ~sr ~vdi ~dp ~url ~dest) ; + S.DATA.MIRROR.stop (fun dbg id -> Impl.DATA.MIRROR.stop () ~dbg ~id) ; + S.DATA.MIRROR.stat (fun dbg id -> Impl.DATA.MIRROR.stat () ~dbg ~id) ; S.DATA.MIRROR.receive_start (fun dbg sr vdi_info id similar -> - Impl.DATA.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id ~similar); + Impl.DATA.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id ~similar) ; S.DATA.MIRROR.receive_cancel (fun dbg id -> - Impl.DATA.MIRROR.receive_cancel () ~dbg ~id); + Impl.DATA.MIRROR.receive_cancel () ~dbg ~id) ; S.DATA.MIRROR.receive_finalize (fun dbg id -> - Impl.DATA.MIRROR.receive_finalize () ~dbg ~id); - S.DATA.MIRROR.list (fun dbg -> - Impl.DATA.MIRROR.list () ~dbg); - + Impl.DATA.MIRROR.receive_finalize () ~dbg ~id) ; + S.DATA.MIRROR.list (fun dbg -> Impl.DATA.MIRROR.list () ~dbg) ; S.Policy.get_backend_vm (fun dbg vm sr vdi -> - Impl.Policy.get_backend_vm () ~dbg ~vm ~sr ~vdi); - - S.TASK.stat (fun dbg task -> - Impl.TASK.stat () ~dbg ~task); - S.TASK.cancel (fun dbg task -> - Impl.TASK.cancel () ~dbg ~task); - S.TASK.destroy (fun dbg task -> - Impl.TASK.destroy () ~dbg ~task); - S.TASK.list (fun dbg -> - Impl.TASK.list () ~dbg); - + Impl.Policy.get_backend_vm () ~dbg ~vm ~sr ~vdi) ; + S.TASK.stat (fun dbg task -> Impl.TASK.stat () ~dbg ~task) ; + S.TASK.cancel (fun dbg task -> Impl.TASK.cancel () ~dbg ~task) ; + S.TASK.destroy (fun dbg task -> Impl.TASK.destroy () ~dbg ~task) ; + S.TASK.list (fun dbg -> Impl.TASK.list () ~dbg) ; S.UPDATES.get (fun dbg from timeout -> Impl.UPDATES.get () ~dbg ~from ~timeout) - (* Bind all *) let process call = Idl.Exn.server S.implementation call - end - diff --git a/storage/storage_skeleton.ml b/storage/storage_skeleton.ml index 51e8301c..5e93071e 100644 --- a/storage/storage_skeleton.ml +++ b/storage/storage_skeleton.ml @@ -13,98 +13,161 @@ *) [@@@ocaml.warning "-27"] -let u x = raise (Storage_interface.(Storage_error (Errors.Unimplemented x))) +let u x = raise Storage_interface.(Storage_error (Errors.Unimplemented x)) type context = unit module UPDATES = struct let get ctx ~dbg ~from ~timeout = (* block forever *) - while true do Thread.delay 5. done; - [], "" + while true do + Thread.delay 5. + done ; + ([], "") end module Query = struct let query ctx ~dbg = u "Query.query" + let diagnostics ctx ~dbg = u "Query.diagnostics" end module DP = struct let create ctx ~dbg ~id = u "DP.create" + let destroy ctx ~dbg ~dp ~allow_leak = u "DP.destroy" + let attach_info ctx ~dbg ~sr ~vdi ~dp = u "DP.attach_info" + let diagnostics ctx () = u "DP.diagnostics" + let stat_vdi ctx ~dbg ~sr ~vdi () = u "DP.stat_vdi" end module SR = struct - let create ctx ~dbg ~sr ~name_label ~name_description ~device_config ~physical_size = u "SR.create" + let create ctx ~dbg ~sr ~name_label ~name_description ~device_config + ~physical_size = + u "SR.create" + let attach ctx ~dbg ~sr ~device_config = u "SR.attach" + let set_name_label ctx ~dbg ~sr ~new_name_label = u "SR.set_name_label" - let set_name_description ctx ~dbg ~sr ~new_name_description = u "SR.set_name_description" + + let set_name_description ctx ~dbg ~sr ~new_name_description = + u "SR.set_name_description" + let detach ctx ~dbg ~sr = u "SR.detach" + let reset ctx ~dbg ~sr = u "SR.reset" + let destroy ctx ~dbg ~sr = u "SR.destroy" + let probe ctx ~dbg ~queue ~device_config ~sm_config = u "SR.probe" + let scan ctx ~dbg ~sr = u "SR.scan" - let update_snapshot_info_src ctx ~dbg ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs = u "SR.update_snapshot_info_src" - let update_snapshot_info_dest ctx ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs = u "SR.update_snapshot_info_dest" + + let update_snapshot_info_src ctx ~dbg ~sr ~vdi ~url ~dest ~dest_vdi + ~snapshot_pairs = + u "SR.update_snapshot_info_src" + + let update_snapshot_info_dest ctx ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs = + u "SR.update_snapshot_info_dest" + let stat ctx ~dbg ~sr = u "SR.stat" + let list ctx ~dbg = u "SR.list" end module VDI = struct let create ctx ~dbg ~sr ~vdi_info = u "VDI.create" + let set_name_label ctx ~dbg ~sr ~vdi ~new_name_label = u "VDI.set_name_label" - let set_name_description ctx ~dbg ~sr ~vdi ~new_name_description = u "VDI.set_name_description" + + let set_name_description ctx ~dbg ~sr ~vdi ~new_name_description = + u "VDI.set_name_description" + let snapshot ctx ~dbg ~sr ~vdi_info = u "VDI.snapshot" + let clone ctx ~dbg ~sr ~vdi_info = u "VDI.clone" + let resize ctx ~dbg ~sr ~vdi ~new_size = u "VDI.resize" + let destroy ctx ~dbg ~sr ~vdi = u "VDI.destroy" + let stat ctx ~dbg ~sr ~vdi = u "VDI.stat" + let introduce ctx ~dbg ~sr ~uuid ~sm_config ~location = u "VDI.introduce" + let set_persistent ctx ~dbg ~sr ~vdi ~persistent = u "VDI.set_persistent" + let epoch_begin ctx ~dbg ~sr ~vdi ~vm ~persistent = () + let attach ctx ~dbg ~dp ~sr ~vdi ~read_write = u "VDI.attach" + let attach2 ctx ~dbg ~dp ~sr ~vdi ~read_write = u "VDI.attach2" + let attach3 ctx ~dbg ~dp ~sr ~vdi ~vm ~read_write = u "VDI.attach3" + let activate ctx ~dbg ~dp ~sr ~vdi = u "VDI.activate" + let activate3 ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.activate3" - let deactivate ctx ~dbg ~dp ~sr ~vdi ~vm= u "VDI.deactivate" + + let deactivate ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.deactivate" + let detach ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.detach" + let epoch_end ctx ~dbg ~sr ~vdi ~vm = () + let get_url ctx ~dbg ~sr ~vdi = u "VDI.get_url" + let similar_content ctx ~dbg ~sr ~vdi = u "VDI.similar_content" + let get_by_name ctx ~dbg ~sr ~name = u "VDI.get_by_name" + let set_content_id ctx ~dbg ~sr ~vdi ~content_id = u "VDI.set_content_id" + let compose ctx ~dbg ~sr ~vdi1 ~vdi2 = u "VDI.compose" + let add_to_sm_config ctx ~dbg ~sr ~vdi ~key ~value = u "VDI.add_to_sm_config" - let remove_from_sm_config ctx ~dbg ~sr ~vdi ~key = u "VDI.remove_from_sm_config" + + let remove_from_sm_config ctx ~dbg ~sr ~vdi ~key = + u "VDI.remove_from_sm_config" + let enable_cbt ctx ~dbg ~sr ~vdi = u "VDI.enable_cbt" + let disable_cbt ctx ~dbg ~sr ~vdi = u "VDI.disable_cbt" + let data_destroy ctx ~dbg ~sr ~vdi = u "VDI.data_destroy" - let list_changed_blocks ctx ~dbg ~sr ~vdi_from ~vdi_to = u "VDI.list_changed_blocks" + + let list_changed_blocks ctx ~dbg ~sr ~vdi_from ~vdi_to = + u "VDI.list_changed_blocks" end let get_by_name ctx ~dbg ~name = u "get_by_name" module DATA = struct let copy_into ctx ~dbg ~sr ~vdi ~url ~dest ~dest_vdi = u "DATA.copy_into" + let copy ctx ~dbg ~sr ~vdi ~dp ~url ~dest = u "DATA.copy" module MIRROR = struct - (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and writes - data synchronously. It returns the id of the VDI.*) + (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and + writes data synchronously. It returns the id of the VDI.*) let start ctx ~dbg ~sr ~vdi ~dp ~url ~dest = u "DATA.MIRROR.start" + let stop ctx ~dbg ~id = u "DATA.MIRROR.stop" + let stat ctx ~dbg ~id = u "DATA.MIRROR.stat" - let receive_start ctx ~dbg ~sr ~vdi_info ~id ~similar = u "DATA.MIRROR.receive_start" - let receive_finalize ctx ~dbg ~id = u "DATA.MIRROR.receive_finalize" + + let receive_start ctx ~dbg ~sr ~vdi_info ~id ~similar = + u "DATA.MIRROR.receive_start" + + let receive_finalize ctx ~dbg ~id = u "DATA.MIRROR.receive_finalize" + let receive_cancel ctx ~dbg ~id = u "DATA.MIRROR.receive_cancel" - + let list ctx ~dbg = u "DATA.MIRROR.list" end - end module Policy = struct @@ -113,8 +176,10 @@ end module TASK = struct let stat ctx ~dbg ~task = u "TASK.stat" + let cancel ctx ~dbg ~task = u "TASK.cancel" + let destroy ctx ~dbg ~task = u "TASK.destroy" + let list ctx ~dbg = u "TASK.list" end - diff --git a/storage/storage_skeleton_test.ml b/storage/storage_skeleton_test.ml index 6ec46362..60763c11 100644 --- a/storage/storage_skeleton_test.ml +++ b/storage/storage_skeleton_test.ml @@ -13,4 +13,4 @@ *) (* if this type-checks then the storage_skeleton is complete *) -module Test = Storage_interface.Server(Storage_skeleton) +module Test = Storage_interface.Server (Storage_skeleton) diff --git a/storage/storage_test.ml b/storage/storage_test.ml index 384fd691..4a7cdd22 100644 --- a/storage/storage_test.ml +++ b/storage/storage_test.ml @@ -23,27 +23,37 @@ open Storage_client (* We assume that no-one else has made VDIs with this name prefix: *) let safe_prefix = Printf.sprintf "storage_test.%d" (Unix.getpid ()) + let dbg = safe_prefix let _vdi_create = "VDI_CREATE" + let _vdi_delete = "VDI_DELETE" + let _vdi_attach = "VDI_ATTACH" + let _vdi_detach = "VDI_DETACH" + let _vdi_activate = "VDI_ACTIVATE" + let _vdi_deactivate = "VDI_DEACTIVATE" + let _vdi_clone = "VDI_CLONE" + let _vdi_resize = "VDI_RESIZE" (* Names which are likely to cause problems *) -let names = [ - "simple"; (* start with an easy one *) - ""; - "."; - ".."; - "/"; - "!"; - String.make 128 '0'; -] +let names = + [ + (* start with an easy one *) + "simple" + ; "" + ; "." + ; ".." + ; "/" + ; "!" + ; String.make 128 '0' + ] (* For each VDI we check that: 1. it shows up in a SR.scan @@ -53,23 +63,25 @@ let names = [ let vdi_exists sr vdi = let all = Client.SR.scan dbg sr in - List.fold_left (fun acc vdi_info -> acc || (vdi_info.vdi = vdi)) false all + List.fold_left (fun acc vdi_info -> acc || vdi_info.vdi = vdi) false all let create sr name_label = - let vdi_info = { - default_vdi_info with - name_label = safe_prefix ^ "." ^ name_label; - virtual_size = 1000000000L; - } in + let vdi_info = + { + default_vdi_info with + name_label= safe_prefix ^ "." ^ name_label + ; virtual_size= 1000000000L + } + in let vdi = Client.VDI.create dbg sr vdi_info in - assert(vdi_exists sr vdi.vdi); + assert (vdi_exists sr vdi.vdi) ; (* Check the disk has size >= the amount we requested *) - assert(vdi.virtual_size >= vdi_info.virtual_size); + assert (vdi.virtual_size >= vdi_info.virtual_size) ; vdi let destroy sr vdi = - Client.VDI.destroy dbg sr vdi.vdi; - assert(not (vdi_exists sr vdi.vdi)) + Client.VDI.destroy dbg sr vdi.vdi ; + assert (not (vdi_exists sr vdi.vdi)) let test_create_destroy sr n () = destroy sr (create sr n) @@ -80,19 +92,19 @@ let attach_detach sr vdi read_write = let test_attach_detach sr n () = let vdi = create sr n in - List.iter (attach_detach sr vdi) [ true; false ]; + List.iter (attach_detach sr vdi) [true; false] ; destroy sr vdi let attach_activate_deactivate_detach sr vdi read_write = let vm = Vm.of_string "0" in let _ = Client.VDI.attach dbg dbg sr vdi.vdi read_write in - Client.VDI.activate dbg dbg sr vdi.vdi; - Client.VDI.deactivate dbg dbg sr vdi.vdi vm; + Client.VDI.activate dbg dbg sr vdi.vdi ; + Client.VDI.deactivate dbg dbg sr vdi.vdi vm ; Client.VDI.detach dbg dbg sr vdi.vdi vm let test_activate_deactivate sr n () = let vdi = create sr n in - List.iter (attach_activate_deactivate_detach sr vdi) [ true; false ]; + List.iter (attach_activate_deactivate_detach sr vdi) [true; false] ; destroy sr vdi let test_clone sr n () = @@ -100,12 +112,12 @@ let test_clone sr n () = List.iter (fun _read_write -> (* Check whether the backend writes type= *) - let vdi = { vdi with sm_config = [] } in + let vdi = {vdi with sm_config= []} in let x = Client.VDI.clone dbg sr vdi in - Client.VDI.destroy dbg sr x.vdi; - assert(List.mem_assoc "type" x.sm_config); - assert(List.assoc "type" x.sm_config <> "raw"); - ) [ true; false ]; + Client.VDI.destroy dbg sr x.vdi ; + assert (List.mem_assoc "type" x.sm_config) ; + assert (List.assoc "type" x.sm_config <> "raw")) + [true; false] ; destroy sr vdi let test_clone_attach sr n () = @@ -115,83 +127,150 @@ let test_clone_attach sr n () = let vdis = Client.SR.scan dbg sr in let x = Client.VDI.clone dbg sr vdi in let vdis' = Client.SR.scan dbg sr in - attach_activate_deactivate_detach sr x read_write; - Client.VDI.destroy dbg sr x.vdi; - assert ((List.length vdis + 1) = (List.length vdis')) - ) [ true; false ]; + attach_activate_deactivate_detach sr x read_write ; + Client.VDI.destroy dbg sr x.vdi ; + assert (List.length vdis + 1 = List.length vdis')) + [true; false] ; destroy sr vdi let test_resize sr n () = let vdi = create sr n in let new_size_request = Int64.mul 2L vdi.virtual_size in let new_size_actual = Client.VDI.resize dbg sr vdi.vdi new_size_request in - assert (new_size_actual >= new_size_request); + assert (new_size_actual >= new_size_request) ; destroy sr vdi -let vdi_create_destroy sr = "vdi_create_destroy" , (List.map (fun n -> "name " ^ n , `Quick, test_create_destroy sr n) names) -let vdi_attach_detach sr = "vdi_attach_detach" , (List.map (fun n -> "name " ^ n , `Quick, test_attach_detach sr n) names) -let vdi_activate_deactivate sr = "vdi_activate_deactivate" , (List.map (fun n -> "name " ^ n , `Quick, test_activate_deactivate sr n) names) -let vdi_clone sr = "vdi_clone" , (List.map (fun n -> "name " ^ n , `Quick, test_clone sr n) names) -let vdi_clone_attach sr = "vdi_clone_attach" , (List.map (fun n -> "name " ^ n , `Quick, test_clone_attach sr n) names) -let vdi_resize sr = "vdi_resize" , (List.map (fun n -> "name " ^ n , `Quick, test_resize sr n) names) +let vdi_create_destroy sr = + ( "vdi_create_destroy" + , List.map (fun n -> ("name " ^ n, `Quick, test_create_destroy sr n)) names ) + +let vdi_attach_detach sr = + ( "vdi_attach_detach" + , List.map (fun n -> ("name " ^ n, `Quick, test_attach_detach sr n)) names ) + +let vdi_activate_deactivate sr = + ( "vdi_activate_deactivate" + , List.map + (fun n -> ("name " ^ n, `Quick, test_activate_deactivate sr n)) + names ) + +let vdi_clone sr = + ("vdi_clone", List.map (fun n -> ("name " ^ n, `Quick, test_clone sr n)) names) + +let vdi_clone_attach sr = + ( "vdi_clone_attach" + , List.map (fun n -> ("name " ^ n, `Quick, test_clone_attach sr n)) names ) + +let vdi_resize sr = + ( "vdi_resize" + , List.map (fun n -> ("name " ^ n, `Quick, test_resize sr n)) names ) open Cmdliner -let start verbose queue sr = match queue, sr with +let start _verbose queue sr = + match (queue, sr) with | Some queue, Some sr -> - Storage_interface.queue_name := queue; - Xcp_client.use_switch := true; - - let q = Client.Query.query dbg in - let features = List.map (fun s -> - try - let i = String.index s '/' in - Some (String.sub s 0 i, Int64.of_string (String.sub s (i+1) (String.length s - i - 1))) - with _ -> Some (s, 1L)) q.features in - let features = List.fold_left (fun acc x -> match x with Some x -> x::acc | None -> acc) [] features in - - let needs_capabilities caps suite = - if List.fold_left (fun acc x -> acc && (List.mem_assoc x features)) true caps - then [ suite ] else [] in - - let suite = - (List.concat [ - needs_capabilities [ _vdi_create; _vdi_delete ] (vdi_create_destroy sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_attach; _vdi_detach ] (vdi_attach_detach sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_attach; _vdi_detach; _vdi_activate; _vdi_deactivate ] (vdi_activate_deactivate sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_clone ] (vdi_clone sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_attach; _vdi_detach; _vdi_activate; _vdi_deactivate; _vdi_clone ] (vdi_clone_attach sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_resize ] (vdi_resize sr); - ]) in - Alcotest.run ~and_exit:false ~argv:[|Array.get Sys.argv 0|] "storage" suite + Storage_interface.queue_name := queue ; + Xcp_client.use_switch := true ; + let q = Client.Query.query dbg in + let features = + List.map + (fun s -> + try + let i = String.index s '/' in + Some + ( String.sub s 0 i + , Int64.of_string + (String.sub s (i + 1) (String.length s - i - 1)) ) + with _ -> Some (s, 1L)) + q.features + in + let features = + List.fold_left + (fun acc x -> match x with Some x -> x :: acc | None -> acc) + [] features + in + let needs_capabilities caps suite = + if + List.fold_left + (fun acc x -> acc && List.mem_assoc x features) + true caps + then + [suite] + else + [] + in + let suite = + List.concat + [ + needs_capabilities [_vdi_create; _vdi_delete] (vdi_create_destroy sr) + ; needs_capabilities + [_vdi_create; _vdi_delete; _vdi_attach; _vdi_detach] + (vdi_attach_detach sr) + ; needs_capabilities + [ + _vdi_create + ; _vdi_delete + ; _vdi_attach + ; _vdi_detach + ; _vdi_activate + ; _vdi_deactivate + ] + (vdi_activate_deactivate sr) + ; needs_capabilities + [_vdi_create; _vdi_delete; _vdi_clone] + (vdi_clone sr) + ; needs_capabilities + [ + _vdi_create + ; _vdi_delete + ; _vdi_attach + ; _vdi_detach + ; _vdi_activate + ; _vdi_deactivate + ; _vdi_clone + ] + (vdi_clone_attach sr) + ; needs_capabilities + [_vdi_create; _vdi_delete; _vdi_resize] + (vdi_resize sr) + ] + in + Alcotest.run ~and_exit:false ~argv:[|Sys.argv.(0)|] "storage" suite | _, _ -> - Printf.fprintf stderr "Please supply both a queue name and an SR\n%!"; - () + Printf.fprintf stderr "Please supply both a queue name and an SR\n%!" ; + () let cmd = let doc = "Storage component test" in - let man = [ - `S "DESCRIPTION"; - `P "Test a storage implementation via the SMAPI."; - `S "USAGE"; - `P "$(tname) "; - `P "-- test the service listening on using the existing attached SR ."; - ] in + let man = + [ + `S "DESCRIPTION" + ; `P "Test a storage implementation via the SMAPI." + ; `S "USAGE" + ; `P "$(tname) " + ; `P + "-- test the service listening on using the existing \ + attached SR ." + ] + in let verbose = let doc = "Print verbose output" in - Arg.(value & flag & info ["verbose"; "v"] ~doc) in + Arg.(value & flag & info ["verbose"; "v"] ~doc) + in let queue = let doc = "The queue name where the storage implementation is listening." in - Arg.(value & pos 0 (some string) None & info [] ~doc) in + Arg.(value & pos 0 (some string) None & info [] ~doc) + in let sr_t = let parse s = Ok (Sr.of_string s) in let print fmt s = s |> Sr.string_of |> Arg.(conv_printer string) fmt in - Arg.conv ~docv:"SR" (parse, print) in + Arg.conv ~docv:"SR" (parse, print) + in let sr = let doc = "The attached SR." in - Arg.(value & pos 1 (some sr_t) None & info [] ~doc) in - - Term.(const start $ verbose $ queue $ sr), - Term.info "test" ~doc ~man + Arg.(value & pos 1 (some sr_t) None & info [] ~doc) + in + (Term.(const start $ verbose $ queue $ sr), Term.info "test" ~doc ~man) -let () = Term.exit @@ Term.eval ~catch:true cmd \ No newline at end of file +let () = Term.exit @@ Term.eval ~catch:true cmd diff --git a/storage/suite.ml b/storage/suite.ml index 5f55a6bc..f1abefbb 100644 --- a/storage/suite.ml +++ b/storage/suite.ml @@ -1,16 +1,11 @@ - let test_parse_nbd_uri () = - let nbd = Storage_interface.{ uri = "nbd:unix:socket:exportname=disk" } in - Alcotest.(check (pair string string)) "correctly parsed NBD URI" - ("socket", "disk") + let nbd = Storage_interface.{uri= "nbd:unix:socket:exportname=disk"} in + Alcotest.(check (pair string string)) + "correctly parsed NBD URI" ("socket", "disk") (Storage_interface.parse_nbd_uri nbd) -let test_helpers = - [ "test_parse_nbd_uri", `Quick, test_parse_nbd_uri - ] +let test_helpers = [("test_parse_nbd_uri", `Quick, test_parse_nbd_uri)] let () = Alcotest.run "Storage_interface unit tests" - [ "helpers", test_helpers - ; "VDI automaton", Vdi_automaton_test.tests - ] + [("helpers", test_helpers); ("VDI automaton", Vdi_automaton_test.tests)] diff --git a/storage/vdi_automaton.ml b/storage/vdi_automaton.ml index 39c3e2ab..e36de90e 100644 --- a/storage/vdi_automaton.ml +++ b/storage/vdi_automaton.ml @@ -11,111 +11,139 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** - * @group Storage - *) - +(** @group Storage *) (** An automaton representing the VDI state machine *) type ro_rw = RO | RW [@@deriving rpcty] -let string_of_ro_rw = function - | RO -> "RO" | RW -> "RW" +let string_of_ro_rw = function RO -> "RO" | RW -> "RW" -type state = - | Detached - | Attached of ro_rw - | Activated of ro_rw +type state = Detached | Attached of ro_rw | Activated of ro_rw [@@deriving rpcty] let string_of_state = function - | Detached -> "detached" - | Attached ro_rw -> Printf.sprintf "attached %s" (string_of_ro_rw ro_rw) - | Activated ro_rw -> Printf.sprintf "activated %s" (string_of_ro_rw ro_rw) + | Detached -> + "detached" + | Attached ro_rw -> + Printf.sprintf "attached %s" (string_of_ro_rw ro_rw) + | Activated ro_rw -> + Printf.sprintf "activated %s" (string_of_ro_rw ro_rw) -let every_state = [ - Detached; - Attached RO; Attached RW; - Activated RO; Activated RW -] +let every_state = + [Detached; Attached RO; Attached RW; Activated RO; Activated RW] -type op = - | Nothing - | Attach of ro_rw - | Detach - | Activate - | Deactivate +type op = Nothing | Attach of ro_rw | Detach | Activate | Deactivate -let every_op = [ - Nothing; - Attach RO; Attach RW; - Activate; - Detach; Deactivate; -] +let every_op = [Nothing; Attach RO; Attach RW; Activate; Detach; Deactivate] let string_of_op = function - | Nothing -> "nothing" - | Attach ro_rw -> Printf.sprintf "attach(%s)" (string_of_ro_rw ro_rw) - | Detach -> "detach" - | Activate -> Printf.sprintf "activate" - | Deactivate -> "deactivate" + | Nothing -> + "nothing" + | Attach ro_rw -> + Printf.sprintf "attach(%s)" (string_of_ro_rw ro_rw) + | Detach -> + "detach" + | Activate -> + Printf.sprintf "activate" + | Deactivate -> + "deactivate" exception Bad_transition of state * op let ( + ) state operation = - let error () = raise (Bad_transition (state, operation)) in - - let ro_rw x y = match x,y with - | RO, RO -> RO - | RW, RW -> RW - | RO, RW -> error () - | RW, RO -> RW in - match state, operation with - | x, Nothing -> x - | Detached, Attach x -> Attached x - | Detached, Activate -> error () - | Detached, Deactivate -> Detached - | Detached, Detach -> Detached - | Attached x, Attach y -> Attached (ro_rw x y) - | Attached x, Activate -> Activated x - | Attached _, Detach -> Detached - | Attached x, Deactivate -> Attached x - | Activated x, Attach y -> Activated (ro_rw x y) - | Activated x, Activate -> Activated x - | Activated x, Deactivate -> Attached x - | Activated _, Detach -> error () + let error () = raise (Bad_transition (state, operation)) in + let ro_rw x y = + match (x, y) with + | RO, RO -> + RO + | RW, RW -> + RW + | RO, RW -> + error () + | RW, RO -> + RW + in + match (state, operation) with + | x, Nothing -> + x + | Detached, Attach x -> + Attached x + | Detached, Activate -> + error () + | Detached, Deactivate -> + Detached + | Detached, Detach -> + Detached + | Attached x, Attach y -> + Attached (ro_rw x y) + | Attached x, Activate -> + Activated x + | Attached _, Detach -> + Detached + | Attached x, Deactivate -> + Attached x + | Activated x, Attach y -> + Activated (ro_rw x y) + | Activated x, Activate -> + Activated x + | Activated x, Deactivate -> + Attached x + | Activated _, Detach -> + error () let superstate states = - let activated = List.fold_left (fun acc s -> - acc || (s = Activated RO) || (s = Activated RW)) false states in - let rw = List.fold_left (fun acc s -> - acc || (s = Activated RW) || (s = Attached RW)) false states in - if states = [] - then Detached - else - if activated - then Activated (if rw then RW else RO) - else Attached (if rw then RW else RO) + let activated = + List.fold_left + (fun acc s -> acc || s = Activated RO || s = Activated RW) + false states + in + let rw = + List.fold_left + (fun acc s -> acc || s = Activated RW || s = Attached RW) + false states + in + if states = [] then + Detached + else if activated then + Activated (if rw then RW else RO) + else + Attached (if rw then RW else RO) exception No_operation of state * state (* x - y = [ (op, state_on_fail)+ ] *) -let ( - ) x y = match x, y with - | Detached, Detached -> [ Nothing, Detached ] - | Attached RO, Attached RO -> [ Nothing, Attached RO ] - | Activated RO, Activated RO -> [ Nothing, Activated RO ] - | Attached RW, Attached RW -> [ Nothing, Attached RW ] - | Activated RW, Activated RW -> [ Nothing, Activated RW ] - | Attached r, Detached -> [ Detach, Attached r ] - | Activated RO, Attached RO -> [ Deactivate, Activated RO ] - | Activated RW, Attached RW -> [ Deactivate, Activated RW ] - | Activated r, Detached -> [ Deactivate, Activated r; Detach, Attached r ] - | Detached, Attached RO -> [ Attach RO, Detached ] - | Detached, Attached RW -> [ Attach RW, Detached ] - | Detached, Activated RO -> [ Attach RO, Detached; Activate, Attached RO ] - | Detached, Activated RW -> [ Attach RW, Detached; Activate, Attached RW ] - | Attached RO, Activated RO -> [ Activate, Attached RO ] - | Attached RW, Activated RW -> [ Activate, Attached RW ] - | _, _ -> raise (No_operation (x, y)) - +let ( - ) x y = + match (x, y) with + | Detached, Detached -> + [(Nothing, Detached)] + | Attached RO, Attached RO -> + [(Nothing, Attached RO)] + | Activated RO, Activated RO -> + [(Nothing, Activated RO)] + | Attached RW, Attached RW -> + [(Nothing, Attached RW)] + | Activated RW, Activated RW -> + [(Nothing, Activated RW)] + | Attached r, Detached -> + [(Detach, Attached r)] + | Activated RO, Attached RO -> + [(Deactivate, Activated RO)] + | Activated RW, Attached RW -> + [(Deactivate, Activated RW)] + | Activated r, Detached -> + [(Deactivate, Activated r); (Detach, Attached r)] + | Detached, Attached RO -> + [(Attach RO, Detached)] + | Detached, Attached RW -> + [(Attach RW, Detached)] + | Detached, Activated RO -> + [(Attach RO, Detached); (Activate, Attached RO)] + | Detached, Activated RW -> + [(Attach RW, Detached); (Activate, Attached RW)] + | Attached RO, Activated RO -> + [(Activate, Attached RO)] + | Attached RW, Activated RW -> + [(Activate, Attached RW)] + | _, _ -> + raise (No_operation (x, y)) diff --git a/storage/vdi_automaton_test.ml b/storage/vdi_automaton_test.ml index c1bddb81..0faf3955 100644 --- a/storage/vdi_automaton_test.ml +++ b/storage/vdi_automaton_test.ml @@ -12,28 +12,26 @@ * GNU Lesser General Public License for more details. *) -(* For any state [s] and operation [o] where [s' = s + o], - [if s <> s' then s - s' = op] *) +(* For any state [s] and operation [o] where [s' = s + o], [if s <> s' then s - + s' = op] *) let all_pairs x y = - List.fold_left (fun acc x -> List.map (fun y -> x, y) y @ acc) [] x + List.fold_left (fun acc x -> List.map (fun y -> (x, y)) y @ acc) [] x let run () = List.iter (fun (s, op) -> - try - let s' = Vdi_automaton.(s + op) in - let op' = List.map fst Vdi_automaton.(s - s') in - if s <> s' && [ op ] <> op' then - failwith Vdi_automaton.( - Printf.sprintf "s = %s; op = %s; s + op = %s; s - (s + op) = %s" - (string_of_state s) - (string_of_op op) - (string_of_state s') - (String.concat ", " (List.map string_of_op op'))) - with Vdi_automaton.Bad_transition(_, _) -> () - ) (all_pairs Vdi_automaton.every_state Vdi_automaton.every_op); - Printf.printf "Passed." + try + let s' = Vdi_automaton.(s + op) in + let op' = List.map fst Vdi_automaton.(s - s') in + if s <> s' && [op] <> op' then + failwith + Vdi_automaton.( + Printf.sprintf "s = %s; op = %s; s + op = %s; s - (s + op) = %s" + (string_of_state s) (string_of_op op) (string_of_state s') + (String.concat ", " (List.map string_of_op op'))) + with Vdi_automaton.Bad_transition (_, _) -> ()) + (all_pairs Vdi_automaton.every_state Vdi_automaton.every_op) ; + Printf.printf "Passed." -let tests = - [ "VDI automaton test", `Quick, run ] +let tests = [("VDI automaton test", `Quick, run)] diff --git a/v6/dune b/v6/dune index 88af0f49..8cf782c6 100644 --- a/v6/dune +++ b/v6/dune @@ -1,42 +1,27 @@ -(* -*- tuareg -*- *) - -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - (library - (name xcp_v6) - (public_name xapi-idl.v6) - (flags (:standard -w -39)) - (modules (:standard \ v6_cli )) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) -) + (name xcp_v6) + (public_name xapi-idl.v6) + (flags (:standard -w -39)) + (modules (:standard \ v6_cli)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name v6_cli) - (modules v6_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.v6 - ) -) - -(alias - (name runtest) - (deps (:x v6_cli.exe)) - (action (run %%{x})) -) + (name v6_cli) + (modules v6_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.v6 + )) -|} coverage_rewriter +(rule + (alias runtest) + (deps (:x v6_cli.exe)) + (action (run %{x}))) diff --git a/v6/v6_cli.ml b/v6/v6_cli.ml index e3ec72b6..3d869938 100644 --- a/v6/v6_cli.ml +++ b/v6/v6_cli.ml @@ -1,25 +1,28 @@ (* Licensing CLI *) -module Cmds =V6_interface.RPC_API(Cmdlinergen.Gen ()) +module Cmds = V6_interface.RPC_API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the V6d API. This allows scripting of the licensing daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "licensing_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the V6d API. This allows scripting of the licensing daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "licensing_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli () = let rpc = V6_client.rpc in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) - -let _ = - match cli () with - | `Ok f -> f () - | _ -> () + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) +let _ = match cli () with `Ok f -> f () | _ -> () diff --git a/v6/v6_client.ml b/v6/v6_client.ml index 486b0d52..41201980 100644 --- a/v6/v6_client.ml +++ b/v6/v6_client.ml @@ -16,27 +16,32 @@ open V6_interface open Xcp_client let retry_econnrefused f = - let rec loop retry = - let result = - try - Some (f ()) - with Unix.Unix_error((Unix.ECONNREFUSED | Unix.ENOENT), _, _) -> - Thread.delay 1.; - None in - match result with - | Some x -> x - | None -> if retry then loop false else raise (V6_error V6d_failure) - in - loop true - + let rec loop retry = + let result = + try Some (f ()) + with Unix.Unix_error ((Unix.ECONNREFUSED | Unix.ENOENT), _, _) -> + Thread.delay 1. ; None + in + match result with + | Some x -> + x + | None -> + if retry then loop false else raise (V6_error V6d_failure) + in + loop true let json_url () = "file:" ^ json_path + let xml_url () = "file:" ^ xml_path let rpc call = - if !use_switch - then json_switch_rpc !queue_name call - else xml_http_rpc ~srcstr:"xapi" ~dststr:"v6d" xml_url call + if !use_switch then + json_switch_rpc !queue_name call + else + xml_http_rpc ~srcstr:"xapi" ~dststr:"v6d" xml_url call + +module Client = V6_interface.RPC_API (Idl.Exn.GenClient (struct + let rpc = rpc +end)) -module Client = V6_interface.RPC_API(Idl.Exn.GenClient(struct let rpc=rpc end)) include Client diff --git a/v6/v6_interface.ml b/v6/v6_interface.ml index 83a7b099..11ba7eeb 100644 --- a/v6/v6_interface.ml +++ b/v6/v6_interface.ml @@ -12,157 +12,172 @@ * GNU Lesser General Public License for more details. *) -(** - @group Licensing -*) +(** @group Licensing *) open Rpc + open Idl -module D = Debug.Make(struct let name = "v6_interface" end) +module D = Debug.Make (struct let name = "v6_interface" end) + open D let service_name = "v6d" + let queue_name = ref (Xcp_service.common_prefix ^ service_name) + let default_sockets_dir = "/var/lib/xcp" + let default_path = ref (Filename.concat default_sockets_dir service_name) + let uri () = "file:" ^ !default_path + let json_path = "/var/xapi/v6.json" + let xml_path = "/var/xapi/v6" (** Uninterpreted/sanitised string associated with operation *) -type debug_info = string -[@@deriving rpcty] +type debug_info = string [@@deriving rpcty] (** Record representing software edition *) -type edition = - { - title : string ; - (** Name of edition, this will be passed to apply_edition *) - official_title : string ; - (** Marketing title used to advertise edition *) - code : string ; - (** Abbreviated form of name, used to show up in logs and on command line *) - order : int ; - (** Number indicating ordering among other editions; - low numbers correspond to fewer features, and vice versa *) - } +type edition = { + title: string (** Name of edition, this will be passed to apply_edition *) + ; official_title: string (** Marketing title used to advertise edition *) + ; code: string + (** Abbreviated form of name, used to show up in logs and on command + line *) + ; order: int + (** Number indicating ordering among other editions; low numbers + correspond to fewer features, and vice versa *) +} [@@deriving rpcty] (** List of edition records *) -type edition_list = edition list -[@@deriving rpcty] +type edition_list = edition list [@@deriving rpcty] (** Record of edition info, including xapi parameters and features *) -type edition_info = - { - edition_name: string; - (** Name of edition *) - xapi_params: (string * string) list; - (** List of parameters used by Xapi *) - additional_params: (string * string) list; - (** Addition parameters supplied *) - experimental_features: (string * bool) list; - (** List of experimental features and whether they're available in this edition *) - } +type edition_info = { + edition_name: string (** Name of edition *) + ; xapi_params: (string * string) list (** List of parameters used by Xapi *) + ; additional_params: (string * string) list + (** Addition parameters supplied *) + ; experimental_features: (string * bool) list + (** List of experimental features and whether they're available in this + edition *) +} [@@deriving rpcty] (** [string * string] list *) -type string_pair_lst = (string * string) list -[@@deriving rpcty] +type string_pair_lst = (string * string) list [@@deriving rpcty] (** Wrapper for specific errors in managing features *) type errors = | Invalid_edition of string - (** Thrown by apply_edition on receiving unfamiliar edition. - * Note: get_editions returns list of all valid editions *) + (** Thrown by apply_edition on receiving unfamiliar edition. Note: + get_editions returns list of all valid editions *) | License_expired - (** Thrown by license_check when expiry date matches or precedes current date *) - | License_processing_error - (** License could not be processed *) - | License_checkout_error of string - (** License could not be checked out *) + (** Thrown by license_check when expiry date matches or precedes current + date *) + | License_processing_error (** License could not be processed *) + | License_checkout_error of string (** License could not be checked out *) | Missing_connection_details - (** Thrown if connection port or address parameter not supplied to check_license *) - | V6d_failure - (** Daemon failed to enable features *) + (** Thrown if connection port or address parameter not supplied to + check_license *) + | V6d_failure (** Daemon failed to enable features *) | Internal_error of string - (** Exception raised if an unexpected error is triggered by the library *) -[@@default V6d_failure] -[@@deriving rpcty] + (** Exception raised if an unexpected error is triggered by the library *) +[@@default V6d_failure] [@@deriving rpcty] (** Pass error variant as exn for error handler *) exception V6_error of errors -let () = (* register printer *) +let () = + (* register printer *) let sprintf = Printf.sprintf in let string_of_error e = - Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | V6_error e -> Some (sprintf "V6_interface.V6_error(%s)" (string_of_error e)) - | _ -> None in + | _ -> + None + in Printexc.register_printer printer (** handle exception generation and raising *) -let err = Error. - { def = errors - ; raiser = (fun e -> - log_backtrace (); - let exn = V6_error e in - error "%s (%s)" (Printexc.to_string exn) __LOC__; - raise exn) - ; matcher = (function - | V6_error e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; +let err = + Error. + { + def= errors + ; raiser= + (fun e -> + log_backtrace () ; + let exn = V6_error e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) + ; matcher= + (function + | V6_error e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some (Internal_error (Printexc.to_string exn))) } (** functor to autogenerate code using PPX *) -module RPC_API(R : RPC) = struct +module RPC_API (R : RPC) = struct open R (* description of V6d interface module *) - let description = Interface.{ - name = "Licensing"; - namespace = None; - description = - [ - "This interface is used by Xapi and V6d to manage " - ; "enabling and disabling features." - ]; - version=(1,0,0); } + let description = + Interface. + { + name= "Licensing" + ; namespace= None + ; description= + [ + "This interface is used by Xapi and V6d to manage " + ; "enabling and disabling features." + ] + ; version= (1, 0, 0) + } (* define implementation *) let implementation = implement description (* define general parameters for API calls *) - let debug_info_p = Param.mk ~description:[ - "An uninterpreted string to associate with the operation." - ] debug_info + let debug_info_p = + Param.mk + ~description:["An uninterpreted string to associate with the operation."] + debug_info (* ---- API call definitions ---- *) let apply_edition = let edition_p = Param.mk ~description:["Edition title"] Types.string in let edition_info_p = Param.mk ~description:["Edition info"] edition_info in - let current_params_p = Param.mk ~description:["Xapi parameters"] string_pair_lst in + let current_params_p = + Param.mk ~description:["Xapi parameters"] string_pair_lst + in declare "apply_edition" ["Checks license info to ensures enabled features are compatible."] - ( debug_info_p @-> edition_p @-> current_params_p @-> returning edition_info_p err ) + (debug_info_p + @-> edition_p + @-> current_params_p + @-> returning edition_info_p err + ) let get_editions = - let edition_list_p = Param.mk ~description:["List of editions"] edition_list in + let edition_list_p = + Param.mk ~description:["List of editions"] edition_list + in declare "get_editions" ["Gets list of accepted editions."] - ( debug_info_p @-> returning edition_list_p err ) + (debug_info_p @-> returning edition_list_p err) let get_version = let result_p = Param.mk ~description:["String of version."] Types.string in - declare "get_version" - ["Returns version"] - ( debug_info_p @-> returning result_p err ) - + declare "get_version" ["Returns version"] + (debug_info_p @-> returning result_p err) end diff --git a/varstore/deprivileged/dune b/varstore/deprivileged/dune index 42659e20..0722d5df 100644 --- a/varstore/deprivileged/dune +++ b/varstore/deprivileged/dune @@ -1,22 +1,28 @@ (library - (name xapi_idl_varstore_deprivileged) - (public_name xapi-idl.varstore.deprivileged) - (modules (:standard \ varstore_deprivileged_cli)) - (flags (:standard -w -39)) - (libraries xcp threads rpclib.core xapi-idl.xen) - (wrapped false) - (preprocess (pps ppx_deriving_rpc))) + (name xapi_idl_varstore_deprivileged) + (public_name xapi-idl.varstore.deprivileged) + (modules (:standard \ varstore_deprivileged_cli)) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl.xen + xcp + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name varstore_deprivileged_cli) - (modules varstore_deprivileged_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.varstore.deprivileged)) + (name varstore_deprivileged_cli) + (modules varstore_deprivileged_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.varstore.deprivileged + )) -(alias - (name runtest) - (deps varstore_deprivileged_cli.exe) +(rule + (alias runtest) + (deps varstore_deprivileged_cli.exe) (action (run %{deps}))) diff --git a/varstore/deprivileged/varstore_deprivileged_cli.ml b/varstore/deprivileged/varstore_deprivileged_cli.ml index 7361d472..b4a582fd 100644 --- a/varstore/deprivileged/varstore_deprivileged_cli.ml +++ b/varstore/deprivileged/varstore_deprivileged_cli.ml @@ -21,7 +21,9 @@ let version_str description = let default_cmd = let doc = "debug CLI" in ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) - , Cmdliner.Term.info "varstored_cli" ~version:(version_str Cmds.description) ~doc ) + , Cmdliner.Term.info "varstored_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli = let uri = ref "" in @@ -33,19 +35,19 @@ let cli = call in let wrapper file next = - uri := "file://" ^ file; + uri := "file://" ^ file ; next in let doc = "Path to deprivileged socket in /var/run/xen" in let path = - Cmdliner.Arg.(required & opt (some file) None & info ["socket"] ~doc ~docv:"SOCKET") + Cmdliner.Arg.( + required & opt (some file) None & info ["socket"] ~doc ~docv:"SOCKET") in - Cmdliner.Term.eval_choice - default_cmd + Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> let term, info = t rpc in - Cmdliner.Term.(const wrapper $ path $ term $ const ()), info ) + (Cmdliner.Term.(const wrapper $ path $ term $ const ()), info)) (Cmds.implementation ())) let () = Cmdliner.Term.exit cli diff --git a/varstore/deprivileged/varstore_deprivileged_interface.ml b/varstore/deprivileged/varstore_deprivileged_interface.ml index dde8b0ae..e418dc4d 100644 --- a/varstore/deprivileged/varstore_deprivileged_interface.ml +++ b/varstore/deprivileged/varstore_deprivileged_interface.ml @@ -22,65 +22,73 @@ type nvram = (string * string) list [@@deriving rpcty] module RPC_API (R : RPC) = struct open R - (* A restricted interface to VM's NVRAM, varstored is sandboxed and has no direct access to XAPI *) + (* A restricted interface to VM's NVRAM, varstored is sandboxed and has no + direct access to XAPI *) let description = let open Interface in - { name = "Xenopsd_varstored" - ; namespace = None - ; description = + { + name= "Xenopsd_varstored" + ; namespace= None + ; description= ["This interface is used by varstored to set VM NVRAM and send alerts"] - ; version = 0, 1, 0 } + ; version= (0, 1, 0) + } let implementation = implement description + let unit_p = Param.mk ~name:"unit" Types.unit + let nvram_p = Param.mk ~name:"NVRAM" nvram + let string_p = Param.mk Types.string + let int64_p = Param.mk Types.int64 - (* The APIs here should be wire-compatible with the ones in XAPI, - * but ignore the parameters that varstored is not allowed to override, - * e.g. the VM ref or session id. - * The parameters cannot be named *) + (* The APIs here should be wire-compatible with the ones in XAPI, but ignore + the parameters that varstored is not allowed to override, e.g. the VM ref + or session id. + + The parameters cannot be named *) let session_login = - declare - "session.login_with_password" + declare "session.login_with_password" ["Dummy, for wire compatibility with XAPI"] - (string_p @-> string_p @-> string_p @-> string_p @-> returning string_p err) + (string_p + @-> string_p + @-> string_p + @-> string_p + @-> returning string_p err + ) let session_logout = - declare - "session.logout" + declare "session.logout" ["Dummy, for wire compatibility with XAPI"] (string_p @-> returning unit_p err) let get_by_uuid = - declare - "VM.get_by_uuid" + declare "VM.get_by_uuid" ["Dummy, for wire compatibility with XAPI"] (string_p @-> string_p @-> returning string_p err) let get_NVRAM = - declare - "VM.get_NVRAM" + declare "VM.get_NVRAM" ["Get the current VM's NVRAM contents"] (string_p @-> string_p @-> returning nvram_p err) let set_NVRAM = - declare - "VM.set_NVRAM_EFI_variables" + declare "VM.set_NVRAM_EFI_variables" ["Set the current VM's NVRAM contents"] (string_p @-> string_p @-> string_p @-> returning unit_p err) let message_create = - declare - "message.create" + declare "message.create" ["Send an alert when booting a UEFI guest fails"] - ( string_p + (string_p @-> string_p @-> int64_p @-> string_p @-> string_p @-> string_p - @-> returning unit_p err ) + @-> returning unit_p err + ) end diff --git a/varstore/privileged/dune b/varstore/privileged/dune index c79ef6b5..5c8d8832 100644 --- a/varstore/privileged/dune +++ b/varstore/privileged/dune @@ -1,22 +1,27 @@ (library - (name xapi_idl_varstore_privileged) - (public_name xapi-idl.varstore.privileged) - (modules (:standard \ varstore_privileged_cli)) - (flags (:standard -w -39)) - (libraries xcp threads rpclib.core) - (wrapped false) - (preprocess (pps ppx_deriving_rpc))) + (name xapi_idl_varstore_privileged) + (public_name xapi-idl.varstore.privileged) + (modules (:standard \ varstore_privileged_cli)) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xcp + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name varstore_privileged_cli) - (modules varstore_privileged_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.varstore.privileged)) + (name varstore_privileged_cli) + (modules varstore_privileged_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.varstore.privileged + )) -(alias - (name runtest) - (deps varstore_privileged_cli.exe) +(rule + (alias runtest) + (deps varstore_privileged_cli.exe) (action (run %{deps}))) diff --git a/varstore/privileged/varstore_privileged_cli.ml b/varstore/privileged/varstore_privileged_cli.ml index 087642a6..c0d84c79 100644 --- a/varstore/privileged/varstore_privileged_cli.ml +++ b/varstore/privileged/varstore_privileged_cli.ml @@ -13,6 +13,7 @@ *) open Varstore_privileged_interface + module Cmds = RPC_API (Cmdlinergen.Gen ()) let version_str description = @@ -21,23 +22,29 @@ let version_str description = let default_cmd = let doc = - String.concat - " " - [ "A CLI for the deprivileged socket spawning API." + String.concat " " + [ + "A CLI for the deprivileged socket spawning API." ; "This allows scripting of the varstored deprivileging daemon" ; "for testing and debugging. This tool is not intended to be used" - ; "as an end user tool" ] + ; "as an end user tool" + ] in ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) - , Cmdliner.Term.info "varstore_cli" ~version:(version_str Cmds.description) ~doc ) + , Cmdliner.Term.info "varstore_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli () = match - Cmdliner.Term.eval_choice - default_cmd - (List.map (fun t -> t Varstore_privileged_client.rpc) (Cmds.implementation ())) + Cmdliner.Term.eval_choice default_cmd + (List.map + (fun t -> t Varstore_privileged_client.rpc) + (Cmds.implementation ())) with - | `Ok f -> f () - | _ -> () + | `Ok f -> + f () + | _ -> + () let _ = cli () diff --git a/varstore/privileged/varstore_privileged_client.ml b/varstore/privileged/varstore_privileged_client.ml index d8b45011..19391476 100644 --- a/varstore/privileged/varstore_privileged_client.ml +++ b/varstore/privileged/varstore_privileged_client.ml @@ -17,6 +17,4 @@ open Varstore_privileged_interface (* daemon only listens on message-switch *) let rpc call = Xcp_client.json_switch_rpc ~timeout:20 queue_name call -module Client = RPC_API (Idl.Exn.GenClient (struct - let rpc = rpc -end)) +module Client = RPC_API (Idl.Exn.GenClient (struct let rpc = rpc end)) diff --git a/varstore/privileged/varstore_privileged_interface.ml b/varstore/privileged/varstore_privileged_interface.ml index c89b5ca0..8330a4c7 100644 --- a/varstore/privileged/varstore_privileged_interface.ml +++ b/varstore/privileged/varstore_privileged_interface.ml @@ -12,18 +12,18 @@ * GNU Lesser General Public License for more details. *) -(** Varstored is deprivileged and should not have full access to XAPI. - This interface provides a way to spawn a new listening socket - restricted to a small number of API calls targeting only 1 VM. - Xenopsd is a client of this interface and calls it through message-switch. - A new privileged daemon (varstored-socket-deprivd) implements the interface - and spawns the listening sockets. - *) +(** Varstored is deprivileged and should not have full access to XAPI. This + interface provides a way to spawn a new listening socket restricted to a + small number of API calls targeting only 1 VM. Xenopsd is a client of this + interface and calls it through message-switch. A new privileged daemon + (varstored-socket-deprivd) implements the interface and spawns the listening + sockets. *) open Rpc open Idl let service_name = "xapi_depriv" + let queue_name = Xcp_service.common_prefix ^ service_name type error = InternalError of string [@@deriving rpcty] @@ -40,22 +40,28 @@ module Uuidm = struct (** Validate UUIDs by converting them to Uuidm.t in the API *) let typ_of = Rpc.Types.Abstract - { aname = "uuid" - ; test_data = [Uuidm.v `V4] - ; rpc_of = (fun t -> Rpc.String (Uuidm.to_string t)) - ; of_rpc = + { + aname= "uuid" + ; test_data= [Uuidm.v `V4] + ; rpc_of= (fun t -> Rpc.String (Uuidm.to_string t)) + ; of_rpc= (function - | Rpc.String s -> - (match Uuidm.of_string s with - | Some uuid -> Ok uuid + | Rpc.String s -> ( + match Uuidm.of_string s with + | Some uuid -> + Ok uuid | None -> - Error (`Msg (Printf.sprintf "typ_of_vm_uuid: not a valid UUID: %s" s))) + Error + (`Msg + (Printf.sprintf "typ_of_vm_uuid: not a valid UUID: %s" s)) + ) | r -> - Error - (`Msg - (Printf.sprintf - "typ_of_vm_uuid: expected rpc string but got %s" - (Rpc.to_string r)))) } + Error + (`Msg + (Printf.sprintf + "typ_of_vm_uuid: expected rpc string but got %s" + (Rpc.to_string r)))) + } end type vm_uuid = Uuidm.t [@@deriving rpcty] @@ -65,25 +71,29 @@ module RPC_API (R : RPC) = struct let description = Interface. - { name = "Depriv" - ; namespace = None - ; description = - ["Interface for creating a deprivileged XAPI socket for a specific VM."] - ; version = 1, 0, 0 } + { + name= "Depriv" + ; namespace= None + ; description= + [ + "Interface for creating a deprivileged XAPI socket for a specific \ + VM." + ] + ; version= (1, 0, 0) + } let implementation = implement description (** An uninterpreted string associated with the operation. *) - type debug_info = string - [@@deriving rpcty] + type debug_info = string [@@deriving rpcty] let debug_info_p = - Param.mk - ~name:"dbg" + Param.mk ~name:"dbg" ~description:["An uninterpreted string to associate with the operation."] debug_info let err = E.error + let unit_p = Param.mk Types.unit let path_p = @@ -94,15 +104,15 @@ module RPC_API (R : RPC) = struct let create = let vm_uuid_p = Param.mk ~name:"vm_uuid" ~description:["VM UUID"] vm_uuid in - declare - "create" - [ "Create a deprivileged socket that only accepts API calls for a" - ; "specific VM. The socket will be writable only to the specified group." ] + declare "create" + [ + "Create a deprivileged socket that only accepts API calls for a" + ; "specific VM. The socket will be writable only to the specified group." + ] (debug_info_p @-> vm_uuid_p @-> gid_p @-> path_p @-> returning unit_p err) let destroy = - declare - "destroy" + declare "destroy" ["Stop listening on sockets for the specified group"] (debug_info_p @-> gid_p @-> path_p @-> returning unit_p err) end diff --git a/xapi-idl.opam b/xapi-idl.opam index 5efca903..92c0d91c 100644 --- a/xapi-idl.opam +++ b/xapi-idl.opam @@ -17,8 +17,10 @@ depends: [ "cohttp" "fd-send-recv" "logs" + "lwt" {>= "5.0.0"} "message-switch-core" "message-switch-unix" + "mtime" "ocaml-migrate-parsetree" "ppx_deriving_rpc" "ppx_sexp_conv" @@ -30,7 +32,6 @@ depends: [ "uri" "xapi-backtrace" "xapi-stdext-date" - "xapi-stdext-monadic" "xapi-stdext-pervasives" "xapi-stdext-threads" "xapi-inventory" diff --git a/xcp.opam b/xcp.opam deleted file mode 100644 index beef5866..00000000 --- a/xcp.opam +++ /dev/null @@ -1,12 +0,0 @@ -opam-version: "2.0" -name: "xcp" -authors: "Dave Scott" -homepage: "https://github.com/xapi-project/xcp-idl" -bug-reports: "https://github.com/xapi-project/xcp-idl/issues" -dev-repo: "git://github.com/xapi-project/xcp-idl" -maintainer: "xen-api@lists.xen.org" -tags: [ "org:xapi-project" ] -depends: ["ocaml" "xapi-idl"] -synopsis: "Interface descriptions and common boilerplate for xapi services" -description: """ -This package has been renamed to 'xapi-idl' and can safely be removed""" diff --git a/xen/device_number.ml b/xen/device_number.ml index 49a08e04..6e8c7d47 100644 --- a/xen/device_number.ml +++ b/xen/device_number.ml @@ -1,192 +1,227 @@ -type bus_type = - | Xen - | Scsi - | Floppy - | Ide -[@@deriving rpcty] +type bus_type = Xen | Scsi | Floppy | Ide [@@deriving rpcty] type spec = bus_type * int * int [@@deriving rpcty] type t = spec [@@deriving rpcty] let to_debug_string = function - | (Xen, disk, partition) -> Printf.sprintf "Xen(%d, %d)" disk partition - | (Scsi, disk, partition) -> Printf.sprintf "Scsi(%d, %d)" disk partition - | (Floppy, disk, partition) -> Printf.sprintf "Floppy(%d, %d)" disk partition - | (Ide , disk, partition) -> Printf.sprintf "Ide(%d, %d)" disk partition + | Xen, disk, partition -> + Printf.sprintf "Xen(%d, %d)" disk partition + | Scsi, disk, partition -> + Printf.sprintf "Scsi(%d, %d)" disk partition + | Floppy, disk, partition -> + Printf.sprintf "Floppy(%d, %d)" disk partition + | Ide, disk, partition -> + Printf.sprintf "Ide(%d, %d)" disk partition (* ocamlp4-friendly operators *) -let (<|) = (lsl) -let (>|) = (lsr) +let ( <| ) = ( lsl ) -let int_of_string x = try int_of_string x with _ -> failwith (Printf.sprintf "int_of_string [%s]" x) +let ( >| ) = ( lsr ) -(* If this is true then we will use the deprecated (linux-specific) IDE encodings for disks > 3 *) +let int_of_string x = + try int_of_string x + with _ -> failwith (Printf.sprintf "int_of_string [%s]" x) + +(* If this is true then we will use the deprecated (linux-specific) IDE + encodings for disks > 3 *) let use_deprecated_ide_encoding = true -let make (x: spec) : t = - let max_xen = ((1 <| 20) - 1), 15 in - let max_scsi = 15, 15 in - let max_ide = if use_deprecated_ide_encoding then 19, 63 else 3, 63 in - let max_floppy = 2, 0 in - let assert_in_range description (disk_limit, partition_limit) (disk, partition) = - if disk < 0 || (disk > disk_limit) - then failwith (Printf.sprintf "%s disk number out of range 0 <= %d <= %d" description disk disk_limit); - if partition < 0 || partition > partition_limit - then failwith (Printf.sprintf "%s partition number out of range 0 <= %d <= %d" description partition partition_limit) in - begin match x with - | Xen, disk, partition -> assert_in_range "xen" max_xen (disk, partition) - | Scsi, disk, partition -> assert_in_range "scsi" max_scsi (disk, partition) - | Floppy, disk, partition -> assert_in_range "floppy" max_floppy (disk, partition) - | Ide, disk, partition -> assert_in_range "ide" max_ide (disk, partition) - end; - x - -let spec (x: t) : spec = x - -let (||) = (lor) - -let standard_ide_table = [ 3; 22 ] -let deprecated_ide_table = standard_ide_table @ [ 33; 34; 56; 57; 88; 89; 90; 91 ] +let make (x : spec) : t = + let max_xen = ((1 <| 20) - 1, 15) in + let max_scsi = (15, 15) in + let max_ide = if use_deprecated_ide_encoding then (19, 63) else (3, 63) in + let max_floppy = (2, 0) in + let assert_in_range description (disk_limit, partition_limit) (disk, partition) + = + if disk < 0 || disk > disk_limit then + failwith + (Printf.sprintf "%s disk number out of range 0 <= %d <= %d" description + disk disk_limit) ; + if partition < 0 || partition > partition_limit then + failwith + (Printf.sprintf "%s partition number out of range 0 <= %d <= %d" + description partition partition_limit) + in + ( match x with + | Xen, disk, partition -> + assert_in_range "xen" max_xen (disk, partition) + | Scsi, disk, partition -> + assert_in_range "scsi" max_scsi (disk, partition) + | Floppy, disk, partition -> + assert_in_range "floppy" max_floppy (disk, partition) + | Ide, disk, partition -> + assert_in_range "ide" max_ide (disk, partition) + ) ; + x + +let spec (x : t) : spec = x + +let ( || ) = ( lor ) + +let standard_ide_table = [3; 22] + +let deprecated_ide_table = standard_ide_table @ [33; 34; 56; 57; 88; 89; 90; 91] let to_xenstore_int = function - | Xen, disk, partition when disk < 16 -> (202 <| 8) || (disk <| 4) || partition - | Xen, disk, partition -> (1 <| 28) || (disk <| 8) || partition - | Scsi, disk, partition -> (8 <| 8) || (disk <| 4) || partition - | Floppy, disk, partition -> (203 <| 8) || (disk <| 4) || partition - | Ide, disk, partition -> - let m = List.nth deprecated_ide_table (disk / 2) in - let n = disk - (disk / 2) * 2 in (* NB integers behave differently to reals *) - (m <| 8) || (n <| 6) || partition + | Xen, disk, partition when disk < 16 -> + 202 <| 8 || disk <| 4 || partition + | Xen, disk, partition -> + 1 <| 28 || disk <| 8 || partition + | Scsi, disk, partition -> + 8 <| 8 || disk <| 4 || partition + | Floppy, disk, partition -> + 203 <| 8 || disk <| 4 || partition + | Ide, disk, partition -> + let m = List.nth deprecated_ide_table (disk / 2) in + let n = disk - (disk / 2 * 2) in + (* NB integers behave differently to reals *) + m <| 8 || n <| 6 || partition let of_xenstore_int x = - let (&&) = (land) in - - if (x && (1 <| 28)) <> 0 - then Xen, (x >| 8) && ((1 <| 20) - 1), x && ((1 <| 8) - 1) - else match x >| 8 with - | 202 -> Xen, (x >| 4) && ((1 <| 4) - 1), x && ((1 <| 4) - 1) - | 8 -> Scsi, (x >| 4) && ((1 <| 4) - 1), x && ((1 <| 4) - 1) - | 203 -> Floppy, (x >| 4) && ((1 <| 4) - 1), x && ((1 <| 4) - 1) - | n -> - let idx = snd(List.fold_left (fun (i, res) e -> i+1, if e = n then i else res) (0, -1) deprecated_ide_table) in - if idx < 0 - then failwith (Printf.sprintf "Unknown device number: %d" x); - Ide, ((x >| 6) && ((1 <| 2) - 1)) + idx * 2, x && ((1 <| 6) - 1) + let ( && ) = ( land ) in + if (x && 1 <| 28) <> 0 then + (Xen, x >| 8 && ((1 <| 20) - 1), x && ((1 <| 8) - 1)) + else + match x >| 8 with + | 202 -> + (Xen, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + | 8 -> + (Scsi, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + | 203 -> + (Floppy, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + | n -> + let idx = + snd + (List.fold_left + (fun (i, res) e -> (i + 1, if e = n then i else res)) + (0, -1) deprecated_ide_table) + in + if idx < 0 then failwith (Printf.sprintf "Unknown device number: %d" x) ; + (Ide, (x >| 6 && ((1 <| 2) - 1)) + (idx * 2), x && ((1 <| 6) - 1)) type xenstore_key = int let to_xenstore_key x = to_xenstore_int x + let of_xenstore_key x = of_xenstore_int x -(* NB the device encoding is base 26 starting from 1 rather than 0 eg - 0 -> a - 25 -> z - 26 -> aa -*) +(* NB the device encoding is base 26 starting from 1 rather than 0 eg 0 -> a 25 + -> z 26 -> aa *) (** Return an integer encoded as a linux device suffix *) -let rec string_of_int26 x = - let high, low = x / 26 - 1, x mod 26 + 1 in - let high' = if high = -1 then "" else string_of_int26 high in - let low' = String.make 1 (char_of_int (low + (int_of_char 'a') - 1)) in - high' ^ low' +let rec string_of_int26 x = + let high, low = ((x / 26) - 1, (x mod 26) + 1) in + let high' = if high = -1 then "" else string_of_int26 high in + let low' = String.make 1 (char_of_int (low + int_of_char 'a' - 1)) in + high' ^ low' module String = struct - include String - let fold_right f string accu = - let accu = ref accu in - for i = length string - 1 downto 0 do - accu := f string.[i] !accu - done; - !accu - - let explode string = - fold_right (fun h t -> h :: t) string [] - - let implode list = - concat "" (List.map (String.make 1) list) + include String + + let fold_right f string accu = + let accu = ref accu in + for i = length string - 1 downto 0 do + accu := f string.[i] !accu + done ; + !accu + + let explode string = fold_right (fun h t -> h :: t) string [] + + let implode list = concat "" (List.map (String.make 1) list) end (** Convert a linux device string back into an integer *) -let int26_of_string x = - let ints = List.map (fun c -> int_of_char c - (int_of_char 'a') + 1) (String.explode x) in - List.fold_left (fun acc x -> acc * 26 + x) 0 ints - 1 - -let to_linux_device = - let p x = if x = 0 then "" else string_of_int x in - function - | Xen, disk, part -> Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) - | Scsi, disk, part -> Printf.sprintf "sd%s%s" (string_of_int26 disk) (p part) - | Floppy, disk, part -> Printf.sprintf "fd%s%s" (string_of_int26 disk) (p part) - | Ide, disk, part -> Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) +let int26_of_string x = + let ints = + List.map (fun c -> int_of_char c - int_of_char 'a' + 1) (String.explode x) + in + List.fold_left (fun acc x -> (acc * 26) + x) 0 ints - 1 + +let to_linux_device = + let p x = if x = 0 then "" else string_of_int x in + function + | Xen, disk, part -> + Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) + | Scsi, disk, part -> + Printf.sprintf "sd%s%s" (string_of_int26 disk) (p part) + | Floppy, disk, part -> + Printf.sprintf "fd%s%s" (string_of_int26 disk) (p part) + | Ide, disk, part -> + Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) let of_linux_device x = - let letter c = 'a' <= c && (c <= 'z') in - let digit c = '0' <= c && (c <= '9') in - let take f x = - let rec inner f acc = function - | x :: xs -> - if f x then inner f (x :: acc) xs else List.rev acc, x :: xs - | [] -> List.rev acc, [] in - inner f [] x in - (* Parse a string "abc123" into x, y where x is "abc" interpreted as base-26 - and y is 123 *) - let parse_b26_int x = - let d, p = take letter x in - let d' = int26_of_string (String.implode d) in - let p' = if p = [] then 0 else int_of_string (String.implode p) in - d', p' in - (* Parse a string "123p456" into x, y where x = 123 and y = 456 *) - let parse_int_p_int x = - let d, rest = take digit x in - match rest with - | 'p' :: rest -> - let p, _ = take digit rest in - int_of_string (String.implode d), int_of_string (String.implode p) - | [] -> - int_of_string (String.implode d), 0 - | _ -> - failwith - (Printf.sprintf "expected digit+ p digit+ got: %s" (String.implode x)) in - match String.explode x with - | 'x' :: 'v' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - Xen, disk, partition - | 's' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - Scsi, disk, partition - | 'f' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - Floppy, disk, partition - | 'h' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - Ide, disk, partition - | 'd' :: rest -> - let disk, partition = parse_int_p_int rest in - Xen, disk, partition - | _ -> failwith (Printf.sprintf "Failed to parse device name: %s" x) + let letter c = 'a' <= c && c <= 'z' in + let digit c = '0' <= c && c <= '9' in + let take f x = + let rec inner f acc = function + | x :: xs -> + if f x then inner f (x :: acc) xs else (List.rev acc, x :: xs) + | [] -> + (List.rev acc, []) + in + inner f [] x + in + (* Parse a string "abc123" into x, y where x is "abc" interpreted as base-26 + and y is 123 *) + let parse_b26_int x = + let d, p = take letter x in + let d' = int26_of_string (String.implode d) in + let p' = if p = [] then 0 else int_of_string (String.implode p) in + (d', p') + in + (* Parse a string "123p456" into x, y where x = 123 and y = 456 *) + let parse_int_p_int x = + let d, rest = take digit x in + match rest with + | 'p' :: rest -> + let p, _ = take digit rest in + (int_of_string (String.implode d), int_of_string (String.implode p)) + | [] -> + (int_of_string (String.implode d), 0) + | _ -> + failwith + (Printf.sprintf "expected digit+ p digit+ got: %s" (String.implode x)) + in + match String.explode x with + | 'x' :: 'v' :: 'd' :: rest -> + let disk, partition = parse_b26_int rest in + (Xen, disk, partition) + | 's' :: 'd' :: rest -> + let disk, partition = parse_b26_int rest in + (Scsi, disk, partition) + | 'f' :: 'd' :: rest -> + let disk, partition = parse_b26_int rest in + (Floppy, disk, partition) + | 'h' :: 'd' :: rest -> + let disk, partition = parse_b26_int rest in + (Ide, disk, partition) + | 'd' :: rest -> + let disk, partition = parse_int_p_int rest in + (Xen, disk, partition) + | _ -> + failwith (Printf.sprintf "Failed to parse device name: %s" x) let upgrade_linux_device x = - match String.explode x with - | 'h' :: 'd' :: rest -> "xvd" ^ (String.implode rest) - | _ -> x + match String.explode x with + | 'h' :: 'd' :: rest -> + "xvd" ^ String.implode rest + | _ -> + x type disk_number = int let to_disk_number = function - | Xen, disk, _ -> disk - | Scsi, disk, _ -> disk - | Floppy, disk, _ -> disk - | Ide, disk, _ -> disk - -let of_disk_number hvm n = - if hvm && (n < 4) - then Ide, n, 0 - else Xen, n, 0 - -let of_string hvm name = - try - of_disk_number hvm (int_of_string name) - with _ -> - of_linux_device name + | Xen, disk, _ -> + disk + | Scsi, disk, _ -> + disk + | Floppy, disk, _ -> + disk + | Ide, disk, _ -> + disk + +let of_disk_number hvm n = if hvm && n < 4 then (Ide, n, 0) else (Xen, n, 0) + +let of_string hvm name = + try of_disk_number hvm (int_of_string name) with _ -> of_linux_device name diff --git a/xen/device_number.mli b/xen/device_number.mli index d963599f..4b5c431c 100644 --- a/xen/device_number.mli +++ b/xen/device_number.mli @@ -1,12 +1,12 @@ (** Disks are attached to particular bus types: *) type bus_type = - | Xen (** A xen paravirtualised bus *) - | Scsi (** A SCSI bus *) - | Floppy (** A floppy bus *) - | Ide (** An IDE bus *) + | Xen (** A xen paravirtualised bus *) + | Scsi (** A SCSI bus *) + | Floppy (** A floppy bus *) + | Ide (** An IDE bus *) -(** A specification for a device number. There are more valid specifications than - valid device numbers because of hardware and/or protocol limits. *) +(** A specification for a device number. There are more valid specifications + than valid device numbers because of hardware and/or protocol limits. *) type spec = bus_type * int * int (** A valid device number *) @@ -14,46 +14,45 @@ type t val typ_of : t Rpc.Types.typ +val make : spec -> t (** [make spec] validates a given device number specification [spec] and returns a device number *) -val make: spec -> t +val spec : t -> spec (** [spec t] takes a [t] and returns the corresponding [spec] *) -val spec: t -> spec -(** [of_string hvm name] returns the interface which best matches the [name] - by applying the policy: first check if it is a disk_number, else fall back to - a linux_device for backwards compatability *) -val of_string: bool -> string -> t +val of_string : bool -> string -> t +(** [of_string hvm name] returns the interface which best matches the [name] by + applying the policy: first check if it is a disk_number, else fall back to a + linux_device for backwards compatability *) +val to_debug_string : t -> string (** [to_debug_string i] returns a pretty-printed interface *) -val to_debug_string: t -> string -(** [to_linux_device i] returns a possible linux string representation of interface [i] *) -val to_linux_device: t -> string +val to_linux_device : t -> string +(** [to_linux_device i] returns a possible linux string representation of + interface [i] *) +val of_linux_device : string -> t (** [of_linux_device x] returns the interface corresponding to string [x] *) -val of_linux_device: string -> t -(** [upgrade_linux_device x] upgrades hd* style device names to xvd* - and leaves all other device names unchanged. *) -val upgrade_linux_device: string -> string +val upgrade_linux_device : string -> string +(** [upgrade_linux_device x] upgrades hd* style device names to xvd* and leaves + all other device names unchanged. *) type xenstore_key = int +val to_xenstore_key : t -> xenstore_key (** [to_xenstore_key i] returns the xenstore key from interface [i] *) -val to_xenstore_key: t -> xenstore_key +val of_xenstore_key : xenstore_key -> t (** [of_xenstore_key key] returns an interface from a xenstore key *) -val of_xenstore_key: xenstore_key -> t type disk_number = int +val to_disk_number : t -> disk_number (** [to_disk_number i] returns the corresponding non-negative disk number *) -val to_disk_number: t -> disk_number - -(** [of_disk_number hvm n] returns the interface corresponding to disk - number [n] which depends on whether the guest is [hvm] or not. *) -val of_disk_number: bool -> disk_number -> t - +val of_disk_number : bool -> disk_number -> t +(** [of_disk_number hvm n] returns the interface corresponding to disk number + [n] which depends on whether the guest is [hvm] or not. *) diff --git a/xen/dune b/xen/dune index 577fec17..abd8acf6 100644 --- a/xen/dune +++ b/xen/dune @@ -1,56 +1,40 @@ -(* -*- tuareg -*- *) - -(* (preprocess (pps)) doesn't work with camlp4 and the other ppx derivers, - it complains about missing rpc_of_t *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - (library - (name xcp_xen_interface_types) - (public_name xapi-idl.xen.interface.types) - (modules xenops_types device_number) - (flags (:standard -w -39-32)) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv %s)) -) + (name xcp_xen_interface_types) + (public_name xapi-idl.xen.interface.types) + (modules xenops_types device_number) + (flags (:standard -w -39-32)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))) (library - (name xcp_xen_interface) - (public_name xapi-idl.xen.interface) - (modules xenops_interface) - (flags (:standard -w -39)) - (libraries - rpclib.core - threads - xapi-idl - xapi-idl.xen.interface.types - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv %s)) -) + (name xcp_xen_interface) + (public_name xapi-idl.xen.interface) + (modules xenops_interface) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.xen.interface.types + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))) (library - (name xcp_xen) - (public_name xapi-idl.xen) - (modules (:standard \ device_number xenops_interface xenops_types)) - (flags (:standard -w -39)) - (libraries - rpclib.core - threads - xapi-idl - xapi-idl.xen.interface - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv %s)) -) -|} coverage_rewriter coverage_rewriter coverage_rewriter + (name xcp_xen) + (public_name xapi-idl.xen) + (modules (:standard \ device_number xenops_interface xenops_types)) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.xen.interface + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))) diff --git a/xen/xenops_client.ml b/xen/xenops_client.ml index 88399c6c..085a72f3 100644 --- a/xen/xenops_client.ml +++ b/xen/xenops_client.ml @@ -15,52 +15,63 @@ open Xenops_interface open Xcp_client -module Client = Xenops_interface.XenopsAPI(Idl.Exn.GenClient(struct - let rpc call = - if !use_switch - then json_switch_rpc !queue_name call - else xml_http_rpc ~srcstr:"xapi" ~dststr:"xenops" default_uri call +module Client = Xenops_interface.XenopsAPI (Idl.Exn.GenClient (struct + let rpc call = + if !use_switch then + json_switch_rpc !queue_name call + else + xml_http_rpc ~srcstr:"xapi" ~dststr:"xenops" default_uri call end)) let query dbg url = - let module Remote = Xenops_interface.XenopsAPI(Idl.Exn.GenClient(struct let rpc = xml_http_rpc ~srcstr:"xenops" ~dststr:"dst_xenops" (fun () -> url) end)) in - Remote.query dbg () + let module Remote = Xenops_interface.XenopsAPI (Idl.Exn.GenClient (struct + let rpc = xml_http_rpc ~srcstr:"xenops" ~dststr:"dst_xenops" (fun () -> url) + end)) in + Remote.query dbg () let event_wait dbg ?from p = - let finished = ref false in - let event_id = ref from in - while not !finished do - let _, deltas, next_id = Client.UPDATES.get dbg !event_id (Some 30) in - event_id := Some next_id; - List.iter (fun d -> if p d then finished := true) deltas; - done + let finished = ref false in + let event_id = ref from in + while not !finished do + let _, deltas, next_id = Client.UPDATES.get dbg !event_id (Some 30) in + event_id := Some next_id ; + List.iter (fun d -> if p d then finished := true) deltas + done let task_ended dbg id = - match (Client.TASK.stat dbg id).Task.state with - | Task.Completed _ - | Task.Failed _ -> true - | Task.Pending _ -> false + match (Client.TASK.stat dbg id).Task.state with + | Task.Completed _ | Task.Failed _ -> + true + | Task.Pending _ -> + false let success_task dbg id = - let t = Client.TASK.stat dbg id in - Client.TASK.destroy dbg id; - match t.Task.state with - | Task.Completed _ -> t - | Task.Failed x -> begin - match Rpcmarshal.unmarshal Errors.error.Rpc.Types.ty x with - | Ok x -> raise (Xenops_interface.Xenopsd_error x) - | Error _ -> raise (Xenops_interface.Xenopsd_error (Errors.Internal_error (Jsonrpc.to_string x))) end - | Task.Pending _ -> failwith "task pending" + let t = Client.TASK.stat dbg id in + Client.TASK.destroy dbg id ; + match t.Task.state with + | Task.Completed _ -> + t + | Task.Failed x -> ( + match Rpcmarshal.unmarshal Errors.error.Rpc.Types.ty x with + | Ok x -> + raise (Xenops_interface.Xenopsd_error x) + | Error _ -> + raise + (Xenops_interface.Xenopsd_error + (Errors.Internal_error (Jsonrpc.to_string x))) + ) + | Task.Pending _ -> + failwith "task pending" let wait_for_task dbg id = - let finished = function - | Dynamic.Task id' -> - id = id' && (task_ended dbg id) - | _ -> - false in - let from = Client.UPDATES.last_id dbg in - if not(task_ended dbg id) then event_wait dbg ~from finished; - id - -let ignore_task (_: Task.t) = () + let finished = function + | Dynamic.Task id' -> + id = id' && task_ended dbg id + | _ -> + false + in + let from = Client.UPDATES.last_id dbg in + if not (task_ended dbg id) then event_wait dbg ~from finished ; + id +let ignore_task (_ : Task.t) = () diff --git a/xen/xenops_interface.ml b/xen/xenops_interface.ml index bc05ad20..1d7cedc7 100644 --- a/xen/xenops_interface.ml +++ b/xen/xenops_interface.ml @@ -18,9 +18,7 @@ open Rpc open Idl -module D = Debug.Make (struct - let name = "xenops_interface" -end) +module D = Debug.Make (struct let name = "xenops_interface" end) open D @@ -29,42 +27,49 @@ type rpc_t = Rpc.t let typ_of_rpc_t = let open Types in Abstract - { aname= "Rpc.t" + { + aname= "Rpc.t" ; test_data= [Null] ; rpc_of= (fun x -> x) - ; of_rpc= (fun x -> Ok x) } + ; of_rpc= (fun x -> Ok x) + } module TypeCombinators = struct - let option ?name ?(description= []) d = + let option ?name ?(description = []) d = let open Rpc.Types in let name = match name with Some n -> n | None -> Printf.sprintf "%s option" d.name in {name; description; ty= Option d.ty} - let list ?name ?(description= []) d = + let list ?name ?(description = []) d = let open Rpc.Types in let name = match name with - | Some n -> n - | None -> Printf.sprintf "list of %ss" d.name + | Some n -> + n + | None -> + Printf.sprintf "list of %ss" d.name in {name; description; ty= List d.ty} - let pair ?name ?(description= []) (p1, p2) = + let pair ?name ?(description = []) (p1, p2) = let open Rpc.Types in let name = match name with - | Some n -> n - | None -> Printf.sprintf "pair of %s and %s" p1.name p2.name + | Some n -> + n + | None -> + Printf.sprintf "pair of %s and %s" p1.name p2.name in {name; description; ty= Tuple (p1.ty, p2.ty)} - let triple ?name ?(description= []) (p1, p2, p3) = + let triple ?name ?(description = []) (p1, p2, p3) = let open Rpc.Types in let name = match name with - | Some n -> n + | Some n -> + n | None -> Printf.sprintf "triple of %s, %s and %s" p1.name p2.name p3.name in @@ -125,7 +130,8 @@ module Errors = struct | Failed_to_start_emulator of (string * string * string) | Ballooning_timeout_before_migration | Internal_error of string - | Unknown_error [@@default Unknown_error] [@@deriving rpcty] + | Unknown_error + [@@default Unknown_error] [@@deriving rpcty] end exception Xenopsd_error of Errors.error @@ -138,39 +144,41 @@ let () = in let printer = function | Xenopsd_error e -> - Some - (sprintf "Xenops_interface.Xenopsd_error(%s)" (string_of_error e)) - | _ -> None + Some (sprintf "Xenops_interface.Xenopsd_error(%s)" (string_of_error e)) + | _ -> + None in Printexc.register_printer printer let err = let open Error in - { def= Errors.error + { + def= Errors.error ; raiser= (fun e -> let exn = Xenopsd_error e in error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - raise exn ) + raise exn) ; matcher= (function - | Xenopsd_error e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - Some (Internal_error (Printexc.to_string exn))) } + | Xenopsd_error e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + Some e + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + Some (Internal_error (Printexc.to_string exn))) + } type debug_info = string [@@deriving rpcty] module Query = struct - type t = - { name: string + type t = { + name: string ; vendor: string ; version: string ; features: string list - ; instance_id: string - (* Unique to this invocation of xenopsd *) } + ; instance_id: string (* Unique to this invocation of xenopsd *) + } [@@deriving rpcty] end @@ -179,10 +187,10 @@ type disk_list = disk list (* XXX: this code shouldn't care about the vswitch/bridge difference *) module Network = struct type t = - | Local of string (** Name of a local switch *) + | Local of string (** Name of a local switch *) | Remote of string * string (** Vm.id * switch *) - | Sriov of Xcp_pci.address (** Xcp_pci.address *) - [@@deriving rpcty] + | Sriov of Xcp_pci.address (** Xcp_pci.address *) + [@@deriving rpcty] let default_network = Local "xenbr0" @@ -194,12 +202,13 @@ module Pci = struct type id = string * string [@@deriving rpcty] - type t = - { id: id + type t = { + id: id ; position: int ; address: address ; msitranslate: bool option - ; power_mgmt: bool option } + ; power_mgmt: bool option + } [@@deriving rpcty] type state = {plugged: bool} [@@deriving rpcty] @@ -212,17 +221,20 @@ module Vgpu = struct | GVT_g of gvt_g | Nvidia of nvidia | MxGPU of mxgpu - | Empty [@@default Empty] [@@deriving rpcty] + | Empty + [@@default Empty] [@@deriving rpcty] type id = string * string [@@deriving rpcty] - let pci_default = Pci.{domain = 0; bus = 0; dev = 0; fn = 0} - type t = - { id: id [@default "", ""] + let pci_default = Pci.{domain= 0; bus= 0; dev= 0; fn= 0} + + type t = { + id: id [@default "", ""] ; position: int [@default 0] - ; virtual_pci_address: Pci.address option [@default None] (* SRIOV VF *) + ; virtual_pci_address: Pci.address option [@default None] (* SRIOV VF *) ; physical_pci_address: Pci.address [@default pci_default] - ; implementation: implementation [@default Empty] } + ; implementation: implementation [@default Empty] + } [@@deriving rpcty] let upgrade_pci_info x = @@ -230,25 +242,31 @@ module Vgpu = struct | {implementation= GVT_g {physical_pci_address= Some address; _}; _} | {implementation= Nvidia {physical_pci_address= Some address; _}; _} | {implementation= MxGPU {physical_function= Some address; _}; _} -> - {x with physical_pci_address= address} - | _ -> x + {x with physical_pci_address= address} + | _ -> + x - type state = {active: bool; plugged: bool; emulator_pid: int option} [@@deriving rpcty] + type state = {active: bool; plugged: bool; emulator_pid: int option} + [@@deriving rpcty] end module Vusb = struct type id = string * string [@@deriving rpcty] - type t = - {id: id; hostbus: string; hostport: string; version: string; path: string; speed: float} + type t = { + id: id + ; hostbus: string + ; hostport: string + ; version: string + ; path: string + ; speed: float + } [@@deriving rpcty] type state = {plugged: bool} [@@deriving rpcty] end -module Vm = struct - include Xenops_types.Vm -end +module Vm = struct include Xenops_types.Vm end module Vbd = struct type mode = ReadOnly | ReadWrite [@@deriving rpcty] @@ -267,8 +285,8 @@ module Vbd = struct type qos = Ionice of qos_scheduler [@@deriving rpcty] - type t = - { id: id [@default "", ""] + type t = { + id: id [@default "", ""] ; position: Device_number.t option [@default None] ; mode: mode [@default ReadWrite] ; backend: disk option [@default None] @@ -277,14 +295,16 @@ module Vbd = struct ; extra_backend_keys: (string * string) list [@default []] ; extra_private_keys: (string * string) list [@default []] ; qos: qos option [@default None] - ; persistent: bool [@default true] } + ; persistent: bool [@default true] + } [@@deriving rpcty] - type state = - { active: bool + type state = { + active: bool ; plugged: bool ; qos_target: qos option - ; backend_present: disk option } + ; backend_present: disk option + } [@@deriving rpcty] end @@ -333,8 +353,8 @@ module Vif = struct type t = site * server list * interface [@@deriving rpcty] end - type t = - { id: id [@default "", ""] + type t = { + id: id [@default "", ""] ; position: int [@default 0] ; mac: string [@default "fe:ff:ff:ff:ff:ff"] ; carrier: bool [@default true] @@ -345,32 +365,35 @@ module Vif = struct ; locking_mode: locking_mode [@default default_locking_mode] ; extra_private_keys: (string * string) list [@default []] ; ipv4_configuration: ipv4_configuration - [@default default_ipv4_configuration] + [@default default_ipv4_configuration] ; ipv6_configuration: ipv6_configuration - [@default default_ipv6_configuration] + [@default default_ipv6_configuration] ; pvs_proxy: PVS_proxy.t option [@default None] - ; vlan: int64 option [@default None] } + ; vlan: int64 option [@default None] + } [@@deriving rpcty] - type state = - { active: bool + type state = { + active: bool ; plugged: bool ; kthread_pid: int ; media_present: bool ; device: string option - ; pvs_rules_active: bool } + ; pvs_rules_active: bool + } [@@deriving rpcty] end module Metadata = struct - type t = - { vm: Vm.t + type t = { + vm: Vm.t ; vbds: Vbd.t list [@default []] ; vifs: Vif.t list [@default []] ; pcis: Pci.t list [@default []] ; vgpus: Vgpu.t list [@default []] ; vusbs: Vusb.t list [@default []] - ; domains: string option [@default None] } + ; domains: string option [@default None] + } [@@deriving rpcty] end @@ -385,16 +408,17 @@ module Task = struct type state = Pending of float | Completed of completion_t | Failed of rpc_t [@@deriving rpcty] - type t = - { id: id + type t = { + id: id ; dbg: string ; ctime: float ; state: state ; subtasks: (string * state) list ; debug_info: (string * string) list - ; backtrace: string (* An s-expression encoded Backtrace.t *) - ; cancellable: bool - } + ; backtrace: string + ; (* An s-expression encoded Backtrace.t *) + cancellable: bool + } [@@deriving rpcty] type t_list = t list [@@deriving rpcty] @@ -427,8 +451,8 @@ module Dynamic = struct end module Host = struct - type cpu_info = - { cpu_count: int + type cpu_info = { + cpu_count: int ; socket_count: int ; vendor: string ; speed: string @@ -442,21 +466,26 @@ module Host = struct ; features_hvm: int64 array ; features_pv_host: int64 array ; features_hvm_host: int64 array - ; features_oldstyle: int64 array } + ; features_oldstyle: int64 array + } [@@deriving rpcty] type chipset_info = {iommu: bool; hvm: bool} [@@deriving rpcty] type hypervisor = {version: string; capabilities: string} [@@deriving rpcty] - type t = - { cpu_info: cpu_info + type t = { + cpu_info: cpu_info ; hypervisor: hypervisor - ; chipset_info: chipset_info } + ; chipset_info: chipset_info + } [@@deriving rpcty] - type guest_agent_feature = - {name: string; licensed: bool; parameters: (string * string) list} + type guest_agent_feature = { + name: string + ; licensed: bool + ; parameters: (string * string) list + } [@@deriving rpcty] type guest_agent_feature_list = guest_agent_feature list [@@deriving rpcty] @@ -467,10 +496,12 @@ module XenopsAPI (R : RPC) = struct let description = let open Interface in - { name= "Xen" + { + name= "Xen" ; namespace= None ; description= ["This interface is used by xapi to talk to xenopsd"] - ; version= (1, 0, 0) } + ; version= (1, 0, 0) + } let implementation = implement description @@ -490,12 +521,11 @@ module XenopsAPI (R : RPC) = struct let get_diagnostics = let result_p = Param.mk Rpc.Types.string in declare "get_diagnostics" - ["Get diagnostics information from the backend"] + ["Get diagnostics information from the backend"] (debug_info_p @-> unit_p @-> returning result_p err) module TASK = struct - let task_id_p = - Param.mk ~description:["Task identifier"] ~name:"id" Task.id + let task_id_p = Param.mk ~description:["Task identifier"] ~name:"id" Task.id let task_t_p = Param.mk ~description:["The state of the task"] ~name:"task" Task.t @@ -505,7 +535,8 @@ module XenopsAPI (R : RPC) = struct Task.t_list let stat = - declare "Task.stat" ["Get the state of the task"] + declare "Task.stat" + ["Get the state of the task"] (debug_info_p @-> task_id_p @-> returning task_t_p err) let cancel = @@ -517,14 +548,14 @@ module XenopsAPI (R : RPC) = struct (debug_info_p @-> task_id_p @-> returning unit_p err) let list = - declare "Task.list" ["List all the current tasks"] + declare "Task.list" + ["List all the current tasks"] (debug_info_p @-> returning task_list_p err) end module HOST = struct let host_t_p = - Param.mk ~description:["The state of the host"] ~name:"host" - Host.t + Param.mk ~description:["The state of the host"] ~name:"host" Host.t let console_data_p = Param.mk ~description:["The console data"] ~name:"console_data" @@ -538,8 +569,9 @@ module XenopsAPI (R : RPC) = struct Param.mk ~description:["The debug keys"] ~name:"debug_keys" Types.string let pool_size_p = - Param.mk ~description:["The size of the worker pool"] ~name:"pool_size" - Types.int + Param.mk + ~description:["The size of the worker pool"] + ~name:"pool_size" Types.int let feature_list_p = Param.mk ~description:["The list of features"] ~name:"features" @@ -548,19 +580,23 @@ module XenopsAPI (R : RPC) = struct type cpu_features_array = int64 array [@@deriving rpcty] let cpu_features_array_p = - Param.mk ~description:["An array containing the raw CPU feature flags"] + Param.mk + ~description:["An array containing the raw CPU feature flags"] ~name:"features_array" cpu_features_array let stat = - declare "HOST.stat" ["Get the state of the host"] + declare "HOST.stat" + ["Get the state of the host"] (debug_info_p @-> returning host_t_p err) let get_console_data = - declare "HOST.get_console_data" ["Get the console data of the host"] + declare "HOST.get_console_data" + ["Get the console data of the host"] (debug_info_p @-> returning console_data_p err) let get_total_memory_mib = - declare "HOST.get_total_memory_mib" ["Get the total memory of the host"] + declare "HOST.get_total_memory_mib" + ["Get the total memory of the host"] (debug_info_p @-> returning memory_p err) let send_debug_keys = @@ -578,8 +614,11 @@ module XenopsAPI (R : RPC) = struct let upgrade_cpu_features = let is_hvm_p = Param.mk ~name:"is_hvm" Types.bool in declare "HOST.upgrade_cpu_features" [] - ( debug_info_p @-> cpu_features_array_p @-> is_hvm_p - @-> returning cpu_features_array_p err ) + (debug_info_p + @-> cpu_features_array_p + @-> is_hvm_p + @-> returning cpu_features_array_p err + ) end module VM = struct @@ -605,15 +644,18 @@ module XenopsAPI (R : RPC) = struct let migrate = let vdimap = - Param.mk ~name:"vdi_map" ~description:["Map of src VDI -> dest VDI"] + Param.mk ~name:"vdi_map" + ~description:["Map of src VDI -> dest VDI"] (list (pair (Types.string, Types.string))) in let vifmap = - Param.mk ~name:"vif_map" ~description:["Map of src VIF -> dest network"] + Param.mk ~name:"vif_map" + ~description:["Map of src VIF -> dest network"] (list (pair (Types.string, Network.t))) in let pcimap = - Param.mk ~name:"pci_map" ~description:["Map of src PCI -> dest PCI"] + Param.mk ~name:"pci_map" + ~description:["Map of src PCI -> dest PCI"] (list (pair (Types.string, Pci.address))) in let xenops_url = @@ -622,8 +664,14 @@ module XenopsAPI (R : RPC) = struct Types.string in declare "VM.migrate" [] - ( debug_info_p @-> vm_id_p @-> vdimap @-> vifmap @-> pcimap - @-> xenops_url @-> returning task_id_p err ) + (debug_info_p + @-> vm_id_p + @-> vdimap + @-> vifmap + @-> pcimap + @-> xenops_url + @-> returning task_id_p err + ) let create = declare "VM.create" [] @@ -658,34 +706,46 @@ module XenopsAPI (R : RPC) = struct let run_script = declare "VM.run_script" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"script" Types.string - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let set_xsdata = declare "VM.set_xsdata" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"xsdata" (list (pair (Types.string, Types.string))) - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let set_vcpus = declare "VM.set_vcpus" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"vcpus" Types.int - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let set_shadow_multiplier = declare "VM.set_shadow_multiplier" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"multiplier" Types.float - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let set_memory_dynamic_range = let min_p = Param.mk ~name:"minimum" Types.int64 in let max_p = Param.mk ~name:"maximum" Types.int64 in declare "VM.set_memory_dynamic_range" [] - ( debug_info_p @-> vm_id_p @-> min_p @-> max_p - @-> returning task_id_p err ) + (debug_info_p + @-> vm_id_p + @-> min_p + @-> max_p + @-> returning task_id_p err + ) let stat = let stat_p = Param.mk (pair (Vm.t, Vm.state)) in @@ -702,9 +762,11 @@ module XenopsAPI (R : RPC) = struct let delay = declare "VM.delay" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"delay" Types.float - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let start = let paused_p = Param.mk ~name:"paused" Types.bool in @@ -745,16 +807,26 @@ module XenopsAPI (R : RPC) = struct let import_metadata = declare "VM.import_metadata" [] - ( debug_info_p + (debug_info_p + @-> Param.mk ~name:"metadata" Types.string + @-> returning vm_id_p err + ) + + let import_metadata_async = + declare "VM.import_metadata_async" [] + (debug_info_p @-> Param.mk ~name:"metadata" Types.string - @-> returning vm_id_p err ) + @-> returning task_id_p err + ) end module PCI = struct open TypeCombinators let pci_t_p = Param.mk ~name:"pci" Pci.t + let pci_id_p = Param.mk ~name:"id" Pci.id + let pci_addr_p = Param.mk ~name:"pci_addr" Pci.address let add = @@ -776,7 +848,8 @@ module XenopsAPI (R : RPC) = struct (debug_info_p @-> VM.vm_id_p @-> returning stat_list_p err) let dequarantine = - declare "PCI.dequarantine" ["De-quarantine PCI device into dom0"] + declare "PCI.dequarantine" + ["De-quarantine PCI device into dom0"] (debug_info_p @-> pci_addr_p @-> returning unit_p err) end @@ -913,8 +986,11 @@ module XenopsAPI (R : RPC) = struct let set_locking_mode = let locking_mode_p = Param.mk ~name:"locking_mode" Vif.locking_mode in declare "VIF.set_locking_mode" [] - ( debug_info_p @-> vif_id_p @-> locking_mode_p - @-> returning task_id_p err ) + (debug_info_p + @-> vif_id_p + @-> locking_mode_p + @-> returning task_id_p err + ) let set_ipv4_configuration = let config_p = @@ -1002,10 +1078,11 @@ module XenopsAPI (R : RPC) = struct let trigger = declare "DEBUG.trigger" [] - ( debug_info_p + (debug_info_p @-> Param.mk ~name:"cmd" Types.string @-> Param.mk ~name:"args" (list Types.string) - @-> returning unit_p err ) + @-> returning unit_p err + ) let shutdown = declare "DEBUG.shutdown" [] diff --git a/xen/xenops_types.ml b/xen/xenops_types.ml index 211c12d9..87aaa353 100644 --- a/xen/xenops_types.ml +++ b/xen/xenops_types.ml @@ -2,197 +2,171 @@ open Sexplib.Std open Xcp_pci module TopLevel = struct - type power_state = - | Running - | Halted - | Suspended - | Paused + type power_state = Running | Halted | Suspended | Paused [@@deriving sexp, rpcty] type disk = - | Local of string (** path to a local block device *) - | VDI of string (** typically "SR/VDI" *) + | Local of string (** path to a local block device *) + | VDI of string (** typically "SR/VDI" *) [@@deriving sexp, rpcty] end module Vgpu = struct type gvt_g = { - physical_pci_address: address option; (* unused; promoted to Vgpu.t *) - low_gm_sz: int64; - high_gm_sz: int64; - fence_sz: int64; - monitor_config_file: string option; - } [@@deriving sexp, rpcty] - - (* Example for nvidia: - { - physical_pci_address : None - config_file: None - virtual_pci_address : Some {domain; bus; device; fn} - type_id: 45 - uuid: aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee - extra_args:key1=v1,key2=v2,key3=v3 + physical_pci_address: address option (** unused; promoted to Vgpu.t *) + ; low_gm_sz: int64 + ; high_gm_sz: int64 + ; fence_sz: int64 + ; monitor_config_file: string option } - *) + [@@deriving sexp, rpcty] + + (** Example for nvidia: { physical_pci_address : None config_file: None + virtual_pci_address : Some {domain; bus; device; fn} type_id: 45 uuid: + aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee extra_args:key1=v1,key2=v2,key3=v3 } *) type nvidia = { - physical_pci_address: address option; (* unused; promoted to Vgpu.t *) - config_file: string option; - virtual_pci_address: address [@default {domain = 0000; bus = 0; dev = 11; fn = 0}]; - type_id: string option; - uuid: string option; - extra_args: string [@default ""]; (* string is passed on as is and no structure is assumed *) - } [@@deriving sexp, rpcty] + physical_pci_address: address option (** unused; promoted to Vgpu.t *) + ; config_file: string option + ; virtual_pci_address: address + [@default {domain= 0000; bus= 0; dev= 11; fn= 0}] + ; type_id: string option + ; uuid: string option + ; extra_args: string [@default ""] + (** string is passed on as is and no structure is assumed *) + } + [@@deriving sexp, rpcty] type mxgpu = { - physical_function: address option; (* unused; promoted to Vgpu.t *) - vgpus_per_pgpu: int64; - framebufferbytes: int64; - } [@@deriving sexp, rpcty] - + physical_function: address option (** unused; promoted to Vgpu.t *) + ; vgpus_per_pgpu: int64 + ; framebufferbytes: int64 + } + [@@deriving sexp, rpcty] end module Nvram_uefi_variables = struct - type onboot = - | Persist - | Reset - [@@deriving rpcty, sexp] + type onboot = Persist | Reset [@@deriving rpcty, sexp] type t = { - on_boot: onboot [@default Persist]; - backend: string [@default "xapidb"]; - } [@@deriving rpcty, sexp] + on_boot: onboot [@default Persist] + ; backend: string [@default "xapidb"] + } + [@@deriving rpcty, sexp] let default_t = match Rpcmarshal.unmarshal t.Rpc.Types.ty Rpc.(Dict []) with - | Ok x -> x + | Ok x -> + x | Error (`Msg m) -> - failwith (Printf.sprintf "Error creating Nvram_uefi_variables.default_t: %s" m) + failwith + (Printf.sprintf "Error creating Nvram_uefi_variables.default_t: %s" m) end module Vm = struct - type igd_passthrough = - | GVT_d - [@@deriving rpcty, sexp] + type igd_passthrough = GVT_d [@@deriving rpcty, sexp] type video_card = | Cirrus | Standard_VGA | Vgpu | IGD_passthrough of igd_passthrough - [@@default Cirrus] - [@@deriving rpcty, sexp] + [@@default Cirrus] [@@deriving rpcty, sexp] - type firmware_type = - | Bios - | Uefi of Nvram_uefi_variables.t + type firmware_type = Bios | Uefi of Nvram_uefi_variables.t [@@deriving rpcty, sexp] let default_firmware = Bios [@@deriving rpcty] type hvm_info = { - hap: bool [@default true]; - shadow_multiplier: float [@default 1.0]; - timeoffset: string [@default ""]; - video_mib: int [@default 4]; - video: video_card [@default Cirrus]; - acpi: bool [@default true]; - serial: string option [@default None]; - keymap: string option [@default None]; - vnc_ip: string option [@default None]; - pci_emulations: string list [@default []]; - pci_passthrough: bool [@default false]; - boot_order: string [@default ""]; - qemu_disk_cmdline: bool [@default false]; - qemu_stubdom: bool [@default false]; - firmware: firmware_type [@default default_firmware]; + hap: bool [@default true] + ; shadow_multiplier: float [@default 1.0] + ; timeoffset: string [@default ""] + ; video_mib: int [@default 4] + ; video: video_card [@default Cirrus] + ; acpi: bool [@default true] + ; serial: string option [@default None] + ; keymap: string option [@default None] + ; vnc_ip: string option [@default None] + ; pci_emulations: string list [@default []] + ; pci_passthrough: bool [@default false] + ; boot_order: string [@default ""] + ; qemu_disk_cmdline: bool [@default false] + ; qemu_stubdom: bool [@default false] + ; firmware: firmware_type [@default default_firmware] } [@@deriving rpcty, sexp] type pv_direct_boot = { - kernel: string [@default ""]; - cmdline: string [@default ""]; - ramdisk: string option [@default None]; + kernel: string [@default ""] + ; cmdline: string [@default ""] + ; ramdisk: string option [@default None] } [@@deriving rpcty, sexp] type pv_indirect_boot = { - bootloader: string [@default ""]; - extra_args: string [@default ""]; - legacy_args: string [@default ""]; - bootloader_args: string [@default ""]; - devices: TopLevel.disk list [@default []]; + bootloader: string [@default ""] + ; extra_args: string [@default ""] + ; legacy_args: string [@default ""] + ; bootloader_args: string [@default ""] + ; devices: TopLevel.disk list [@default []] } [@@deriving rpcty, sexp] - type pv_boot = - | Direct of pv_direct_boot - | Indirect of pv_indirect_boot + type pv_boot = Direct of pv_direct_boot | Indirect of pv_indirect_boot [@@deriving rpcty, sexp] type pv_info = { - boot: pv_boot; - framebuffer: bool [@default true]; - framebuffer_ip: string option [@default None]; - vncterm: bool [@default true]; - vncterm_ip: string option [@default None]; - pci_passthrough: bool [@default false] + boot: pv_boot + ; framebuffer: bool [@default true] + ; framebuffer_ip: string option [@default None] + ; vncterm: bool [@default true] + ; vncterm_ip: string option [@default None] + ; pci_passthrough: bool [@default false] } [@@deriving rpcty, sexp] - type builder_info = - | HVM of hvm_info - | PV of pv_info - | PVinPVH of pv_info + type builder_info = HVM of hvm_info | PV of pv_info | PVinPVH of pv_info [@@deriving rpcty, sexp] type id = string [@@deriving rpcty, sexp] - type action = - | Coredump - | Shutdown - | Start - | Pause - [@@deriving rpcty, sexp] + type action = Coredump | Shutdown | Start | Pause [@@deriving rpcty, sexp] type scheduler_params = { - priority: (int * int) option; (* weight, cap *) - affinity: int list list (* vcpu -> pcpu list *) - } [@@deriving rpcty, sexp] + priority: (int * int) option (** weight, cap *) + ; affinity: int list list (** vcpu -> pcpu list *) + } + [@@deriving rpcty, sexp] type t = { - id: id; - name: string [@default "unnamed"]; - ssidref: int32; - xsdata: (string * string) list; - platformdata: (string * string) list; - bios_strings: (string * string) list; - ty: builder_info; - suppress_spurious_page_faults: bool; - machine_address_size: int option; - memory_static_max: int64; - memory_dynamic_max: int64; - memory_dynamic_min: int64; - vcpu_max: int; (* boot-time maximum *) - vcpus: int; (* ideal number to use *) - scheduler_params: scheduler_params; - on_crash: action list; - on_shutdown: action list; - on_reboot: action list; - pci_msitranslate: bool; - pci_power_mgmt: bool; - has_vendor_device: bool [@default false]; - } [@@deriving rpcty, sexp] - - type console_protocol = - | Rfb - | Vt100 + id: id + ; name: string [@default "unnamed"] + ; ssidref: int32 + ; xsdata: (string * string) list + ; platformdata: (string * string) list + ; bios_strings: (string * string) list + ; ty: builder_info + ; suppress_spurious_page_faults: bool + ; machine_address_size: int option + ; memory_static_max: int64 + ; memory_dynamic_max: int64 + ; memory_dynamic_min: int64 + ; vcpu_max: int (** boot-time maximum *) + ; vcpus: int (** ideal number to use *) + ; scheduler_params: scheduler_params + ; on_crash: action list + ; on_shutdown: action list + ; on_reboot: action list + ; pci_msitranslate: bool + ; pci_power_mgmt: bool + ; has_vendor_device: bool [@default false] + } [@@deriving rpcty, sexp] - type console = { - protocol: console_protocol; - port: int; - path: string; - } [@@deriving rpcty, sexp] + type console_protocol = Rfb | Vt100 [@@deriving rpcty, sexp] + + type console = {protocol: console_protocol; port: int; path: string} + [@@deriving rpcty, sexp] type domain_type = | Domain_HVM @@ -202,24 +176,24 @@ module Vm = struct [@@deriving rpcty, sexp] type state = { - power_state: TopLevel.power_state; - domids: int list; - consoles: console list; - memory_target: int64; - memory_actual: int64; - memory_limit: int64; - vcpu_target: int; (* actual number of vcpus *) - shadow_multiplier_target: float; (* actual setting *) - rtc_timeoffset: string; - uncooperative_balloon_driver: bool; - guest_agent: (string * string) list; - xsdata_state: (string * string) list; - pv_drivers_detected: bool; - last_start_time: float; - hvm: bool; - nomigrate: bool; (* true: VM must not migrate *) - nested_virt: bool; (* true: VM uses nested virtualisation *) - domain_type: domain_type; - } [@@deriving rpcty, sexp] - + power_state: TopLevel.power_state + ; domids: int list + ; consoles: console list + ; memory_target: int64 + ; memory_actual: int64 + ; memory_limit: int64 + ; vcpu_target: int (** actual number of vcpus *) + ; shadow_multiplier_target: float (** actual setting *) + ; rtc_timeoffset: string + ; uncooperative_balloon_driver: bool + ; guest_agent: (string * string) list + ; xsdata_state: (string * string) list + ; pv_drivers_detected: bool + ; last_start_time: float + ; hvm: bool + ; nomigrate: bool (** true means VM must not migrate *) + ; nested_virt: bool (** true means VM uses nested virtualisation *) + ; domain_type: domain_type + } + [@@deriving rpcty, sexp] end