diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 919cf406127..5c3f1cd5502 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -20,13 +20,11 @@ jobs: python-version: "3.x" - name: Install build dependencies - run: | - pip install build - sudo apt-get install ocaml dune libfindlib-ocaml-dev libdune-ocaml-dev libcmdliner-ocaml-dev + run: pip install build - name: Generate python package for XenAPI run: | - ./configure --xapi_version=${{ github.ref_name }} + echo "export XAPI_VERSION=${{ github.ref_name }}" > config.mk make python - name: Store python distribution artifacts diff --git a/doc/content/design/coverage/index.md b/doc/content/design/coverage/index.md index 3b3f6ec3ec7..27ccd0d469a 100644 --- a/doc/content/design/coverage/index.md +++ b/doc/content/design/coverage/index.md @@ -8,7 +8,7 @@ revision: 2 We would like to add optional coverage profiling to existing [OCaml] projects in the context of [XenServer] and [XenAPI]. This article -presents how we do it. +presents how we do it. Binaries instrumented for coverage profiling in the XenServer project need to run in an environment where several services act together as @@ -21,7 +21,7 @@ isolation. To build binaries with coverage profiling, do: ./configure --enable-coverage - make + make Binaries will log coverage data to `/tmp/bisect*.out` from which a coverage report can be generated in `coverage/`: @@ -38,7 +38,7 @@ and logs during execution data to in-memory data structures. Before an instrumented binary terminates, it writes the logged data to a file. This data can then be analysed with the `bisect-ppx-report` tool, to produce a summary of annotated code that highlights what part of a -codebase was executed. +codebase was executed. [BisectPPX] has several desirable properties: @@ -65,13 +65,13 @@ abstracted by OCamlfind (OCaml's library manager) and OCamlbuild # build it with instrumentation from bisect_ppx ocamlbuild -use-ocamlfind -pkg bisect_ppx -pkg unix example.native - + # execute it - generates files ./bisect*.out ./example.native - + # generate report bisect-ppx-report -I _build -html coverage bisect000* - + # view coverage/index.html Summary: @@ -86,7 +86,7 @@ will be instrumented during compilation. Behind the scenes `ocamlfind` makes sure that the compiler uses a preprocessing step that instruments the code. -## Signal Handling +## Signal Handling During execution the code instrumentation leads to the collection of data. This code registers a function with `at_exit` that writes the data @@ -98,7 +98,7 @@ terminated by receiving the `TERM` signal, a signal handler must be installed: let stop signal = - printf "caught signal %d\n" signal; + printf "caught signal %a\n" Debug.Pp.signal signal; exit 0 Sys.set_signal Sys.sigterm (Sys.Signal_handle stop) @@ -149,8 +149,8 @@ environment variable. This can happen on the command line: BISECT_FILE=/tmp/example ./example.native -In the context of XenServer we could do this in startup scripts. -However, we added a bit of code +In the context of XenServer we could do this in startup scripts. +However, we added a bit of code val Coverage.init: string -> unit @@ -176,12 +176,12 @@ Goals for instrumentation are: * what files are instrumented should be obvious and easy to manage * instrumentation must be optional, yet easy to activate -* avoid methods that require to keep several files in sync like multiple +* avoid methods that require to keep several files in sync like multiple `_oasis` files * avoid separate Git branches for instrumented and non-instrumented code -In the ideal case, we could introduce a configuration switch +In the ideal case, we could introduce a configuration switch `./configure --enable-coverage` that would prepare compilation for coverage instrumentation. While [Oasis] supports the creation of such switches, they cannot be used to control build dependencies like @@ -196,7 +196,7 @@ rules in file `_tags.coverage` that cause files to be instrumented: leads to the execution of this code during preparation: - coverage: _tags _tags.coverage + coverage: _tags _tags.coverage test ! -f _tags.orig && mv _tags _tags.orig || true cat _tags.coverage _tags.orig > _tags @@ -207,7 +207,7 @@ could be tweaked to instrument only some files: <**/*.native>: pkg_bisect_ppx When `make coverage` is not called, these rules are not active and -hence, code is not instrumented for coverage. We believe that this +hence, code is not instrumented for coverage. We believe that this solution to control instrumentation meets the goals from above. In particular, what files are instrumented and when is controlled by very few lines of declarative code that lives in the main repository of a @@ -226,14 +226,14 @@ coverage analysis are: The `_oasis` file bundles the files under `profiling/` into an internal library which executables then depend on: - # Support files for profiling + # Support files for profiling Library profiling CompiledObject: best Path: profiling Install: false Findlibname: profiling Modules: Coverage - BuildDepends: + BuildDepends: Executable set_domain_uuid CompiledObject: best @@ -243,8 +243,8 @@ library which executables then depend on: MainIs: set_domain_uuid.ml Install: false BuildDepends: - xenctrl, - uuidm, + xenctrl, + uuidm, cmdliner, profiling # <-- here @@ -252,7 +252,7 @@ The `Makefile` target `coverage` primes the project for a profiling build: # make coverage - prepares for building with coverage analysis - coverage: _tags _tags.coverage + coverage: _tags _tags.coverage test ! -f _tags.orig && mv _tags _tags.orig || true cat _tags.coverage _tags.orig > _tags diff --git a/ocaml/database/database_test.ml b/ocaml/database/database_test.ml index 51e28dbf387..dc176488f3b 100644 --- a/ocaml/database/database_test.ml +++ b/ocaml/database/database_test.ml @@ -16,6 +16,8 @@ let name_label = "name__label" let name_description = "name__description" +let failwith_fmt fmt = Printf.ksprintf failwith fmt + module Tests = functor (Client : Db_interface.DB_ACCESS) @@ -111,7 +113,7 @@ functor ; where_value= "" } in - failwith (Printf.sprintf "%s " fn_name) + failwith_fmt "%s " fn_name ) ; Printf.printf "%s \n" @@ -126,11 +128,9 @@ functor ; where_value= name } in - failwith - (Printf.sprintf - "%s " - fn_name - ) + failwith_fmt + "%s " + fn_name ) ; Printf.printf "%s \n" @@ -145,11 +145,9 @@ functor ; where_value= "" } in - failwith - (Printf.sprintf - "%s " - fn_name - ) + failwith_fmt + "%s " + fn_name ) (* Verify the ref_index contents are correct for a given [tblname] and [key] (uuid/ref) *) @@ -168,10 +166,9 @@ functor | Some {Ref_index.name_label= name_label'; uuid; _ref} -> (* key should be either uuid or _ref *) if key <> uuid && key <> _ref then - failwith - (Printf.sprintf "check_ref_index %s key %s: got ref %s uuid %s" - tblname key _ref uuid - ) ; + failwith_fmt "check_ref_index %s key %s: got ref %s uuid %s" tblname + key _ref uuid ; + let real_ref = if Client.is_valid_ref t key then key @@ -183,14 +180,11 @@ functor with _ -> None in if name_label' <> real_name_label then - failwith - (Printf.sprintf - "check_ref_index %s key %s: ref_index name_label = %s; db has \ - %s" - tblname key - (Option.value ~default:"None" name_label') - (Option.value ~default:"None" real_name_label) - ) + failwith_fmt + "check_ref_index %s key %s: ref_index name_label = %s; db has %s" + tblname key + (Option.value ~default:"None" name_label') + (Option.value ~default:"None" real_name_label) open Db_cache_types @@ -226,11 +220,9 @@ functor in let bar_foos = Row.find "foos" bar_1 in if bar_foos <> Set ["foo:1"] then - failwith - (Printf.sprintf - "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s" - (Schema.Value.marshal bar_foos) - ) ; + failwith_fmt + "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s" + (Schema.Value.marshal bar_foos) ; (* set foo.bars to [] *) (* let foo_1 = Table.find "foo:1" (TableSet.find "foo" (Database.tableset db)) in*) let db = set_field "foo" "foo:1" "bars" (Set []) db in @@ -240,11 +232,8 @@ functor in let bar_foos = Row.find "foos" bar_1 in if bar_foos <> Set [] then - failwith - (Printf.sprintf - "check_many_to_many: bar(bar:1).foos expected () got %s" - (Schema.Value.marshal bar_foos) - ) ; + failwith_fmt "check_many_to_many: bar(bar:1).foos expected () got %s" + (Schema.Value.marshal bar_foos) ; (* add 'bar' to foo.bars *) let db = set_field "foo" "foo:1" "bars" (Set ["bar:1"]) db in (* check that 'bar.foos' includes 'foo' *) @@ -253,11 +242,9 @@ functor in let bar_foos = Row.find "foos" bar_1 in if bar_foos <> Set ["foo:1"] then - failwith - (Printf.sprintf - "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s - 2" - (Schema.Value.marshal bar_foos) - ) ; + failwith_fmt + "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s - 2" + (Schema.Value.marshal bar_foos) ; (* delete 'bar' *) let db = remove_row "bar" "bar:1" db in (* check that 'foo.bars' is empty *) @@ -266,11 +253,8 @@ functor in let foo_bars = Row.find "bars" foo_1 in if foo_bars <> Set [] then - failwith - (Printf.sprintf - "check_many_to_many: foo(foo:1).foos expected () got %s" - (Schema.Value.marshal foo_bars) - ) ; + failwith_fmt "check_many_to_many: foo(foo:1).foos expected () got %s" + (Schema.Value.marshal foo_bars) ; () let check_events t = @@ -503,8 +487,7 @@ functor | None -> Printf.printf "Reference '%s' has no associated table\n" invalid_ref | Some t -> - failwith - (Printf.sprintf "Reference '%s' exists in table '%s'" invalid_ref t) + failwith_fmt "Reference '%s' exists in table '%s'" invalid_ref t ) ; Printf.printf "is_valid_ref \n" ; if Client.is_valid_ref t invalid_ref then @@ -571,15 +554,25 @@ functor Printf.printf "db_get_by_uuid \n" ; let r = Client.db_get_by_uuid t "VM" valid_uuid in if r <> valid_ref then - failwith - (Printf.sprintf "db_get_by_uuid : got %s; expected %s" r - valid_ref - ) ; + failwith_fmt "db_get_by_uuid : got %s; expected %s" r + valid_ref ; Printf.printf "db_get_by_uuid \n" ; expect_missing_uuid "VM" invalid_uuid (fun () -> let (_ : string) = Client.db_get_by_uuid t "VM" invalid_uuid in failwith "db_get_by_uuid " ) ; + Printf.printf "db_get_by_uuid_opt \n" ; + let r = Client.db_get_by_uuid_opt t "VM" valid_uuid in + ( if r <> Some valid_ref then + let rs = Option.value ~default:"None" r in + failwith_fmt "db_get_by_uuid_opt : got %s; expected %s" rs + valid_ref + ) ; + Printf.printf "db_get_by_uuid_opt \n" ; + let r = Client.db_get_by_uuid_opt t "VM" invalid_uuid in + if not (Option.is_none r) then + failwith_fmt "db_get_by_uuid_opt : got %s; expected None" + valid_ref ; Printf.printf "get_by_name_label \n" ; if Client.db_get_by_name_label t "VM" invalid_name <> [] then failwith "db_get_by_name_label " ; diff --git a/ocaml/database/db_remote_cache_access_v1.ml b/ocaml/database/db_remote_cache_access_v1.ml index ec198755739..1499fa3fc13 100644 --- a/ocaml/database/db_remote_cache_access_v1.ml +++ b/ocaml/database/db_remote_cache_access_v1.ml @@ -102,6 +102,12 @@ module DBCacheRemoteListener = struct let s, e = unmarshall_db_get_by_uuid_args args in success (marshall_db_get_by_uuid_response (DBCache.db_get_by_uuid t s e)) + | "db_get_by_uuid_opt" -> + let s, e = unmarshall_db_get_by_uuid_args args in + success + (marshall_db_get_by_uuid_opt_response + (DBCache.db_get_by_uuid_opt t s e) + ) | "db_get_by_name_label" -> let s, e = unmarshall_db_get_by_name_label_args args in success diff --git a/ocaml/database/db_remote_cache_access_v2.ml b/ocaml/database/db_remote_cache_access_v2.ml index 040ad215600..754fd2fa340 100644 --- a/ocaml/database/db_remote_cache_access_v2.ml +++ b/ocaml/database/db_remote_cache_access_v2.ml @@ -36,6 +36,8 @@ let process_rpc (req : Rpc.t) = Response.Read_field_where (DB.read_field_where t w) | Request.Db_get_by_uuid (a, b) -> Response.Db_get_by_uuid (DB.db_get_by_uuid t a b) + | Request.Db_get_by_uuid_opt (a, b) -> + Response.Db_get_by_uuid_opt (DB.db_get_by_uuid_opt t a b) | Request.Db_get_by_name_label (a, b) -> Response.Db_get_by_name_label (DB.db_get_by_name_label t a b) | Request.Create_row (a, b, c) -> diff --git a/ocaml/database/db_rpc_client_v2.ml b/ocaml/database/db_rpc_client_v2.ml index 3a32b3149e9..2e03f069497 100644 --- a/ocaml/database/db_rpc_client_v2.ml +++ b/ocaml/database/db_rpc_client_v2.ml @@ -78,7 +78,7 @@ functor raise Remote_db_server_returned_bad_message let db_get_by_uuid_opt _ t u = - match process (Request.Db_get_by_uuid (t, u)) with + match process (Request.Db_get_by_uuid_opt (t, u)) with | Response.Db_get_by_uuid_opt y -> y | _ -> diff --git a/ocaml/database/db_rpc_common_v1.ml b/ocaml/database/db_rpc_common_v1.ml index cced73dd9ca..b4ef9a4163e 100644 --- a/ocaml/database/db_rpc_common_v1.ml +++ b/ocaml/database/db_rpc_common_v1.ml @@ -192,6 +192,8 @@ let unmarshall_db_get_by_uuid_args xml = unmarshall_2strings xml let marshall_db_get_by_uuid_response s = XMLRPC.To.string s +let marshall_db_get_by_uuid_opt_response = marshall_stringopt + let unmarshall_db_get_by_uuid_response xml = XMLRPC.From.string xml let unmarshall_db_get_by_uuid_opt_response xml = unmarshall_stringopt xml diff --git a/ocaml/database/db_rpc_common_v2.ml b/ocaml/database/db_rpc_common_v2.ml index 4cd9d7541ab..6700d159f18 100644 --- a/ocaml/database/db_rpc_common_v2.ml +++ b/ocaml/database/db_rpc_common_v2.ml @@ -23,6 +23,7 @@ module Request = struct | Find_refs_with_filter of string * Db_filter_types.expr | Read_field_where of Db_cache_types.where_record | Db_get_by_uuid of string * string + | Db_get_by_uuid_opt of string * string | Db_get_by_name_label of string * string | Create_row of string * (string * string) list * string | Delete_row of string * string diff --git a/ocaml/database/db_xml.ml b/ocaml/database/db_xml.ml index d7c73db3d84..1795cdef3bd 100644 --- a/ocaml/database/db_xml.ml +++ b/ocaml/database/db_xml.ml @@ -161,12 +161,9 @@ module From = struct D.warn "no lifetime information about %s.%s, ignoring" tblname k ; false in - if do_not_load then ( - D.info - {|dropping column "%s.%s": it has been removed from the datamodel|} - tblname k ; + if do_not_load then row - ) else + else let column_schema = Schema.Table.find k table_schema in let value = Schema.Value.unmarshal column_schema.Schema.Column.ty diff --git a/ocaml/database/master_connection.ml b/ocaml/database/master_connection.ml index e10658d48c0..ed9bfbd2826 100644 --- a/ocaml/database/master_connection.ml +++ b/ocaml/database/master_connection.ml @@ -221,6 +221,57 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : else if !backoff_delay > 256.0 then backoff_delay := 256.0 in + let reconnect () = + (* RPC failed - there's no way we can recover from this so try reopening connection every 2s + backoff delay *) + ( match !my_connection with + | None -> + () + | Some st_proc -> ( + my_connection := None ; + (* don't want to try closing multiple times *) + try Stunnel.disconnect st_proc with _ -> () + ) + ) ; + let time_sofar = Unix.gettimeofday () -. time_call_started in + if !connection_timeout < 0. then ( + if not !surpress_no_timeout_logs then ( + debug + "Connection to master died. I will continue to retry indefinitely \ + (supressing future logging of this message)." ; + error + "Connection to master died. I will continue to retry indefinitely \ + (supressing future logging of this message)." + ) ; + surpress_no_timeout_logs := true + ) else + debug + "Connection to master died: time taken so far in this call '%f'; will \ + %s" + time_sofar + ( if !connection_timeout < 0. then + "never timeout" + else + Printf.sprintf "timeout after '%f'" !connection_timeout + ) ; + if time_sofar > !connection_timeout && !connection_timeout >= 0. then + if !restart_on_connection_timeout then ( + debug "Exceeded timeout for retrying master connection: restarting xapi" ; + !Db_globs.restart_fn () + ) else ( + debug + "Exceeded timeout for retrying master connection: raising \ + Cannot_connect_to_master" ; + raise Cannot_connect_to_master + ) ; + debug "Sleeping %f seconds before retrying master connection..." + !backoff_delay ; + let timed_out = Scheduler.PipeDelay.wait delay !backoff_delay in + if not timed_out then + debug "%s: Sleep interrupted, retrying master connection now" __FUNCTION__ ; + update_backoff_delay () ; + D.log_and_ignore_exn open_secure_connection + in + while not !write_ok do try let req_string = req in @@ -266,67 +317,13 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : Db_globs.http_limit_max_rpc_size ; debug "Re-raising exception to caller." ; raise Http.Client_requested_size_over_limit - (* TODO: This http exception handler caused CA-36936 and can probably be removed now that there's backoff delay in the generic handler _ below *) | Http_client.Http_error (http_code, err_msg) -> - error - "Received HTTP error %s (%s) from master. This suggests our master \ - address is wrong. Sleeping for %.0fs and then executing restart_fn." - http_code err_msg - !Db_globs.permanent_master_failure_retry_interval ; - Thread.delay !Db_globs.permanent_master_failure_retry_interval ; - !Db_globs.restart_fn () + error "Received HTTP error %s (%s) from the coordinator" http_code + err_msg ; + reconnect () | e -> error "Caught %s" (Printexc.to_string e) ; - (* RPC failed - there's no way we can recover from this so try reopening connection every 2s + backoff delay *) - ( match !my_connection with - | None -> - () - | Some st_proc -> ( - my_connection := None ; - (* don't want to try closing multiple times *) - try Stunnel.disconnect st_proc with _ -> () - ) - ) ; - let time_sofar = Unix.gettimeofday () -. time_call_started in - if !connection_timeout < 0. then ( - if not !surpress_no_timeout_logs then ( - debug - "Connection to master died. I will continue to retry \ - indefinitely (supressing future logging of this message)." ; - error - "Connection to master died. I will continue to retry \ - indefinitely (supressing future logging of this message)." - ) ; - surpress_no_timeout_logs := true - ) else - debug - "Connection to master died: time taken so far in this call '%f'; \ - will %s" - time_sofar - ( if !connection_timeout < 0. then - "never timeout" - else - Printf.sprintf "timeout after '%f'" !connection_timeout - ) ; - if time_sofar > !connection_timeout && !connection_timeout >= 0. then - if !restart_on_connection_timeout then ( - debug - "Exceeded timeout for retrying master connection: restarting xapi" ; - !Db_globs.restart_fn () - ) else ( - debug - "Exceeded timeout for retrying master connection: raising \ - Cannot_connect_to_master" ; - raise Cannot_connect_to_master - ) ; - debug "Sleeping %f seconds before retrying master connection..." - !backoff_delay ; - let timed_out = Scheduler.PipeDelay.wait delay !backoff_delay in - if not timed_out then - debug "%s: Sleep interrupted, retrying master connection now" - __FUNCTION__ ; - update_backoff_delay () ; - D.log_and_ignore_exn open_secure_connection + reconnect () done ; !result diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index e8dd8c8312e..662223770f4 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -4,7 +4,9 @@ (wrapped false) (libraries astring + clock fd-send-recv + mtime rpclib.core rpclib.json rpclib.xml diff --git a/ocaml/forkexecd/lib/forkhelpers.ml b/ocaml/forkexecd/lib/forkhelpers.ml index 7b7fc0b2247..2407b86b924 100644 --- a/ocaml/forkexecd/lib/forkhelpers.ml +++ b/ocaml/forkexecd/lib/forkhelpers.ml @@ -315,8 +315,8 @@ let safe_close_and_exec ?tracing ?env stdin stdout stderr close_fds let execute_command_get_output_inner ?tracing ?env ?stdin - ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) - ?(timeout = -1.0) cmd args = + ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) timeout + cmd args = let to_close = ref [] in let close fd = if List.mem fd !to_close then ( @@ -354,8 +354,13 @@ let execute_command_get_output_inner ?tracing ?env ?stdin close wr ) stdinandpipes ; - if timeout > 0. then - Unix.setsockopt_float sock Unix.SO_RCVTIMEO timeout ; + ( match timeout with + | Some span -> + let timeout = Clock.Timer.span_to_s span in + Unix.setsockopt_float sock Unix.SO_RCVTIMEO timeout + | None -> + () + ) ; with_tracing ~tracing ~name:"Forkhelpers.waitpid" @@ fun _ -> try waitpid (sock, pid) with Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> @@ -380,12 +385,12 @@ let execute_command_get_output_inner ?tracing ?env ?stdin let execute_command_get_output ?tracing ?env ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) ?timeout cmd args = with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> - execute_command_get_output_inner ?tracing ?env ?stdin:None ?timeout - ~syslog_stdout ~redirect_stderr_to_stdout cmd args + execute_command_get_output_inner ?tracing ?env ?stdin:None ~syslog_stdout + ~redirect_stderr_to_stdout timeout cmd args let execute_command_get_output_send_stdin ?tracing ?env ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) ?timeout cmd args stdin = with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> execute_command_get_output_inner ?tracing ?env ~stdin ~syslog_stdout - ~redirect_stderr_to_stdout ?timeout cmd args + ~redirect_stderr_to_stdout timeout cmd args diff --git a/ocaml/forkexecd/lib/forkhelpers.mli b/ocaml/forkexecd/lib/forkhelpers.mli index a91afa52a87..b98a03ef5e0 100644 --- a/ocaml/forkexecd/lib/forkhelpers.mli +++ b/ocaml/forkexecd/lib/forkhelpers.mli @@ -48,7 +48,7 @@ val execute_command_get_output : -> ?env:string array -> ?syslog_stdout:syslog_stdout -> ?redirect_stderr_to_stdout:bool - -> ?timeout:float + -> ?timeout:Mtime.Span.t -> string -> string list -> string * string @@ -61,7 +61,7 @@ val execute_command_get_output_send_stdin : -> ?env:string array -> ?syslog_stdout:syslog_stdout -> ?redirect_stderr_to_stdout:bool - -> ?timeout:float + -> ?timeout:Mtime.Span.t -> string -> string list -> string diff --git a/ocaml/forkexecd/src/child.ml b/ocaml/forkexecd/src/child.ml index 1512e3af851..5f79f2fb6c9 100644 --- a/ocaml/forkexecd/src/child.ml +++ b/ocaml/forkexecd/src/child.ml @@ -111,11 +111,11 @@ let report_child_exit comms_sock args child_pid status = Fe.WEXITED n | Unix.WSIGNALED n -> log_failure args child_pid - (Printf.sprintf "exited with signal: %s" (Unixext.string_of_signal n)) ; + (Printf.sprintf "exited with signal: %a" Debug.Pp.signal n) ; Fe.WSIGNALED n | Unix.WSTOPPED n -> log_failure args child_pid - (Printf.sprintf "stopped with signal: %s" (Unixext.string_of_signal n)) ; + (Printf.sprintf "stopped with signal: %a" Debug.Pp.signal n) ; Fe.WSTOPPED n in let result = Fe.Finished pr in diff --git a/ocaml/forkexecd/test/dune b/ocaml/forkexecd/test/dune index 7ab49f0e214..91c90e64188 100644 --- a/ocaml/forkexecd/test/dune +++ b/ocaml/forkexecd/test/dune @@ -1,7 +1,7 @@ (executable (modes exe) (name fe_test) - (libraries forkexec uuid xapi-stdext-unix fd-send-recv)) + (libraries fmt forkexec mtime clock mtime.clock.os uuid xapi-stdext-unix fd-send-recv)) (rule (alias runtest) diff --git a/ocaml/forkexecd/test/fe_test.ml b/ocaml/forkexecd/test/fe_test.ml index 870ac591601..57455ed5dc4 100644 --- a/ocaml/forkexecd/test/fe_test.ml +++ b/ocaml/forkexecd/test/fe_test.ml @@ -115,12 +115,6 @@ let one fds x = :: string_of_int (fds - (x.max_extra - number_of_extra)) :: shuffle cmdline_names in - (* Printf.fprintf stderr "stdin = %s\n" (if x.stdin then "Some" else "None"); - Printf.fprintf stderr "stdout = %s\n" (if x.stdout then "Some" else "None"); - Printf.fprintf stderr "stderr = %s\n" (if x.stderr then "Some" else "None"); - List.iter (fun (uuid, _) -> Printf.fprintf stderr "uuid %s -> stdin\n" uuid) table; - Printf.fprintf stderr "%s %s\n" exe (String.concat " " args); - *) Forkhelpers.waitpid_fail_if_bad_exit (Forkhelpers.safe_close_and_exec (if x.stdin then Some fd else None) @@ -129,26 +123,43 @@ let one fds x = table exe args ) +type in_range = In_range | Longer | Shorter + +let in_range ~e:leeway ~around span = + let upper = Mtime.Span.add around leeway in + if Clock.Timer.span_is_shorter ~than:around span then + Shorter + else if Clock.Timer.span_is_longer ~than:upper span then + Longer + else + In_range + let test_delay () = - let start = Unix.gettimeofday () in + let start = Mtime_clock.counter () in let args = ["sleep"] in (* Need to have fractional part because some internal usage split integer and fractional and do computation. Better to have a high fractional part (> 0.5) to more probably exceed the unit. *) - let timeout = 1.7 in + let timeout = Mtime.Span.(1700 * ms) in try Forkhelpers.execute_command_get_output ~timeout exe args |> ignore ; fail "Failed to timeout" with - | Forkhelpers.Subprocess_timeout -> - let elapsed = Unix.gettimeofday () -. start in - Printf.printf "Caught timeout exception after %f seconds\n%!" elapsed ; - if elapsed < timeout then - failwith "Process exited too soon" ; - if elapsed > timeout +. 0.2 then - failwith "Excessive time elapsed" + | Forkhelpers.Subprocess_timeout -> ( + let elapsed = Mtime_clock.count start in + Printf.printf "Caught timeout exception after %s seconds\n%!" + Fmt.(to_to_string Mtime.Span.pp elapsed) ; + + match in_range ~e:Mtime.Span.(200 * ms) ~around:timeout elapsed with + | In_range -> + () + | Shorter -> + failwith "Process exited too soon" + | Longer -> + failwith "Process took too long to exit" + ) | e -> fail "Failed with unexpected exception: %s" (Printexc.to_string e) @@ -289,9 +300,6 @@ let slave = function ) fds ; (* Check that we have the expected number *) - (* - Printf.fprintf stderr "%s %d\n" total_fds (List.length present - 1) - *) if total_fds <> List.length filtered then fail "Expected %d fds; /proc/self/fd has %d: %s" total_fds (List.length filtered) ls diff --git a/ocaml/gencert/pem.ml b/ocaml/gencert/pem.ml index 436fa73e4fd..9a9354babdb 100644 --- a/ocaml/gencert/pem.ml +++ b/ocaml/gencert/pem.ml @@ -18,10 +18,16 @@ type t = {private_key: string; host_cert: string; other_certs: string list} let is_data = function '-' -> false | _ -> true +let is_eol = function '\n' | '\r' -> true | _ -> false + let data = take_while1 is_data type kind = RSA | EC | OTHER +type block = Key of string | Cert of string + +let fail_fmt fmt = Printf.ksprintf (fun str -> fail str) fmt + let kind = string " RSA " *> return RSA <|> string " EC " *> return EC @@ -43,29 +49,54 @@ let footer = function | OTHER -> "-----END PRIVATE KEY-----" -let key_header = string "-----BEGIN" *> kind <* string "PRIVATE KEY-----" +let key_header = + string "-----BEGIN" *> kind <* string "PRIVATE KEY-----" "key_header" -let key_footer k = string (footer k) +let key_footer k = string (footer k) "key_footer" -let cert_header = string "-----BEGIN CERTIFICATE-----" +let cert_header = string "-----BEGIN CERTIFICATE-----" "cert_header" -let cert_footer = string "-----END CERTIFICATE-----" +let cert_footer = string "-----END CERTIFICATE-----" "cert_footer" let key = key_header >>= fun kind -> data >>= fun body -> key_footer kind *> return (String.concat "" [header kind; body; footer kind]) + "key" let cert = cert_header >>= fun hd -> data >>= fun body -> - cert_footer >>= fun tl -> return (String.concat "" [hd; body; tl]) + cert_footer >>= fun tl -> return (String.concat "" [hd; body; tl]) "cert" + +let line = take_till is_eol *> end_of_line + +let any_block = + cert >>= (fun c -> return (Cert c)) <|> (key >>= fun k -> return (Key k)) +(* this skips over junk until we succeed finding the next block *) +let block = fix (fun m -> any_block <|> line *> m) "until_block" + +(* collect and tag all blocks *) +let blocks = many block "PEM blocks" + +(* decompose blocks into certs and keys *) let pem = - many end_of_line *> key >>= fun private_key -> - many end_of_line *> cert >>= fun host_cert -> - many end_of_line *> many cert >>= fun other_certs -> - many end_of_line *> return {private_key; host_cert; other_certs} + let ( let* ) = ( >>= ) in + let strip = function Cert c -> c | Key k -> k in + blocks >>= fun bs -> + match List.partition (function Key _ -> true | Cert _ -> false) bs with + | [Key k], Cert c :: xs -> + return {private_key= k; host_cert= c; other_certs= List.map strip xs} + | [_], [] -> + let* p = pos in + fail_fmt "PEM is lacking a certificate (at offset %d)" p + | [], _ -> + let* p = pos in + fail_fmt "PEM is missing a private key (at offset %d)" p + | _ :: _, _ -> + let* p = pos in + fail_fmt "PEM has more than one private key (at offset %d)" p let defer f = Fun.protect ~finally:f @@ -74,6 +105,10 @@ let read_file path = defer (fun () -> close_in ic) @@ fun () -> really_input_string ic (in_channel_length ic) +let _parse_with t path = + let consume = Consume.Prefix in + read_file path |> parse_string ~consume t + let parse_string str = let consume = Consume.Prefix in parse_string ~consume pem str diff --git a/ocaml/gencert/test_data/pems/fail-01.pem b/ocaml/gencert/test_data/pems/pass-05.pem similarity index 100% rename from ocaml/gencert/test_data/pems/fail-01.pem rename to ocaml/gencert/test_data/pems/pass-05.pem diff --git a/ocaml/gencert/test_data/pems/pass-06.pem b/ocaml/gencert/test_data/pems/pass-06.pem new file mode 100644 index 00000000000..18d7d7e0a96 --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-06.pem @@ -0,0 +1,109 @@ +Multiple certificates and one key. + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + + +-----BEGIN PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH +tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI +r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 +eniepJw4K+SMqAaGUvdwWfe44pYjOsmAS3IWLERdpjxcupgvHLwEnk+4zheypp93 +iVvmqwrX8okLiJJZap1ew6EgKzeK2mw9HUed4d0AGKCkAhghzGTl/IsLz4QOOFes +rY4awQwzK1SwBvF49xAuOiRbURdzt+K7GsoN0lm5P8CxZmrDSGpGR1BICrMSatSG +N0NuOCJ9AgMBAAECggEATgm51VKZ0+Kew5Twjzo9bqGawPVHsiYDK9H+yL5+inij +gTWrhTWxxvq/KDwoS//6n3ipAd2UQNmfo5qQIsIJtawUsaw4V4Fh6BrIcGUUV3KK +8lG/bHoZOz0cfFCKewv5mJH4z/q9awk6ypVG3yb+kmoDHiJsy7Pmr0IpFn+qxMg1 +EYZU91G10DguXekciRtNcZJRL0wCQR3s2OwDdQUC+XIotvAsKiuhWl++MLwn42ad +EwhzLuLd312qWg58ByCcNq8/XJkHJUbKDTWmBRGopWRliduP+Kb6vJZ16KL0G2B+ +OKuTQxMOzVVmumXdEVj3kH54cjpn7kCq9jwhhSJiQQKBgQD94ZFOzsUzZfmNlDZ3 +hFmkFuFpQCacH58FQX/vD6JQ84HwEHJx69aHYI6olCNaKcNwMhsOw+0KqBRWZnCf +A6oMWUf3pkogV5JZJy7DyHNOmkfI/w8NcWtqJ03pCoA237f5RH0sul2ady9BVzsJ +/8rb3B5uDw8+XesnG8Ryj6BCsQKBgQD9rhKfHxJgsZUzyassIumYcLTefgdoeCq5 +awd+YaM9jrGGN1ty8dTEzo3rbovnz8y+ZJMzaDRbCUeNTQjKDox8mWffRTpjxcks +rJzImY7coBdnZT8K4C5OMoeCAr30FI1veXBk/XFfr56h1X8QbmM2kuJwpsf5bOaf +CTfL2q2XjQKBgHem4pvYuXoC2n1OV+k2GCVMn0nCcS/tez234/qgTKiISzoAFl/4 +fW/qIvHyd0LcIf7zrmrkDgiStJsPxo465N7TCSb/WToq649W9yRQiX+HGMPy6X41 +cSFjisWFLG4wO/2fuLrmzoypFT1fRjTtOAcsk67dLBsBmn0hChHP/QDRAoGASXS7 +XaogpzEk1A8kaq5dV8/i/74cpQqOzIwKanUZULzd+NBUwa72/loVTEQBbQmF7ueu +nCcjae0A9BCHaALYeUfuhP9Fzhg6jZ4Z9BhK/uW4gS8XFy4dGnWVOXdTy7ab0din +TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH +ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT +6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo +FIPEq03cDKVNDCgABw4mkw== +-----END PRIVATE KEY----- + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + + diff --git a/ocaml/gencert/test_data/pems/pass-extra-lines-multiple-certs.pem b/ocaml/gencert/test_data/pems/pass-extra-lines-multiple-certs.pem new file mode 100644 index 00000000000..eeb088698a2 --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-extra-lines-multiple-certs.pem @@ -0,0 +1,87 @@ +extra line +-----BEGIN RSA PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH +tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI +r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 +eniepJw4K+SMqAaGUvdwWfe44pYjOsmAS3IWLERdpjxcupgvHLwEnk+4zheypp93 +iVvmqwrX8okLiJJZap1ew6EgKzeK2mw9HUed4d0AGKCkAhghzGTl/IsLz4QOOFes +rY4awQwzK1SwBvF49xAuOiRbURdzt+K7GsoN0lm5P8CxZmrDSGpGR1BICrMSatSG +N0NuOCJ9AgMBAAECggEATgm51VKZ0+Kew5Twjzo9bqGawPVHsiYDK9H+yL5+inij +gTWrhTWxxvq/KDwoS//6n3ipAd2UQNmfo5qQIsIJtawUsaw4V4Fh6BrIcGUUV3KK +8lG/bHoZOz0cfFCKewv5mJH4z/q9awk6ypVG3yb+kmoDHiJsy7Pmr0IpFn+qxMg1 +EYZU91G10DguXekciRtNcZJRL0wCQR3s2OwDdQUC+XIotvAsKiuhWl++MLwn42ad +EwhzLuLd312qWg58ByCcNq8/XJkHJUbKDTWmBRGopWRliduP+Kb6vJZ16KL0G2B+ +OKuTQxMOzVVmumXdEVj3kH54cjpn7kCq9jwhhSJiQQKBgQD94ZFOzsUzZfmNlDZ3 +hFmkFuFpQCacH58FQX/vD6JQ84HwEHJx69aHYI6olCNaKcNwMhsOw+0KqBRWZnCf +A6oMWUf3pkogV5JZJy7DyHNOmkfI/w8NcWtqJ03pCoA237f5RH0sul2ady9BVzsJ +/8rb3B5uDw8+XesnG8Ryj6BCsQKBgQD9rhKfHxJgsZUzyassIumYcLTefgdoeCq5 +awd+YaM9jrGGN1ty8dTEzo3rbovnz8y+ZJMzaDRbCUeNTQjKDox8mWffRTpjxcks +rJzImY7coBdnZT8K4C5OMoeCAr30FI1veXBk/XFfr56h1X8QbmM2kuJwpsf5bOaf +CTfL2q2XjQKBgHem4pvYuXoC2n1OV+k2GCVMn0nCcS/tez234/qgTKiISzoAFl/4 +fW/qIvHyd0LcIf7zrmrkDgiStJsPxo465N7TCSb/WToq649W9yRQiX+HGMPy6X41 +cSFjisWFLG4wO/2fuLrmzoypFT1fRjTtOAcsk67dLBsBmn0hChHP/QDRAoGASXS7 +XaogpzEk1A8kaq5dV8/i/74cpQqOzIwKanUZULzd+NBUwa72/loVTEQBbQmF7ueu +nCcjae0A9BCHaALYeUfuhP9Fzhg6jZ4Z9BhK/uW4gS8XFy4dGnWVOXdTy7ab0din +TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH +ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT +6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo +FIPEq03cDKVNDCgABw4mkw== +-----END RSA PRIVATE KEY----- +extra line +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- +extra line +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- +extra line +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- +extra line diff --git a/ocaml/gencert/test_data/pems/pass-extra-lines-one-cert.pem b/ocaml/gencert/test_data/pems/pass-extra-lines-one-cert.pem new file mode 100644 index 00000000000..bc43f444a28 --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-extra-lines-one-cert.pem @@ -0,0 +1,49 @@ +extra line +-----BEGIN PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH +tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI +r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 +eniepJw4K+SMqAaGUvdwWfe44pYjOsmAS3IWLERdpjxcupgvHLwEnk+4zheypp93 +iVvmqwrX8okLiJJZap1ew6EgKzeK2mw9HUed4d0AGKCkAhghzGTl/IsLz4QOOFes +rY4awQwzK1SwBvF49xAuOiRbURdzt+K7GsoN0lm5P8CxZmrDSGpGR1BICrMSatSG +N0NuOCJ9AgMBAAECggEATgm51VKZ0+Kew5Twjzo9bqGawPVHsiYDK9H+yL5+inij +gTWrhTWxxvq/KDwoS//6n3ipAd2UQNmfo5qQIsIJtawUsaw4V4Fh6BrIcGUUV3KK +8lG/bHoZOz0cfFCKewv5mJH4z/q9awk6ypVG3yb+kmoDHiJsy7Pmr0IpFn+qxMg1 +EYZU91G10DguXekciRtNcZJRL0wCQR3s2OwDdQUC+XIotvAsKiuhWl++MLwn42ad +EwhzLuLd312qWg58ByCcNq8/XJkHJUbKDTWmBRGopWRliduP+Kb6vJZ16KL0G2B+ +OKuTQxMOzVVmumXdEVj3kH54cjpn7kCq9jwhhSJiQQKBgQD94ZFOzsUzZfmNlDZ3 +hFmkFuFpQCacH58FQX/vD6JQ84HwEHJx69aHYI6olCNaKcNwMhsOw+0KqBRWZnCf +A6oMWUf3pkogV5JZJy7DyHNOmkfI/w8NcWtqJ03pCoA237f5RH0sul2ady9BVzsJ +/8rb3B5uDw8+XesnG8Ryj6BCsQKBgQD9rhKfHxJgsZUzyassIumYcLTefgdoeCq5 +awd+YaM9jrGGN1ty8dTEzo3rbovnz8y+ZJMzaDRbCUeNTQjKDox8mWffRTpjxcks +rJzImY7coBdnZT8K4C5OMoeCAr30FI1veXBk/XFfr56h1X8QbmM2kuJwpsf5bOaf +CTfL2q2XjQKBgHem4pvYuXoC2n1OV+k2GCVMn0nCcS/tez234/qgTKiISzoAFl/4 +fW/qIvHyd0LcIf7zrmrkDgiStJsPxo465N7TCSb/WToq649W9yRQiX+HGMPy6X41 +cSFjisWFLG4wO/2fuLrmzoypFT1fRjTtOAcsk67dLBsBmn0hChHP/QDRAoGASXS7 +XaogpzEk1A8kaq5dV8/i/74cpQqOzIwKanUZULzd+NBUwa72/loVTEQBbQmF7ueu +nCcjae0A9BCHaALYeUfuhP9Fzhg6jZ4Z9BhK/uW4gS8XFy4dGnWVOXdTy7ab0din +TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH +ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT +6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo +FIPEq03cDKVNDCgABw4mkw== +-----END PRIVATE KEY----- +extra line +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- +extra line diff --git a/ocaml/gencert/test_data/pems/pass-xsi-1781-reformat.pem b/ocaml/gencert/test_data/pems/pass-xsi-1781-reformat.pem new file mode 100644 index 00000000000..b0e3cf8288f --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-xsi-1781-reformat.pem @@ -0,0 +1,51 @@ +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQC7qKYiCfucgzLI +X78/NTAtFXA97Cp3PfnQwpi90tF0YmWUObOdVdxP2FHvUTyMhItpvimsvztX503D +C0Q7lI9/omK3AbPPy51lhRCKTMiz8ic2fmiHU9lePmkZMZJv0p/eHgAIcOmIl5Kc +uvoKvOutLnFTRKrYhUQMu2eyBz0f8rzY/4yhLLNflkQUJ3zc3W0jeMuAUei7Zmtz +jpj+s3Ll5rwzVYG3xLbndzpCR7NaP5uZcchByhsirohR90m3dQtrFdtLTkiDJ8vJ +hW7z3AzAA0Btw/CtH1/Ef/rHt3XHKGMJoJ3nQ2zRvSutdrRSAknNqYONe0hyrLvy +MRGno7SjAgMBAAECggEANHjKw1fRQAk7aOXE3xKrPt/wu4/Oq/rrYGEZPnK1WHqu +9oxP2d2JNdZBys4HRS9GoDGpC4GJQWIOz0vWL2ax3Tl1qsBSG/dOMnXLkzA3KoG6 +TzV3WueqLvz6fC3tSVE2nG/9CF8yHZxsRWDOy7PZnloPG/5mWxagWYMJUrFNeSH2 +nXd40Rff5uM43OzKtiOOzoKv2bKlKReyJVcI98MkyqSbUiie6qO1/NqrOUhq7rsV +zFmbtjy8UL4gXR2VVz0itb/w/iV/SDVHdMQ36obo8EM9eyxUFu4QPscrbK0FvjHV +lsKTnzu1zj/fm68NafXDy/KL5I9jethsj8ReNaQzoQKBgQDLkaIxBtNtAZfcFK7S +dXtR7fIQfUTtgDrxznYXPqCkCy/0wp53hj7aShX2C/rfFQVElBUPkf2E/P6v7Xnf +b+M/Zj6TH7XYbScoVu+8cqfIm1ySd3evK4GoqGIUiJeuSYEfeLqZSTp1XxO05lGb +ZmAEtZUHor24Co9HIV/3P86EcwKBgQDr/fqn6b6V1O64r7/cnOmWhW1+5MjoWO2K ++y0fSutrPMOFK4ItJIk4Q5JbHA42cwyYRMe+oElGXzWJXGbqxyorFhW0Er/+roTa +6GXwNrRkdA3S0rgPAE7IS42WLDsAO9/muiZJ4heXtk8i0xDoyy3Y8UQ/6hR4h1px +jtn9Bs4zEQKBgBdW+TuZxr/mwNyQ2oJyydLY7zoIwtBgNWHoBA4iNhTY24S6k6Ss +laQ9fksZkIfnRxVXzRpd6K1IvIK7PY/qqilotZ/0sMrBqQ2s+gunMamEdpasb+J7 +oIAP3j7wckOfVdif5PUSOkuevQmupoiksjmYACBB/nKNc2P6ZaBZhnoVAoGBAJuc +4z777BeCzFNuWJaRxZniq9wj4rMLiL+/dvaOgYQ6EjdrBDDeSbmXHRgE/P48iQ6T +NB9oNEk6GORV0Ot5nz3AF1mhj4bR73smCaoHeJZQzJi7KHGD429CGr/utI0n7jGH +iB3p/2Kj7bTp9tl6uOW32ihHI26C2knNR8MITMnxAoGAZ+Dpg1a6u2ZMTSgOn9Vc +pECwENGtOQP4RKyXmnq3ET5ykx1hMMCf9uoA09TXDRuJ/20hVfsAGvLZdbQq/9DL +C3bckcoalhy8RXC/OV9c6SC/xgoYiggxmZtzV34wnQSLM4Cr+Q/lhOaj7sop6iJi +apYRps2sXbUdu3pDTub/zSI= +-----END PRIVATE KEY----- +-----BEGIN CERTIFICATE----- +MIIDwzCCAqugAwIBAgIUZeSD7KNhTFOoqpI7cWxxWcN417EwDQYJKoZIhvcNAQEL +BQAwcTELMAkGA1UEBhMCVUsxEzARBgNVBAgMClNvbWUtU3RhdGUxEjAQBgNVBAcM +CUNhbWJyaWRnZTEPMA0GA1UECgwGQ2l0cml4MRIwEAYDVQQLDAlYZW5TZXJ2ZXIx +FDASBgNVBAMMC2V4YW1wbGUuY29tMB4XDTI1MDExNDE1NDIwMFoXDTM1MDExMjE1 +NDIwMFowcTELMAkGA1UEBhMCVUsxEzARBgNVBAgMClNvbWUtU3RhdGUxEjAQBgNV +BAcMCUNhbWJyaWRnZTEPMA0GA1UECgwGQ2l0cml4MRIwEAYDVQQLDAlYZW5TZXJ2 +ZXIxFDASBgNVBAMMC2V4YW1wbGUuY29tMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A +MIIBCgKCAQEAu6imIgn7nIMyyF+/PzUwLRVwPewqdz350MKYvdLRdGJllDmznVXc +T9hR71E8jISLab4prL87V+dNwwtEO5SPf6JitwGzz8udZYUQikzIs/InNn5oh1PZ +Xj5pGTGSb9Kf3h4ACHDpiJeSnLr6CrzrrS5xU0Sq2IVEDLtnsgc9H/K82P+MoSyz +X5ZEFCd83N1tI3jLgFHou2Zrc46Y/rNy5ea8M1WBt8S253c6QkezWj+bmXHIQcob +Iq6IUfdJt3ULaxXbS05IgyfLyYVu89wMwANAbcPwrR9fxH/6x7d1xyhjCaCd50Ns +0b0rrXa0UgJJzamDjXtIcqy78jERp6O0owIDAQABo1MwUTAdBgNVHQ4EFgQUK3or +CHusUjk/eheKHz6JMuYQBkAwHwYDVR0jBBgwFoAUK3orCHusUjk/eheKHz6JMuYQ +BkAwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEATq7rhHQE3xSk +NUsD1dIFUwz7NJ1eIbdNQ8kJGybcTkIsBY9PrUcrnXFozEE05dZaZizCK/F0To3v +903kVAwaBe04sZuIqAVDHAjewH2yfCAIRkgA6RPnSHio6NTCLMi3Ukqrhj5bIFGy +eqcAKy0akXeV3uLIKKY/ZdNpPRP5gW2UZpC+p9ZBEcVDNKAWEK+GVLDar1MLdyIp +XyCp4wimx4iK+TyXEYKRK7G5+/HPtYOU2OrHtuUFnppz4G5/QuyuDO7yDAJaK8X/ +9hIuR4tcxzt3FdBMVXju5PViMpKbpw5XslbGxdAFFCSrkSRvzYw98tq7HkUB5IyV +OgjjLNHdJg== +-----END CERTIFICATE----- diff --git a/ocaml/gencert/test_data/pems/pass-xsi-1781.pem b/ocaml/gencert/test_data/pems/pass-xsi-1781.pem new file mode 100644 index 00000000000..7623c6e5cf0 --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-xsi-1781.pem @@ -0,0 +1,111 @@ +Certificate: + Data: + Version: 3 (0x2) + Serial Number: + 65:e4:83:ec:a3:61:4c:53:a8:aa:92:3b:71:6c:71:59:c3:78:d7:b1 + Signature Algorithm: sha256WithRSAEncryption + Issuer: C = UK, ST = Some-State, L = Cambridge, O = Citrix, OU = XenServer, CN = example.com + Validity + Not Before: Jan 14 15:42:00 2025 GMT + Not After : Jan 12 15:42:00 2035 GMT + Subject: C = UK, ST = Some-State, L = Cambridge, O = Citrix, OU = XenServer, CN = example.com + Subject Public Key Info: + Public Key Algorithm: rsaEncryption + Public-Key: (2048 bit) + Modulus: + 00:bb:a8:a6:22:09:fb:9c:83:32:c8:5f:bf:3f:35: + 30:2d:15:70:3d:ec:2a:77:3d:f9:d0:c2:98:bd:d2: + d1:74:62:65:94:39:b3:9d:55:dc:4f:d8:51:ef:51: + 3c:8c:84:8b:69:be:29:ac:bf:3b:57:e7:4d:c3:0b: + 44:3b:94:8f:7f:a2:62:b7:01:b3:cf:cb:9d:65:85: + 10:8a:4c:c8:b3:f2:27:36:7e:68:87:53:d9:5e:3e: + 69:19:31:92:6f:d2:9f:de:1e:00:08:70:e9:88:97: + 92:9c:ba:fa:0a:bc:eb:ad:2e:71:53:44:aa:d8:85: + 44:0c:bb:67:b2:07:3d:1f:f2:bc:d8:ff:8c:a1:2c: + b3:5f:96:44:14:27:7c:dc:dd:6d:23:78:cb:80:51: + e8:bb:66:6b:73:8e:98:fe:b3:72:e5:e6:bc:33:55: + 81:b7:c4:b6:e7:77:3a:42:47:b3:5a:3f:9b:99:71: + c8:41:ca:1b:22:ae:88:51:f7:49:b7:75:0b:6b:15: + db:4b:4e:48:83:27:cb:c9:85:6e:f3:dc:0c:c0:03: + 40:6d:c3:f0:ad:1f:5f:c4:7f:fa:c7:b7:75:c7:28: + 63:09:a0:9d:e7:43:6c:d1:bd:2b:ad:76:b4:52:02: + 49:cd:a9:83:8d:7b:48:72:ac:bb:f2:31:11:a7:a3: + b4:a3 + Exponent: 65537 (0x10001) + X509v3 extensions: + X509v3 Subject Key Identifier: + 2B:7A:2B:08:7B:AC:52:39:3F:7A:17:8A:1F:3E:89:32:E6:10:06:40 + X509v3 Authority Key Identifier: + 2B:7A:2B:08:7B:AC:52:39:3F:7A:17:8A:1F:3E:89:32:E6:10:06:40 + X509v3 Basic Constraints: critical + CA:TRUE + Signature Algorithm: sha256WithRSAEncryption + Signature Value: + 4e:ae:eb:84:74:04:df:14:a4:35:4b:03:d5:d2:05:53:0c:fb: + 34:9d:5e:21:b7:4d:43:c9:09:1b:26:dc:4e:42:2c:05:8f:4f: + ad:47:2b:9d:71:68:cc:41:34:e5:d6:5a:66:2c:c2:2b:f1:74: + 4e:8d:ef:f7:4d:e4:54:0c:1a:05:ed:38:b1:9b:88:a8:05:43: + 1c:08:de:c0:7d:b2:7c:20:08:46:48:00:e9:13:e7:48:78:a8: + e8:d4:c2:2c:c8:b7:52:4a:ab:86:3e:5b:20:51:b2:7a:a7:00: + 2b:2d:1a:91:77:95:de:e2:c8:28:a6:3f:65:d3:69:3d:13:f9: + 81:6d:94:66:90:be:a7:d6:41:11:c5:43:34:a0:16:10:af:86: + 54:b0:da:af:53:0b:77:22:29:5f:20:a9:e3:08:a6:c7:88:8a: + f9:3c:97:11:82:91:2b:b1:b9:fb:f1:cf:b5:83:94:d8:ea:c7: + b6:e5:05:9e:9a:73:e0:6e:7f:42:ec:ae:0c:ee:f2:0c:02:5a: + 2b:c5:ff:f6:12:2e:47:8b:5c:c7:3b:77:15:d0:4c:55:78:ee: + e4:f5:62:32:92:9b:a7:0e:57:b2:56:c6:c5:d0:05:14:24:ab: + 91:24:6f:cd:8c:3d:f2:da:bb:1e:45:01:e4:8c:95:3a:08:e3: + 2c:d1:dd:26 +-----BEGIN CERTIFICATE----- +MIIDwzCCAqugAwIBAgIUZeSD7KNhTFOoqpI7cWxxWcN417EwDQYJKoZIhvcNAQEL +BQAwcTELMAkGA1UEBhMCVUsxEzARBgNVBAgMClNvbWUtU3RhdGUxEjAQBgNVBAcM +CUNhbWJyaWRnZTEPMA0GA1UECgwGQ2l0cml4MRIwEAYDVQQLDAlYZW5TZXJ2ZXIx +FDASBgNVBAMMC2V4YW1wbGUuY29tMB4XDTI1MDExNDE1NDIwMFoXDTM1MDExMjE1 +NDIwMFowcTELMAkGA1UEBhMCVUsxEzARBgNVBAgMClNvbWUtU3RhdGUxEjAQBgNV +BAcMCUNhbWJyaWRnZTEPMA0GA1UECgwGQ2l0cml4MRIwEAYDVQQLDAlYZW5TZXJ2 +ZXIxFDASBgNVBAMMC2V4YW1wbGUuY29tMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A +MIIBCgKCAQEAu6imIgn7nIMyyF+/PzUwLRVwPewqdz350MKYvdLRdGJllDmznVXc +T9hR71E8jISLab4prL87V+dNwwtEO5SPf6JitwGzz8udZYUQikzIs/InNn5oh1PZ +Xj5pGTGSb9Kf3h4ACHDpiJeSnLr6CrzrrS5xU0Sq2IVEDLtnsgc9H/K82P+MoSyz +X5ZEFCd83N1tI3jLgFHou2Zrc46Y/rNy5ea8M1WBt8S253c6QkezWj+bmXHIQcob +Iq6IUfdJt3ULaxXbS05IgyfLyYVu89wMwANAbcPwrR9fxH/6x7d1xyhjCaCd50Ns +0b0rrXa0UgJJzamDjXtIcqy78jERp6O0owIDAQABo1MwUTAdBgNVHQ4EFgQUK3or +CHusUjk/eheKHz6JMuYQBkAwHwYDVR0jBBgwFoAUK3orCHusUjk/eheKHz6JMuYQ +BkAwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEATq7rhHQE3xSk +NUsD1dIFUwz7NJ1eIbdNQ8kJGybcTkIsBY9PrUcrnXFozEE05dZaZizCK/F0To3v +903kVAwaBe04sZuIqAVDHAjewH2yfCAIRkgA6RPnSHio6NTCLMi3Ukqrhj5bIFGy +eqcAKy0akXeV3uLIKKY/ZdNpPRP5gW2UZpC+p9ZBEcVDNKAWEK+GVLDar1MLdyIp +XyCp4wimx4iK+TyXEYKRK7G5+/HPtYOU2OrHtuUFnppz4G5/QuyuDO7yDAJaK8X/ +9hIuR4tcxzt3FdBMVXju5PViMpKbpw5XslbGxdAFFCSrkSRvzYw98tq7HkUB5IyV +OgjjLNHdJg== +-----END CERTIFICATE----- + + +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQC7qKYiCfucgzLI +X78/NTAtFXA97Cp3PfnQwpi90tF0YmWUObOdVdxP2FHvUTyMhItpvimsvztX503D +C0Q7lI9/omK3AbPPy51lhRCKTMiz8ic2fmiHU9lePmkZMZJv0p/eHgAIcOmIl5Kc +uvoKvOutLnFTRKrYhUQMu2eyBz0f8rzY/4yhLLNflkQUJ3zc3W0jeMuAUei7Zmtz +jpj+s3Ll5rwzVYG3xLbndzpCR7NaP5uZcchByhsirohR90m3dQtrFdtLTkiDJ8vJ +hW7z3AzAA0Btw/CtH1/Ef/rHt3XHKGMJoJ3nQ2zRvSutdrRSAknNqYONe0hyrLvy +MRGno7SjAgMBAAECggEANHjKw1fRQAk7aOXE3xKrPt/wu4/Oq/rrYGEZPnK1WHqu +9oxP2d2JNdZBys4HRS9GoDGpC4GJQWIOz0vWL2ax3Tl1qsBSG/dOMnXLkzA3KoG6 +TzV3WueqLvz6fC3tSVE2nG/9CF8yHZxsRWDOy7PZnloPG/5mWxagWYMJUrFNeSH2 +nXd40Rff5uM43OzKtiOOzoKv2bKlKReyJVcI98MkyqSbUiie6qO1/NqrOUhq7rsV +zFmbtjy8UL4gXR2VVz0itb/w/iV/SDVHdMQ36obo8EM9eyxUFu4QPscrbK0FvjHV +lsKTnzu1zj/fm68NafXDy/KL5I9jethsj8ReNaQzoQKBgQDLkaIxBtNtAZfcFK7S +dXtR7fIQfUTtgDrxznYXPqCkCy/0wp53hj7aShX2C/rfFQVElBUPkf2E/P6v7Xnf +b+M/Zj6TH7XYbScoVu+8cqfIm1ySd3evK4GoqGIUiJeuSYEfeLqZSTp1XxO05lGb +ZmAEtZUHor24Co9HIV/3P86EcwKBgQDr/fqn6b6V1O64r7/cnOmWhW1+5MjoWO2K ++y0fSutrPMOFK4ItJIk4Q5JbHA42cwyYRMe+oElGXzWJXGbqxyorFhW0Er/+roTa +6GXwNrRkdA3S0rgPAE7IS42WLDsAO9/muiZJ4heXtk8i0xDoyy3Y8UQ/6hR4h1px +jtn9Bs4zEQKBgBdW+TuZxr/mwNyQ2oJyydLY7zoIwtBgNWHoBA4iNhTY24S6k6Ss +laQ9fksZkIfnRxVXzRpd6K1IvIK7PY/qqilotZ/0sMrBqQ2s+gunMamEdpasb+J7 +oIAP3j7wckOfVdif5PUSOkuevQmupoiksjmYACBB/nKNc2P6ZaBZhnoVAoGBAJuc +4z777BeCzFNuWJaRxZniq9wj4rMLiL+/dvaOgYQ6EjdrBDDeSbmXHRgE/P48iQ6T +NB9oNEk6GORV0Ot5nz3AF1mhj4bR73smCaoHeJZQzJi7KHGD429CGr/utI0n7jGH +iB3p/2Kj7bTp9tl6uOW32ihHI26C2knNR8MITMnxAoGAZ+Dpg1a6u2ZMTSgOn9Vc +pECwENGtOQP4RKyXmnq3ET5ykx1hMMCf9uoA09TXDRuJ/20hVfsAGvLZdbQq/9DL +C3bckcoalhy8RXC/OV9c6SC/xgoYiggxmZtzV34wnQSLM4Cr+Q/lhOaj7sop6iJi +apYRps2sXbUdu3pDTub/zSI= +-----END PRIVATE KEY----- diff --git a/ocaml/gencert/test_data/reformat.sh b/ocaml/gencert/test_data/reformat.sh new file mode 100755 index 00000000000..67bb040f08c --- /dev/null +++ b/ocaml/gencert/test_data/reformat.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash +# parse a PEM file for certificate and key and emit them again as a PEM +# to stdout. This is in response to XSI-1781. + +set -o errexit +set -o pipefail +if [[ -n "$TRACE" ]]; then set -o xtrace; fi +set -o nounset + +if [[ "${1-}" =~ ^-*h(elp)?$ ]]; then + cat < log_backtrace_internal ~level:Syslog.Debug ~msg:"debug" e () end -module Pp = struct let mtime_span () = Fmt.str "%a" Mtime.Span.pp end +module Pp = struct + let mtime_span () = Fmt.to_to_string Mtime.Span.pp + + let signal () = Fmt.(to_to_string Dump.signal) +end diff --git a/ocaml/libs/log/debug.mli b/ocaml/libs/log/debug.mli index f6301c3d587..4ba72886ce6 100644 --- a/ocaml/libs/log/debug.mli +++ b/ocaml/libs/log/debug.mli @@ -91,4 +91,8 @@ val is_disabled : string -> Syslog.level -> bool module Pp : sig val mtime_span : unit -> Mtime.Span.t -> string + + val signal : unit -> int -> string + (** signal pretty-prints an ocaml signal number as its POSIX name, see + {Fmt.Dump.signal} *) end diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index 6b7d42608e7..0f5c74564c8 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -448,44 +448,30 @@ let with_connect ?unique_id ?use_fork_exec_helper ?write_to_log ~verify_cert ) 5 -let with_client_proxy ~verify_cert ~remote_host ~remote_port ~local_host - ~local_port f = - ( try - D.debug "Clean up running stunnel client proxy if there is any ..." ; - let out, _ = - Forkhelpers.execute_command_get_output "/usr/sbin/fuser" - ["-4k"; string_of_int local_port ^ "/tcp"] - in - D.debug "Killed running stunnel client proxy:%s" out - with - | Forkhelpers.Spawn_internal_error (stderr, stdout, process_status) -> ( - match process_status with - | Unix.WEXITED 1 -> - D.debug "No running stunnel client proxy" - | _ -> - D.warn - "Cleaning up running stunnel client proxy returned unexpectedly: \ - stdout=(%s); stderr=(%s)" - stdout stderr - ) - ) ; - - retry +let with_client_proxy_systemd_service ~verify_cert ~remote_host ~remote_port + ~local_host ~local_port ~service f = + let cmd_path = stunnel_path () in + let config = + config_file + ~accept:(Some (local_host, local_port)) + verify_cert remote_host remote_port + in + let stop () = ignore (Fe_systemctl.stop ~service) in + (* Try stopping anyway before starting it. *) + ignore_exn stop () ; + let conf_path, out = Filename.open_temp_file service ".conf" in + let finally = Xapi_stdext_pervasives.Pervasiveext.finally in + finally (fun () -> - let pid, _ = - attempt_one_connect - (`Local_host_port (local_host, local_port)) - verify_cert remote_host remote_port - in - D.debug "Started a client proxy (pid:%s): %s:%s -> %s:%s" - (string_of_int (getpid pid)) - local_host (string_of_int local_port) remote_host - (string_of_int remote_port) ; - Xapi_stdext_pervasives.Pervasiveext.finally - (fun () -> f ()) - (fun () -> disconnect_with_pid ~wait:false ~force:true pid) + finally (fun () -> output_string out config) (fun () -> close_out out) ; + finally + (fun () -> + Fe_systemctl.start_transient ~service cmd_path [conf_path] ; + f () + ) + (fun () -> ignore_exn stop ()) ) - 5 + (fun () -> Unixext.unlink_safe conf_path) let check_verify_error line = let sub_after i s = diff --git a/ocaml/libs/stunnel/stunnel.mli b/ocaml/libs/stunnel/stunnel.mli index eba084a9ef2..99fcba608ce 100644 --- a/ocaml/libs/stunnel/stunnel.mli +++ b/ocaml/libs/stunnel/stunnel.mli @@ -88,11 +88,12 @@ val with_moved_exn : t -> (t -> 'd) -> 'd val safe_release : t -> unit -val with_client_proxy : +val with_client_proxy_systemd_service : verify_cert:verification_config option -> remote_host:string -> remote_port:int -> local_host:string -> local_port:int + -> service:string -> (unit -> 'a) -> 'a diff --git a/ocaml/libs/xapi-compression/xapi_compression.ml b/ocaml/libs/xapi-compression/xapi_compression.ml index a0ca8bdc6d5..7349cdef732 100644 --- a/ocaml/libs/xapi-compression/xapi_compression.ml +++ b/ocaml/libs/xapi-compression/xapi_compression.ml @@ -123,7 +123,6 @@ module Make (Algorithm : ALGORITHM) = struct error "%s" msg ; failwith msg in Unixfd.safe_close close_later ; - let open Xapi_stdext_unix in match snd (Forkhelpers.waitpid pid) with | Unix.WEXITED 0 -> () @@ -131,14 +130,10 @@ module Make (Algorithm : ALGORITHM) = struct failwith_error (Printf.sprintf "exit code %d" i) | Unix.WSIGNALED i -> failwith_error - (Printf.sprintf "killed by signal: %s" - (Unixext.string_of_signal i) - ) + (Printf.sprintf "killed by signal: %a" Debug.Pp.signal i) | Unix.WSTOPPED i -> failwith_error - (Printf.sprintf "stopped by signal: %s" - (Unixext.string_of_signal i) - ) + (Printf.sprintf "stopped by signal: %a" Debug.Pp.signal i) ) let compress fd f = go Compress Active fd f diff --git a/ocaml/libs/xapi-rrd/lib/rrd.ml b/ocaml/libs/xapi-rrd/lib/rrd.ml index c9d646345cd..6667f2a4f5c 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd.ml @@ -341,9 +341,10 @@ let rra_update rrd proc_pdp_st elapsed_pdp_st pdps = Array.iter updatefn rrd.rrd_rras (* We assume that the data being given is of the form of a rate; that is, - it's dependent on the time interval between updates. To be able to - deal with gauge DSs, we multiply by the interval so that it cancels - the subsequent divide by interval later on *) + it's dependent on the time interval between updates. + Gauge and Absolute data sources are simply kept as is without any + time-based calculations, while Derive data sources will be changed according + to the time passed since the last measurement. (see CA-404597) *) let process_ds_value ds value interval new_rrd = if interval > ds.ds_mrhb then nan @@ -360,10 +361,8 @@ let process_ds_value ds value interval new_rrd = let rate = match (ds.ds_ty, new_rrd) with - | Absolute, _ | Derive, true -> + | Absolute, _ | Derive, true | Gauge, _ -> value_raw - | Gauge, _ -> - value_raw *. interval | Derive, false -> ( match (ds.ds_last, value) with | VT_Int64 x, VT_Int64 y -> @@ -433,7 +432,14 @@ let ds_update rrd timestamp valuesandtransforms new_rrd = if Utils.isnan value then ds.ds_unknown_sec <- pre_int else - ds.ds_value <- ds.ds_value +. (pre_int *. value /. interval) + (* CA-404597 - Gauge and Absolute values should be passed as-is, + without being involved in time-based calculations at all. + This applies to calculations below as well *) + match ds.ds_ty with + | Gauge | Absolute -> + ds.ds_value <- value + | Derive -> + ds.ds_value <- ds.ds_value +. (pre_int *. value /. interval) ) v2s ; @@ -450,7 +456,13 @@ let ds_update rrd timestamp valuesandtransforms new_rrd = let raw = let proc_pdp_st = get_float_time last_updated rrd.timestep in let occu_pdp_st = get_float_time timestamp rrd.timestep in - ds.ds_value /. (occu_pdp_st -. proc_pdp_st -. ds.ds_unknown_sec) + + match ds.ds_ty with + | Gauge | Absolute -> + ds.ds_value + | Derive -> + ds.ds_value + /. (occu_pdp_st -. proc_pdp_st -. ds.ds_unknown_sec) in (* Apply the transform after the raw value has been calculated *) let raw = apply_transform_function transform raw in @@ -473,8 +485,12 @@ let ds_update rrd timestamp valuesandtransforms new_rrd = ds.ds_value <- 0.0 ; ds.ds_unknown_sec <- post_int ) else ( - ds.ds_value <- post_int *. value /. interval ; - ds.ds_unknown_sec <- 0.0 + ds.ds_unknown_sec <- 0.0 ; + match ds.ds_ty with + | Gauge | Absolute -> + ds.ds_value <- value + | Derive -> + ds.ds_value <- post_int *. value /. interval ) ) v2s @@ -621,9 +637,9 @@ let rrd_add_ds_unsafe rrd timestamp newds = rrd.rrd_rras } -(** Add in a new DS into a pre-existing RRD. Preserves data of all the other archives - and fills the new one full of NaNs. Note that this doesn't fill in the CDP values - correctly at the moment! +(** Add in a new DS into a pre-existing RRD. Preserves data of all the other + archives and fills the new one full of NaNs. Note that this doesn't fill + in the CDP values correctly at the moment! *) let rrd_add_ds rrd timestamp newds = @@ -632,28 +648,27 @@ let rrd_add_ds rrd timestamp newds = else rrd_add_ds_unsafe rrd timestamp newds -(** Remove the named DS from an RRD. Removes all of the data associated with it, too *) +(** Remove the named DS from an RRD. Removes all of the data associated with + it, too. THe function is idempotent. *) let rrd_remove_ds rrd ds_name = - let n = - Utils.array_index ds_name (Array.map (fun ds -> ds.ds_name) rrd.rrd_dss) - in - if n = -1 then - raise (Invalid_data_source ds_name) - else - { - rrd with - rrd_dss= Utils.array_remove n rrd.rrd_dss - ; rrd_rras= - Array.map - (fun rra -> - { - rra with - rra_data= Utils.array_remove n rra.rra_data - ; rra_cdps= Utils.array_remove n rra.rra_cdps - } - ) - rrd.rrd_rras - } + match Utils.find_index (fun ds -> ds.ds_name = ds_name) rrd.rrd_dss with + | None -> + rrd + | Some n -> + { + rrd with + rrd_dss= Utils.array_remove n rrd.rrd_dss + ; rrd_rras= + Array.map + (fun rra -> + { + rra with + rra_data= Utils.array_remove n rra.rra_data + ; rra_cdps= Utils.array_remove n rra.rra_cdps + } + ) + rrd.rrd_rras + } (** Find the RRA with a particular CF that contains a particular start time, and also has a minimum pdp_cnt. If it can't find an @@ -698,18 +713,17 @@ let find_best_rras rrd pdp_interval cf start = List.filter (contains_time newstarttime) rras let query_named_ds rrd as_of_time ds_name cf = - let n = - Utils.array_index ds_name (Array.map (fun ds -> ds.ds_name) rrd.rrd_dss) - in - if n = -1 then - raise (Invalid_data_source ds_name) - else - let rras = find_best_rras rrd 0 (Some cf) (Int64.of_float as_of_time) in - match rras with - | [] -> - raise No_RRA_Available - | rra :: _ -> - Fring.peek rra.rra_data.(n) 0 + match Utils.find_index (fun ds -> ds.ds_name = ds_name) rrd.rrd_dss with + | None -> + raise (Invalid_data_source ds_name) + | Some n -> ( + let rras = find_best_rras rrd 0 (Some cf) (Int64.of_float as_of_time) in + match rras with + | [] -> + raise No_RRA_Available + | rra :: _ -> + Fring.peek rra.rra_data.(n) 0 + ) (******************************************************************************) (* Marshalling/Unmarshalling functions *) @@ -876,30 +890,26 @@ let from_xml input = (* Purge any repeated data sources from the RRD *) let ds_names = ds_names rrd in - let ds_names_set = Utils.setify ds_names in - let ds_name_counts = - List.map - (fun name -> - let x, _ = List.partition (( = ) name) ds_names in - (name, List.length x) - ) - ds_names_set - in - let removals_required = - List.filter (fun (_, x) -> x > 1) ds_name_counts - in - List.fold_left - (fun rrd (name, n) -> - (* Remove n-1 lots of this data source *) - let rec inner rrd n = - if n = 1 then - rrd - else - inner (rrd_remove_ds rrd name) (n - 1) - in - inner rrd n - ) - rrd removals_required + List.sort_uniq String.compare ds_names + |> List.filter_map (fun name -> + match List.filter (String.equal name) ds_names with + | [] | [_] -> + None + | x -> + Some (name, List.length x) + ) + |> List.fold_left + (fun rrd (name, n) -> + (* Remove n-1 lots of this data source *) + let rec inner rrd n = + if n = 1 then + rrd + else + inner (rrd_remove_ds rrd name) (n - 1) + in + inner rrd n + ) + rrd ) input diff --git a/ocaml/libs/xapi-rrd/lib/rrd_utils.ml b/ocaml/libs/xapi-rrd/lib/rrd_utils.ml index c0863d0175f..aa959a042dd 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd_utils.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd_utils.ml @@ -47,13 +47,13 @@ end let isnan x = match classify_float x with FP_nan -> true | _ -> false -let array_index e a = +let find_index f a = let len = Array.length a in let rec check i = if len <= i then - -1 - else if a.(i) = e then - i + None + else if f a.(i) then + Some i else check (i + 1) in @@ -62,23 +62,6 @@ let array_index e a = let array_remove n a = Array.append (Array.sub a 0 n) (Array.sub a (n + 1) (Array.length a - n - 1)) -let filter_map f list = - let rec inner acc l = - match l with - | [] -> - List.rev acc - | x :: xs -> - let acc = match f x with Some res -> res :: acc | None -> acc in - inner acc xs - in - inner [] list - -let rec setify = function - | [] -> - [] - | x :: xs -> - if List.mem x xs then setify xs else x :: setify xs - (** C# and JS representation of special floats are 'NaN' and 'Infinity' which are different from ocaml's native representation. Caml is fortunately more forgiving when doing a float_of_string, and can cope with these forms, so diff --git a/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml b/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml index f9cb5765b9f..1bcd65ad7d3 100644 --- a/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml +++ b/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml @@ -107,6 +107,110 @@ let test_length_invariants rrd () = let check_length dss rra = check_length_of_fring dss rra.rra_data in Array.iter (check_length rrd.rrd_dss) rrd.rrd_rras +let absolute_rrd = + let rra = rra_create CF_Average 100 1 0.5 in + let rra2 = rra_create CF_Average 100 10 0.5 in + let rra3 = rra_create CF_Average 100 100 0.5 in + let rra4 = rra_create CF_Average 100 1000 0.5 in + let ts = 1000000000.0 in + let ds = ds_create "foo" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds2 = ds_create "bar" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds3 = ds_create "baz" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds4 = ds_create "boo" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let rrd = rrd_create [|ds; ds2; ds3; ds4|] [|rra; rra2; rra3; rra4|] 1L ts in + let id = Identity in + for i = 1 to 100000 do + let t = 1000000.0 +. (0.7 *. float_of_int i) in + let v1 = + (0, {value= VT_Float (0.5 +. (0.5 *. sin (t /. 10.0))); transform= id}) + in + let v2 = + (1, {value= VT_Float (1.5 +. (0.5 *. cos (t /. 80.0))); transform= id}) + in + let v3 = + (2, {value= VT_Float (3.5 +. (0.5 *. sin (t /. 700.0))); transform= id}) + in + let v4 = + (3, {value= VT_Float (6.5 +. (0.5 *. cos (t /. 5000.0))); transform= id}) + in + ds_update rrd t [|v1; v2; v3; v4|] false + done ; + rrd + +let absolute_rrd_CA_404597 () = + let rra = rra_create CF_Average 100 1 0.5 in + let rra2 = rra_create CF_Average 100 10 0.5 in + let rra3 = rra_create CF_Average 100 100 0.5 in + let rra4 = rra_create CF_Average 100 1000 0.5 in + let ts = 1000000000.0 in + let ds = ds_create "foo" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds2 = ds_create "bar" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds3 = ds_create "baz" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds4 = ds_create "boo" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let rrd = rrd_create [|ds; ds2; ds3; ds4|] [|rra; rra2; rra3; rra4|] 1L ts in + let id = Identity in + for i = 1 to 100000 do + let t = 1000000.0 +. (0.7 *. float_of_int i) in + let ((_, val1) as v1) = + (0, {value= VT_Float (0.5 +. (0.5 *. sin (t /. 10.0))); transform= id}) + in + let ((_, val2) as v2) = + (1, {value= VT_Float (1.5 +. (0.5 *. cos (t /. 80.0))); transform= id}) + in + let ((_, val3) as v3) = + (2, {value= VT_Float (3.5 +. (0.5 *. sin (t /. 700.0))); transform= id}) + in + let ((_, val4) as v4) = + (3, {value= VT_Float (6.5 +. (0.5 *. cos (t /. 5000.0))); transform= id}) + in + ds_update rrd t [|v1; v2; v3; v4|] false ; + + Array.iter2 + (fun ds value -> + compare_float __LOC__ ds.ds_value + (float_of_string (ds_value_to_string value.value)) + ) + rrd.rrd_dss [|val1; val2; val3; val4|] + done + +(** Verify that Gauge data soruce values are correctly handled by the RRD lib + and that timestamps do not cause absolute values to fluctuate *) +let gauge_rrd_CA_404597 () = + let rra = rra_create CF_Average 100 1 0.5 in + let rra2 = rra_create CF_Average 100 10 0.5 in + let rra3 = rra_create CF_Average 100 100 0.5 in + let rra4 = rra_create CF_Average 100 1000 0.5 in + let ts = 1000000000.0 in + let ds = ds_create "foo" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let ds2 = ds_create "bar" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let ds3 = ds_create "baz" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let ds4 = ds_create "boo" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let rrd = rrd_create [|ds; ds2; ds3; ds4|] [|rra; rra2; rra3; rra4|] 1L ts in + let id = Identity in + for i = 1 to 100000 do + let t = 1000000.0 +. (0.7 *. float_of_int i) in + let ((_, val1) as v1) = + (0, {value= VT_Float (0.5 +. (0.5 *. sin (t /. 10.0))); transform= id}) + in + let ((_, val2) as v2) = + (1, {value= VT_Float (1.5 +. (0.5 *. cos (t /. 80.0))); transform= id}) + in + let ((_, val3) as v3) = + (2, {value= VT_Float (3.5 +. (0.5 *. sin (t /. 700.0))); transform= id}) + in + let ((_, val4) as v4) = + (3, {value= VT_Float (6.5 +. (0.5 *. cos (t /. 5000.0))); transform= id}) + in + ds_update rrd t [|v1; v2; v3; v4|] false ; + + Array.iter2 + (fun ds value -> + compare_float __LOC__ ds.ds_value + (float_of_string (ds_value_to_string value.value)) + ) + rrd.rrd_dss [|val1; val2; val3; val4|] + done + let gauge_rrd = let rra = rra_create CF_Average 100 1 0.5 in let rra2 = rra_create CF_Average 100 10 0.5 in @@ -328,12 +432,15 @@ let regression_suite = ; ("CA-329043 (1)", `Quick, test_ranges ca_329043_rrd_1) ; ("CA-329043 (2)", `Quick, test_ranges ca_329043_rrd_2) ; ("CA-329813", `Quick, test_ranges ca_329813_rrd) + ; ("CA-404597 (1)", `Quick, gauge_rrd_CA_404597) + ; ("CA-404597 (2)", `Quick, absolute_rrd_CA_404597) ] let () = Alcotest.run "Test RRD library" [ - ("Gauge RRD", rrd_suite gauge_rrd) + ("Absolute RRD", rrd_suite absolute_rrd) + ; ("Gauge RRD", rrd_suite gauge_rrd) ; ("RRD for CA-322008", rrd_suite ca_322008_rrd) ; ("RRD for CA-329043", rrd_suite ca_329043_rrd_1) ; ("RRD for CA-329813", rrd_suite ca_329813_rrd) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml index a544ed79bbb..200b9925786 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml @@ -36,8 +36,7 @@ let lock = Mutex.create () module Clock = struct let span s = Mtime.Span.of_uint64_ns (Int64.of_float (s *. 1e9)) - let span_to_s span = - Mtime.Span.to_uint64_ns span |> Int64.to_float |> fun ns -> ns /. 1e9 + let span_to_s span = Mtime.Span.to_float_ns span |> fun ns -> ns /. 1e9 let add_span clock secs = (* return mix or max available value if the add overflows *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune index 92b77753a86..e73e4d47fa3 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune @@ -16,7 +16,5 @@ (language c) (names blkgetsize_stubs - unixext_open_stubs - unixext_stubs - unixext_write_stubs)) + unixext_stubs)) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index c63a61ff783..111599f89d5 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -371,36 +371,6 @@ let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid = raise Process_still_alive ) -let string_of_signal x = - let table = - [ - (Sys.sigabrt, "SIGABRT") - ; (Sys.sigalrm, "SIGALRM") - ; (Sys.sigfpe, "SIGFPE") - ; (Sys.sighup, "SIGHUP") - ; (Sys.sigill, "SIGILL") - ; (Sys.sigint, "SIGINT") - ; (Sys.sigkill, "SIGKILL") - ; (Sys.sigpipe, "SIGPIPE") - ; (Sys.sigquit, "SIGQUIT") - ; (Sys.sigsegv, "SIGSEGV") - ; (Sys.sigterm, "SIGTERM") - ; (Sys.sigusr1, "SIGUSR1") - ; (Sys.sigusr2, "SIGUSR2") - ; (Sys.sigchld, "SIGCHLD") - ; (Sys.sigcont, "SIGCONT") - ; (Sys.sigstop, "SIGSTOP") - ; (Sys.sigttin, "SIGTTIN") - ; (Sys.sigttou, "SIGTTOU") - ; (Sys.sigvtalrm, "SIGVTALRM") - ; (Sys.sigprof, "SIGPROF") - ] - in - if List.mem_assoc x table then - List.assoc x table - else - Printf.sprintf "(ocaml signal %d with an unknown name)" x - let with_polly f = let polly = Polly.create () in let finally () = Polly.close polly in @@ -925,35 +895,6 @@ let test_open n = done ) -module Direct = struct - type t = Unix.file_descr - - external openfile : string -> Unix.open_flag list -> Unix.file_perm -> t - = "stub_stdext_unix_open_direct" - - let close = Unix.close - - let with_openfile path flags perms f = - let t = openfile path flags perms in - finally (fun () -> f t) (fun () -> close t) - - external unsafe_write : t -> bytes -> int -> int -> int - = "stub_stdext_unix_write" - - let write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then - invalid_arg "Unixext.write" - else - unsafe_write fd buf ofs len - - let copy_from_fd ?limit socket fd = - copy_file_internal ?limit (Unix.read socket) (write fd) - - let fsync x = fsync x - - let lseek fd x cmd = Unix.LargeFile.lseek fd x cmd -end - (* --------------------------------------------------------------------------------------- *) module Daemon = struct diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli index fa8eb331f25..047935b475c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -122,10 +122,6 @@ exception Process_still_alive val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit -val string_of_signal : int -> string -(** [string_of_signal x] translates an ocaml signal number into - * a string suitable for logging. *) - val proxy : Unix.file_descr -> Unix.file_descr -> unit val really_read : Unix.file_descr -> bytes -> int -> int -> unit @@ -266,36 +262,6 @@ val test_open : int -> unit The file descriptors will stay open until the program exits. *) -module Direct : sig - (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) - - (** represents a file open in O_DIRECT mode *) - type t - - val openfile : string -> Unix.open_flag list -> Unix.file_perm -> t - (** [openfile name flags perm] behaves the same as [Unix.openfile] but includes the O_DIRECT flag *) - - val close : t -> unit - (** [close t] closes [t], a file open in O_DIRECT mode *) - - val with_openfile : - string -> Unix.open_flag list -> Unix.file_perm -> (t -> 'a) -> 'a - (** [with_openfile name flags perm f] opens [name], applies the result to [f] and closes *) - - val write : t -> bytes -> int -> int -> int - (** [write t buf ofs len] writes [len] bytes at offset [ofs] from buffer [buf] to - [t] using page-aligned buffers. *) - - val copy_from_fd : ?limit:int64 -> Unix.file_descr -> t -> int64 - (** [copy_from_fd ?limit fd t] copies from [fd] to [t] up to [limit] *) - - val fsync : t -> unit - (** [fsync t] commits all outstanding writes, throwing an error if necessary. *) - - val lseek : t -> int64 -> Unix.seek_command -> int64 - (** [lseek t offset command]: see Unix.LargeFile.lseek *) -end - module Daemon : sig (** OCaml interface to libsystemd. diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c deleted file mode 100644 index d15cfeff0b1..00000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c +++ /dev/null @@ -1,75 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: open.c 9547 2010-01-22 12:48:24Z doligez $ */ - -#define _GNU_SOURCE /* O_DIRECT */ - -#include -#include -#include -#include -#include -#include -#include - -#ifndef O_NONBLOCK -#define O_NONBLOCK O_NDELAY -#endif -#ifndef O_DSYNC -#define O_DSYNC 0 -#endif -#ifndef O_SYNC -#define O_SYNC 0 -#endif -#ifndef O_RSYNC -#define O_RSYNC 0 -#endif - -static int open_flag_table[] = { - O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, - O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC -}; - -CAMLprim value stub_stdext_unix_open_direct(value path, value flags, value perm) -{ - CAMLparam3(path, flags, perm); - int fd, cv_flags; -#ifndef O_DIRECT - int ret; -#endif - char * p; - - cv_flags = caml_convert_flag_list(flags, open_flag_table); - -#ifdef O_DIRECT - cv_flags |= O_DIRECT; -#endif - p = caml_stat_alloc(caml_string_length(path) + 1); - strcpy(p, String_val(path)); - /* open on a named FIFO can block (PR#1533) */ - caml_enter_blocking_section(); - fd = open(p, cv_flags, Int_val(perm)); -#ifndef O_DIRECT - if (fd != -1) - ret = fcntl(fd, F_NOCACHE); -#endif - caml_leave_blocking_section(); - caml_stat_free(p); - if (fd == -1) uerror("open", path); -#ifndef O_DIRECT - if (ret == -1) uerror("fcntl", path); -#endif - - CAMLreturn (Val_int(fd)); -} diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c deleted file mode 100644 index e4be9f68018..00000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c +++ /dev/null @@ -1,65 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: write.c 9547 2010-01-22 12:48:24Z doligez $ */ - -#include -#include -#include -#include -#include -#include - -#define PAGE_SIZE 4096 - -#ifndef EAGAIN -#define EAGAIN (-1) -#endif -#ifndef EWOULDBLOCK -#define EWOULDBLOCK (-1) -#endif - -CAMLprim value stub_stdext_unix_write(value fd, value buf, value vofs, value vlen) -{ - long ofs, len, written; - int numbytes, ret; - void *iobuf = NULL; - - Begin_root (buf); - ofs = Long_val(vofs); - len = Long_val(vlen); - written = 0; - while (len > 0) { - numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; - ret = posix_memalign(&iobuf, PAGE_SIZE, numbytes); - if (ret != 0) - uerror("write/posix_memalign", Nothing); - - memmove (iobuf, &Byte(buf, ofs), numbytes); - caml_enter_blocking_section(); - ret = write(Int_val(fd), iobuf, numbytes); - caml_leave_blocking_section(); - free(iobuf); - - if (ret == -1) { - if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0) break; - uerror("write", Nothing); - } - written += ret; - ofs += ret; - len -= ret; - } - End_roots(); - return Val_long(written); -} - diff --git a/ocaml/nbd/src/cleanup.ml b/ocaml/nbd/src/cleanup.ml index a3c0fd60d35..c4affe38628 100644 --- a/ocaml/nbd/src/cleanup.ml +++ b/ocaml/nbd/src/cleanup.ml @@ -218,6 +218,11 @@ module Runtime = struct Printf.eprintf "SIGINT received - exiting" ; flush stderr ; exit 0 + | Signal n -> + Printf.eprintf "unexpected signal %s in signal handler - exiting" + Fmt.(to_to_string Dump.signal n) ; + flush stderr ; + exit 1 | e -> Printf.eprintf "unexpected exception %s in signal handler - exiting" (Printexc.to_string e) ; @@ -225,8 +230,9 @@ module Runtime = struct exit 1 let cleanup_resources signal = + let name = Fmt.(to_to_string Dump.signal signal) in let cleanup () = - Lwt_log.warning_f "Caught signal %d, cleaning up" signal >>= fun () -> + Lwt_log.warning_f "Caught signal %s, cleaning up" name >>= fun () -> (* First we have to close the open file descriptors corresponding to the VDIs we plugged to dom0. Otherwise the VDI.unplug call would hang. *) ignore_exn_log_error "Caught exception while closing open block devices" diff --git a/ocaml/nbd/src/dune b/ocaml/nbd/src/dune index 076e6884786..02c9dc6a0ed 100644 --- a/ocaml/nbd/src/dune +++ b/ocaml/nbd/src/dune @@ -4,7 +4,7 @@ (libraries cmdliner consts - + fmt local_xapi_session lwt lwt.unix diff --git a/ocaml/networkd/bin/dune b/ocaml/networkd/bin/dune index 9d755a10e37..be140076b58 100644 --- a/ocaml/networkd/bin/dune +++ b/ocaml/networkd/bin/dune @@ -14,10 +14,11 @@ (modes exe) (libraries astring - + clock forkexec http_lib integers + mtime netlink networklibs rpclib.core diff --git a/ocaml/networkd/bin/network_server.ml b/ocaml/networkd/bin/network_server.ml index b398ca93b8c..8cc5e9ea908 100644 --- a/ocaml/networkd/bin/network_server.ml +++ b/ocaml/networkd/bin/network_server.ml @@ -53,7 +53,8 @@ let on_shutdown signal = let dbg = "shutdown" in Debug.with_thread_associated dbg (fun () -> - debug "xcp-networkd caught signal %d; performing cleanup actions." signal ; + debug "xcp-networkd caught signal %a; performing cleanup actions." + Debug.Pp.signal signal ; write_config () ) () diff --git a/ocaml/networkd/bin/networkd.ml b/ocaml/networkd/bin/networkd.ml index 3b3163a8a7a..bd4b813f6c9 100644 --- a/ocaml/networkd/bin/networkd.ml +++ b/ocaml/networkd/bin/networkd.ml @@ -105,8 +105,14 @@ let options = , "Path to the Unix command dracut" ) ; ( "dracut-timeout" - , Arg.Set_float Network_utils.dracut_timeout - , (fun () -> string_of_float !Network_utils.dracut_timeout) + , Arg.Float + (fun x -> + let x = Float.to_int (x *. 1000.) in + Network_utils.dracut_timeout := Mtime.Span.(x * ms) + ) + , (fun () -> + Float.to_string (Clock.Timer.span_to_s !Network_utils.dracut_timeout) + ) , "Default value for the dracut command timeout" ) ; ( "modinfo-cmd-path" diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index 4a473b29579..6a37a7dfc5c 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -67,7 +67,7 @@ let dracut = ref "/sbin/dracut" let modinfo = ref "/sbin/modinfo" -let dracut_timeout = ref 180.0 +let dracut_timeout = ref Mtime.Span.(3 * min) let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" @@ -128,7 +128,8 @@ let check_n_run ?(on_error = default_error_handler) ?(log = true) run_func | Forkhelpers.Spawn_internal_error (stderr, stdout, status) -> on_error script args stdout stderr status -let call_script ?(timeout = Some 60.0) ?on_error ?log script args = +let call_script ?(timeout = Some Mtime.Span.(1 * min)) ?on_error ?log script + args = let call_script_internal env script args = let out, _err = Forkhelpers.execute_command_get_output ~env ?timeout script args @@ -1064,15 +1065,23 @@ end = struct end module Fcoe = struct - let call ?log args = call_script ?log ~timeout:(Some 10.0) !fcoedriver args + let call ?log args = + call_script ?log ~timeout:(Some Mtime.Span.(10 * s)) !fcoedriver args let get_capabilities name = - try - let output = call ~log:false ["--xapi"; name; "capable"] in - if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] - with _ -> - debug "Failed to get fcoe support status on device %s" name ; - [] + match Sys.file_exists !fcoedriver with + | false -> + info "%s: %s not found, does not support FCoE" __FUNCTION__ !fcoedriver ; + [] (* Does not support FCoE *) + | true -> ( + try + let output = call ~log:false ["--xapi"; name; "capable"] in + if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] + with _ -> + debug "%s: Failed to get fcoe support status on device %s" __FUNCTION__ + name ; + [] + ) end module Sysctl = struct diff --git a/ocaml/rrd2csv/src/rrd2csv.ml b/ocaml/rrd2csv/src/rrd2csv.ml index 0448c4e067f..b22c430f656 100644 --- a/ocaml/rrd2csv/src/rrd2csv.ml +++ b/ocaml/rrd2csv/src/rrd2csv.ml @@ -149,27 +149,33 @@ module Ds_selector = struct let of_string str = let open Rrd in - let splitted = Xstringext.String.split ':' str in + let splitted = Xstringext.String.split ',' str in match splitted with - | [cf; owner; uuid; metric] -> - { - cf= (try Some (cf_type_of_string cf) with _ -> None) - ; owner= - ( match owner with - | "vm" -> - Some (VM uuid) - | "sr" -> - Some (SR uuid) - | "host" -> - Some Host - | _ -> - None - ) - ; uuid - ; metric - } - | [metric] -> - {empty with metric} + | without_trailing_comma :: _ -> ( + let splitted = Xstringext.String.split ':' without_trailing_comma in + match splitted with + | [cf; owner; uuid; metric] -> + { + cf= (try Some (cf_type_of_string cf) with _ -> None) + ; owner= + ( match owner with + | "vm" -> + Some (VM uuid) + | "sr" -> + Some (SR uuid) + | "host" -> + Some Host + | _ -> + None + ) + ; uuid + ; metric + } + | [metric] -> + {empty with metric} + | _ -> + failwith "ds_selector_of_string" + ) | _ -> failwith "ds_selector_of_string" diff --git a/ocaml/sdk-gen/csharp/autogen/src/Session.cs b/ocaml/sdk-gen/csharp/autogen/src/Session.cs index 4a84b5bcd0c..82db84a8210 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/Session.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/Session.cs @@ -65,29 +65,15 @@ public Session(JsonRpcClient client) client.KeepAlive = true; client.UserAgent = UserAgent; client.WebProxy = Proxy; - client.JsonRpcVersion = JsonRpcVersion.v2; client.AllowAutoRedirect = true; JsonRpcClient = client; } - [Obsolete("Use Session(string url) { Timeout = ... }; instead.")] - public Session(int timeout, string url) - : this(new JsonRpcClient(url)) - { - JsonRpcClient.Timeout = timeout; - } - public Session(string url) : this(new JsonRpcClient(url)) { } - [Obsolete("Use Session(string host, int port) { Timeout = ... }; instead.")] - public Session(int timeout, string host, int port) - : this(timeout, GetUrl(host, port)) - { - } - public Session(string host, int port) : this(GetUrl(host, port)) { @@ -100,23 +86,6 @@ public Session(string url, string opaqueRef) SetupSessionDetails(); } - /// - /// Create a new Session instance, using the given instance and timeout. The connection details and Xen-API session handle will be - /// copied from the given instance, but a new connection will be created. Use this if you want a duplicate connection to a host, - /// for example when you need to cancel an operation that is blocking the primary connection. - /// - /// - /// - [Obsolete("Use Session(Session session) { Timeout = ... }; instead.")] - public Session(Session session, int timeout) - : this(session) - { - if (JsonRpcClient != null) - { - JsonRpcClient.Timeout = timeout; - } - } - /// /// Create a new Session instance, using the given instance. The connection details /// and Xen-API session handle will be copied from the given instance, but a new @@ -175,6 +144,14 @@ private void SetAPIVersion() Host host = Host.get_record(this, pool.master); APIVersion = Helper.GetAPIVersion(host.API_version_major, host.API_version_minor); } + + if (JsonRpcClient != null) + { + if (APIVersion == API_Version.API_2_6) + JsonRpcClient.JsonRpcVersion = JsonRpcVersion.v1; + else if (APIVersion >= API_Version.API_2_8) + JsonRpcClient.JsonRpcVersion = JsonRpcVersion.v2; + } } private void CopyADFromSession(Session session) diff --git a/ocaml/sdk-gen/csharp/templates/ApiVersion.mustache b/ocaml/sdk-gen/csharp/templates/ApiVersion.mustache index a8be1e4e8a5..9cac0b97c18 100644 --- a/ocaml/sdk-gen/csharp/templates/ApiVersion.mustache +++ b/ocaml/sdk-gen/csharp/templates/ApiVersion.mustache @@ -28,9 +28,6 @@ */ using System; -using System.Collections; -using System.Collections.Generic; - namespace XenAPI { @@ -63,8 +60,7 @@ namespace XenAPI { try { - return (API_Version)Enum.Parse(typeof(API_Version), - string.Format("API_{0}_{1}", major, minor)); + return (API_Version)Enum.Parse(typeof(API_Version), $"API_{major}_{minor}"); } catch (ArgumentException) { @@ -82,30 +78,14 @@ namespace XenAPI { string[] tokens = version.Split('.'); int major, minor; - if (tokens.Length == 2 && int.TryParse(tokens[0], out major) && int.TryParse(tokens[1], out minor)) + if (tokens.Length == 2 && + int.TryParse(tokens[0], out major) && + int.TryParse(tokens[1], out minor)) { return GetAPIVersion(major, minor); } } return API_Version.UNKNOWN; } - - /// - /// Return a positive number if the given session's API version is greater than the given - /// API_version, negative if it is less, and 0 if they are equal. - /// - internal static int APIVersionCompare(Session session, API_Version v) - { - return (int)session.APIVersion - (int)v; - } - - /// - /// Return true if the given session's API version is greater than or equal to the given - /// API_version. - /// - internal static bool APIVersionMeets(Session session, API_Version v) - { - return APIVersionCompare(session, v) >= 0; - } } } diff --git a/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs b/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs index 8f29ecde1f5..d22d5eadee0 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs @@ -39,14 +39,11 @@ namespace Citrix.XenServer { - class CommonCmdletFunctions + internal class CommonCmdletFunctions { private const string SessionsVariable = "global:Citrix.XenServer.Sessions"; - private const string DefaultSessionVariable = "global:XenServer_Default_Session"; - private const string KnownServerCertificatesFilePathVariable = "global:KnownServerCertificatesFilePath"; - static CommonCmdletFunctions() { Session.UserAgent = string.Format("XenServerPSModule/{0}", Assembly.GetExecutingAssembly().GetName().Version); @@ -78,72 +75,12 @@ internal static void SetDefaultXenSession(PSCmdlet cmdlet, Session session) cmdlet.SessionState.PSVariable.Set(DefaultSessionVariable, session); } - internal static string GetKnownServerCertificatesFilePathVariable(PSCmdlet cmdlet) - { - var knownCertificatesFilePathObject = cmdlet.SessionState.PSVariable.GetValue(KnownServerCertificatesFilePathVariable); - if (knownCertificatesFilePathObject is PSObject psObject) - return psObject.BaseObject as string; - return knownCertificatesFilePathObject?.ToString() ?? string.Empty; - } - internal static string GetUrl(string hostname, int port) { - return string.Format("{0}://{1}:{2}", port == 80 ? "http" : "https", hostname, port); - } - - public static Dictionary LoadCertificates(PSCmdlet cmdlet) - { - Dictionary certificates = new Dictionary(); - var knownServerCertificatesFilePath = GetKnownServerCertificatesFilePathVariable(cmdlet); - - if (File.Exists(knownServerCertificatesFilePath)) - { - XmlDocument doc = new XmlDocument(); - doc.Load(knownServerCertificatesFilePath); - - foreach (XmlNode node in doc.GetElementsByTagName("certificate")) - { - XmlAttribute hostAtt = node.Attributes?["hostname"]; - XmlAttribute fngprtAtt = node.Attributes?["fingerprint"]; - - if (hostAtt != null && fngprtAtt != null) - certificates[hostAtt.Value] = fngprtAtt.Value; - } - } - - return certificates; - } - - public static void SaveCertificates(PSCmdlet cmdlet, Dictionary certificates) - { - var knownServerCertificatesFilePath = GetKnownServerCertificatesFilePathVariable(cmdlet); - string dirName = Path.GetDirectoryName(knownServerCertificatesFilePath); - - if (!Directory.Exists(dirName)) - Directory.CreateDirectory(dirName); - - XmlDocument doc = new XmlDocument(); - XmlDeclaration decl = doc.CreateXmlDeclaration("1.0", "utf-8", null); - doc.AppendChild(decl); - XmlNode node = doc.CreateElement("certificates"); - - foreach (KeyValuePair cert in certificates) - { - XmlNode certNode = doc.CreateElement("certificate"); - XmlAttribute hostname = doc.CreateAttribute("hostname"); - XmlAttribute fingerprint = doc.CreateAttribute("fingerprint"); - hostname.Value = cert.Key; - fingerprint.Value = cert.Value; - certNode.Attributes?.Append(hostname); - certNode.Attributes?.Append(fingerprint); - node.AppendChild(certNode); - } - - doc.AppendChild(node); - doc.Save(knownServerCertificatesFilePath); + return $"{(port == 80 ? "http" : "https")}://{hostname}:{port}"; } - public static string FingerprintPrettyString(string fingerprint) + internal static string FingerprintPrettyString(string fingerprint) { List pairs = new List(); while (fingerprint.Length > 1) @@ -157,7 +94,7 @@ public static string FingerprintPrettyString(string fingerprint) return string.Join(":", pairs.ToArray()); } - public static Dictionary ConvertHashTableToDictionary(Hashtable tbl) + internal static Dictionary ConvertHashTableToDictionary(Hashtable tbl) { if (tbl == null) return null; @@ -169,7 +106,7 @@ public static Dictionary ConvertHashTableToDictionary(Hashtable tbl) return dict; } - public static Hashtable ConvertDictionaryToHashtable(Dictionary dict) + internal static Hashtable ConvertDictionaryToHashtable(Dictionary dict) { if (dict == null) return null; diff --git a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs index f300801f5ef..a1dc4ecf964 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs @@ -29,6 +29,7 @@ using System; using System.Collections.Generic; +using System.IO; using System.Management.Automation; using System.Net; using System.Net.Security; @@ -36,6 +37,7 @@ using System.Security; using System.Security.Cryptography; using System.Security.Cryptography.X509Certificates; +using System.Xml; using XenAPI; namespace Citrix.XenServer.Commands @@ -43,6 +45,8 @@ namespace Citrix.XenServer.Commands [Cmdlet("Connect", "XenServer")] public class ConnectXenServerCommand : PSCmdlet { + private const string CertificatesPathVariable = "global:KnownServerCertificatesFilePath"; + private readonly object _certificateValidationLock = new object(); public ConnectXenServerCommand() @@ -214,7 +218,10 @@ protected override void ProcessRecord() { if (ShouldContinue(ex.Message, ex.Caption)) { - AddCertificate(ex.Hostname, ex.Fingerprint); + var certPath = GetCertificatesPath(); + var certificates = LoadCertificates(certPath); + certificates[ex.Hostname] = ex.Fingerprint; + SaveCertificates(certPath, certificates); i--; continue; } @@ -254,13 +261,6 @@ protected override void ProcessRecord() WriteObject(newSessions.Values, true); } - private void AddCertificate(string hostname, string fingerprint) - { - var certificates = CommonCmdletFunctions.LoadCertificates(this); - certificates[hostname] = fingerprint; - CommonCmdletFunctions.SaveCertificates(this, certificates); - } - private bool ValidateServerCertificate(object sender, X509Certificate certificate, X509Chain chain, SslPolicyErrors sslPolicyErrors) { if (sslPolicyErrors == SslPolicyErrors.None) @@ -277,11 +277,11 @@ private bool ValidateServerCertificate(object sender, X509Certificate certificat bool trusted = VerifyInAllStores(new X509Certificate2(certificate)); - var certificates = CommonCmdletFunctions.LoadCertificates(this); + var certPath = GetCertificatesPath(); + var certificates = LoadCertificates(certPath); - if (certificates.ContainsKey(hostname)) + if (certificates.TryGetValue(hostname, out var fingerprintOld)) { - string fingerprintOld = certificates[hostname]; if (fingerprintOld == fingerprint) return true; @@ -295,7 +295,7 @@ private bool ValidateServerCertificate(object sender, X509Certificate certificat } certificates[hostname] = fingerprint; - CommonCmdletFunctions.SaveCertificates(this, certificates); + SaveCertificates(certPath, certificates); return true; } } @@ -312,6 +312,65 @@ private bool VerifyInAllStores(X509Certificate2 certificate2) return false; } } + + private string GetCertificatesPath() + { + var certPathObject = SessionState.PSVariable.GetValue(CertificatesPathVariable); + + return certPathObject is PSObject psObject + ? psObject.BaseObject as string + : certPathObject?.ToString() ?? string.Empty; + } + + private Dictionary LoadCertificates(string certPath) + { + var certificates = new Dictionary(); + + if (File.Exists(certPath)) + { + var doc = new XmlDocument(); + doc.Load(certPath); + + foreach (XmlNode node in doc.GetElementsByTagName("certificate")) + { + var hostAtt = node.Attributes?["hostname"]; + var fngprtAtt = node.Attributes?["fingerprint"]; + + if (hostAtt != null && fngprtAtt != null) + certificates[hostAtt.Value] = fngprtAtt.Value; + } + } + + return certificates; + } + + private void SaveCertificates(string certPath, Dictionary certificates) + { + string dirName = Path.GetDirectoryName(certPath); + + if (!Directory.Exists(dirName)) + Directory.CreateDirectory(dirName); + + XmlDocument doc = new XmlDocument(); + XmlDeclaration decl = doc.CreateXmlDeclaration("1.0", "utf-8", null); + doc.AppendChild(decl); + XmlNode node = doc.CreateElement("certificates"); + + foreach (KeyValuePair cert in certificates) + { + XmlNode certNode = doc.CreateElement("certificate"); + XmlAttribute hostname = doc.CreateAttribute("hostname"); + XmlAttribute fingerprint = doc.CreateAttribute("fingerprint"); + hostname.Value = cert.Key; + fingerprint.Value = cert.Value; + certNode.Attributes?.Append(hostname); + certNode.Attributes?.Append(fingerprint); + node.AppendChild(certNode); + } + + doc.AppendChild(node); + doc.Save(certPath); + } } internal abstract class CertificateValidationException : Exception diff --git a/ocaml/xapi-guard/lib/server_interface.ml b/ocaml/xapi-guard/lib/server_interface.ml index c6f70769313..8a64a576897 100644 --- a/ocaml/xapi-guard/lib/server_interface.ml +++ b/ocaml/xapi-guard/lib/server_interface.ml @@ -38,7 +38,8 @@ let shutdown = Lwt_switch.create () let () = let cleanup n = - debug "Triggering cleanup on signal %d, and waiting for servers to stop" n ; + debug "Triggering cleanup on signal %a, and waiting for servers to stop" + Debug.Pp.signal n ; Lwt.async (fun () -> let* () = Lwt_switch.turn_off shutdown in info "Cleanup complete, exiting" ; diff --git a/ocaml/xapi-types/features.ml b/ocaml/xapi-types/features.ml index c80d3c833a5..52469387acc 100644 --- a/ocaml/xapi-types/features.ml +++ b/ocaml/xapi-types/features.ml @@ -58,6 +58,7 @@ type feature = | USB_passthrough | Network_sriov | Corosync + | Cluster_address | Zstd_export | Pool_secret_rotation | Certificate_verification @@ -123,6 +124,7 @@ let keys_of_features = ; (USB_passthrough, ("restrict_usb_passthrough", Negative, "USB_passthrough")) ; (Network_sriov, ("restrict_network_sriov", Negative, "Network_sriov")) ; (Corosync, ("restrict_corosync", Negative, "Corosync")) + ; (Cluster_address, ("restrict_cluster_address", Negative, "Cluster_address")) ; (Zstd_export, ("restrict_zstd_export", Negative, "Zstd_export")) ; ( Pool_secret_rotation , ("restrict_pool_secret_rotation", Negative, "Pool_secret_rotation") diff --git a/ocaml/xapi-types/features.mli b/ocaml/xapi-types/features.mli index f6efce3f0a5..018749cb685 100644 --- a/ocaml/xapi-types/features.mli +++ b/ocaml/xapi-types/features.mli @@ -65,6 +65,7 @@ type feature = | USB_passthrough (** Enable the use of USB passthrough. *) | Network_sriov (** Enable the use of Network SRIOV. *) | Corosync (** Enable the use of corosync. *) + | Cluster_address (** Enable the use of extended cluster address interface *) | Zstd_export (** Enable the use of VM export with zstd compression. *) | Pool_secret_rotation (** Enable Pool Secret Rotation *) | Certificate_verification (** Used by XenCenter *) diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 68368754e72..4d1ede48abd 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -71,7 +71,7 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args = | None -> "without a timeout" | Some t -> - Printf.sprintf "with a timeout of %.3f seconds" t + Fmt.str "with a timeout of %a" Mtime.Span.pp t in debug "about to call script %s: %s %s" timeout_msg script (String.concat " " (filter_args args)) ; @@ -109,9 +109,9 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args = | Unix.WEXITED n -> Printf.sprintf "exited with code %d" n | Unix.WSIGNALED n -> - Printf.sprintf "was killed by signal %d" n + Printf.sprintf "was killed by signal %a" Debug.Pp.signal n | Unix.WSTOPPED n -> - Printf.sprintf "was stopped by signal %d" n + Printf.sprintf "was stopped by signal %a" Debug.Pp.signal n in if should_log_output_on_failure then debug "%s %s %s [stdout = '%s'; stderr = '%s']" script diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index 51699612739..38a46edc3bb 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -398,10 +398,11 @@ let with_local_repositories ~__context f = with Pool_role.This_host_is_a_master -> Option.get (Helpers.get_management_ip_addr ~__context) in - Stunnel.with_client_proxy ~verify_cert:(Stunnel_client.pool ()) - ~remote_host:master_addr ~remote_port:Constants.default_ssl_port - ~local_host:"127.0.0.1" + Stunnel.with_client_proxy_systemd_service + ~verify_cert:(Stunnel_client.pool ()) ~remote_host:master_addr + ~remote_port:Constants.default_ssl_port ~local_host:"127.0.0.1" ~local_port:!Xapi_globs.local_yum_repo_port + ~service:"stunnel_proxy_for_update_client" @@ fun () -> let enabled = get_enabled_repositories ~__context in Xapi_stdext_pervasives.Pervasiveext.finally diff --git a/ocaml/xapi/sm_exec.ml b/ocaml/xapi/sm_exec.ml index 28cdd11e07b..d97e8f41e9b 100644 --- a/ocaml/xapi/sm_exec.ml +++ b/ocaml/xapi/sm_exec.ml @@ -393,7 +393,7 @@ let exec_xmlrpc ~dbg ?context:_ ?(needs_session = true) (driver : string) (Backend_error ( Api_errors.sr_backend_failure , [ - "received signal: " ^ Unixext.string_of_signal i + Printf.sprintf "received signal: %a" Debug.Pp.signal i ; output ; log ] diff --git a/ocaml/xapi/static_vdis.ml b/ocaml/xapi/static_vdis.ml index 049708e9c71..2197ac559a5 100644 --- a/ocaml/xapi/static_vdis.ml +++ b/ocaml/xapi/static_vdis.ml @@ -37,7 +37,9 @@ let permanent_vdi_attach ~__context ~vdi ~reason = ) ) ; ignore - (Helpers.call_script ~timeout:60.0 !Xapi_globs.static_vdis + (Helpers.call_script + ~timeout:Mtime.Span.(1 * min) + !Xapi_globs.static_vdis ["add"; Db.VDI.get_uuid ~__context ~self:vdi; reason] ) ; (* VDI will be attached on next boot; attach it now too *) diff --git a/ocaml/xapi/xapi_cluster.ml b/ocaml/xapi/xapi_cluster.ml index 498a0ea4111..1968e5f0774 100644 --- a/ocaml/xapi/xapi_cluster.ml +++ b/ocaml/xapi/xapi_cluster.ml @@ -13,7 +13,6 @@ *) open Xapi_clustering -open Ipaddr_rpc_type module D = Debug.Make (struct let name = "xapi_cluster" end) @@ -65,12 +64,8 @@ let create ~__context ~pIF ~cluster_stack ~pool_auto_join ~token_timeout let hostuuid = Inventory.lookup Inventory._installation_uuid in let hostname = Db.Host.get_hostname ~__context ~self:host in let member = - Extended - { - ip= Ipaddr.of_string_exn (ipstr_of_address ip_addr) - ; hostuuid - ; hostname - } + Xapi_cluster_host_helpers.get_cluster_host_address ~__context ~ip_addr + ~hostuuid ~hostname in let token_timeout_ms = Int64.of_float (token_timeout *. 1000.0) in let token_timeout_coefficient_ms = diff --git a/ocaml/xapi/xapi_cluster_helpers.ml b/ocaml/xapi/xapi_cluster_helpers.ml index 954b946b0fa..a4d30bcedaa 100644 --- a/ocaml/xapi/xapi_cluster_helpers.ml +++ b/ocaml/xapi/xapi_cluster_helpers.ml @@ -12,6 +12,8 @@ * GNU Lesser General Public License for more details. *) +module D = Debug.Make (struct let name = __MODULE__ end) + let finally = Xapi_stdext_pervasives.Pervasiveext.finally let all_cluster_operations = [`add; `remove; `enable; `disable; `destroy] @@ -104,6 +106,12 @@ let with_cluster_operation ~__context ~(self : [`Cluster] API.Ref.t) ~doc ~op with _ -> () ) +let cluster_address_enabled ~__context = + let r = Pool_features.is_enabled ~__context Features.Cluster_address in + D.debug "%s extended cluster address is %s" __FUNCTION__ + (if r then "enabled" else "disabled") ; + r + let corosync3_enabled ~__context = let pool = Helpers.get_pool ~__context in let restrictions = Db.Pool.get_restrictions ~__context ~self:pool in diff --git a/ocaml/xapi/xapi_cluster_host.ml b/ocaml/xapi/xapi_cluster_host.ml index e022f75c706..713261931a4 100644 --- a/ocaml/xapi/xapi_cluster_host.ml +++ b/ocaml/xapi/xapi_cluster_host.ml @@ -13,7 +13,6 @@ *) open Xapi_clustering -open Ipaddr_rpc_type module D = Debug.Make (struct let name = "xapi_cluster_host" end) @@ -126,12 +125,8 @@ let join_internal ~__context ~self = let host = Db.Cluster_host.get_host ~__context ~self in let hostname = Db.Host.get_hostname ~__context ~self:host in let member = - Extended - { - ip= Ipaddr.of_string_exn (ipstr_of_address ip_addr) - ; hostuuid - ; hostname - } + Xapi_cluster_host_helpers.get_cluster_host_address ~__context ~ip_addr + ~hostuuid ~hostname in let ip_list = List.filter_map @@ -338,14 +333,8 @@ let enable ~__context ~self = let hostuuid = Inventory.lookup Inventory._installation_uuid in let hostname = Db.Host.get_hostname ~__context ~self:host in let member = - Cluster_interface.( - Extended - { - ip= Ipaddr.of_string_exn (ipstr_of_address ip_addr) - ; hostuuid - ; hostname - } - ) + Xapi_cluster_host_helpers.get_cluster_host_address ~__context ~ip_addr + ~hostuuid ~hostname in let cluster_ref = Db.Cluster_host.get_cluster ~__context ~self in let cluster_stack = diff --git a/ocaml/xapi/xapi_cluster_host_helpers.ml b/ocaml/xapi/xapi_cluster_host_helpers.ml index 37e16d43178..59e5141da73 100644 --- a/ocaml/xapi/xapi_cluster_host_helpers.ml +++ b/ocaml/xapi/xapi_cluster_host_helpers.ml @@ -106,3 +106,17 @@ let with_cluster_host_operation ~__context ~(self : [`Cluster_host] API.Ref.t) (Datamodel_common._cluster_host, Ref.string_of self) with _ -> () ) + +let get_cluster_host_address ~__context ~ip_addr ~hostuuid ~hostname = + let open Ipaddr_rpc_type in + if Xapi_cluster_helpers.cluster_address_enabled ~__context then + Cluster_interface.( + Extended + { + ip= Ipaddr.of_string_exn (ipstr_of_address ip_addr) + ; hostuuid + ; hostname + } + ) + else + Cluster_interface.(IPv4 (ipstr_of_address ip_addr)) diff --git a/ocaml/xapi/xapi_extensions.ml b/ocaml/xapi/xapi_extensions.ml index dbc38349bdc..301a0a5e686 100644 --- a/ocaml/xapi/xapi_extensions.ml +++ b/ocaml/xapi/xapi_extensions.ml @@ -50,8 +50,7 @@ let call_extension rpc = ( Api_errors.internal_error , [ path - ; Printf.sprintf "signal: %s" - (Xapi_stdext_unix.Unixext.string_of_signal i) + ; Printf.sprintf "signal: %a" Debug.Pp.signal i ; output ; log ] diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index efdcabfbdb6..384ec35aed5 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -994,7 +994,7 @@ let winbind_allow_kerberos_auth_fallback = ref false let winbind_keep_configuration = ref false -let winbind_ldap_query_subject_timeout = ref 20. +let winbind_ldap_query_subject_timeout = ref Mtime.Span.(20 * s) let tdb_tool = ref "/usr/bin/tdbtool" @@ -1143,9 +1143,16 @@ let xapi_globs_spec = ; ("max_traces", Int max_traces) ; ("max_observer_file_size", Int max_observer_file_size) ; ("test-open", Int test_open) (* for consistency with xenopsd *) + ; ("local_yum_repo_port", Int local_yum_repo_port) ] -let xapi_globs_spec_with_descriptions = [] +let xapi_globs_spec_with_descriptions = + [ + ( "winbind_ldap_query_subject_timeout" + , ShortDurationFromSeconds winbind_ldap_query_subject_timeout + , "Timeout to perform ldap query for subject information" + ) + ] let option_of_xapi_globs_spec ?(description = None) (name, ty) = let spec = @@ -1466,11 +1473,6 @@ let other_options = , "Whether to clear winbind configuration when join domain failed or leave \ domain" ) - ; ( "winbind_ldap_query_subject_timeout" - , Arg.Set_float winbind_ldap_query_subject_timeout - , (fun () -> string_of_float !winbind_ldap_query_subject_timeout) - , "Timeout to perform ldap query for subject information" - ) ; ( "hsts_max_age" , Arg.Set_int hsts_max_age , (fun () -> string_of_int !hsts_max_age) @@ -1689,11 +1691,6 @@ module Resources = struct ; ("xsh", xsh, "Path to xsh binary") ; ("static-vdis", static_vdis, "Path to static-vdis script") ; ("xen-cmdline-script", xen_cmdline_script, "Path to xen-cmdline script") - ; ( "fcoe-driver" - , fcoe_driver - , "Execute during PIF unplug to get the lun devices related with the \ - ether interface of the PIF" - ) ; ("list_domains", list_domains, "Path to the list_domains command") ; ("systemctl", systemctl, "Control the systemd system and service manager") ; ( "alert-certificate-check" @@ -1797,6 +1794,12 @@ module Resources = struct , "Path to yum-config-manager command" ) ; ("c_rehash", c_rehash, "Path to regenerate CA store") + (* Dropped since XS9, list here as XS8 still requires it *) + ; ( "fcoe-driver" + , fcoe_driver + , "Execute during PIF unplug to get the lun devices related with the \ + ether interface of the PIF" + ) ] let essential_files = diff --git a/ocaml/xapi/xapi_pif.ml b/ocaml/xapi/xapi_pif.ml index a2383ed9d9b..0284a134a68 100644 --- a/ocaml/xapi/xapi_pif.ml +++ b/ocaml/xapi/xapi_pif.ml @@ -319,33 +319,40 @@ let assert_no_other_local_pifs ~__context ~host ~network = ) let assert_fcoe_not_in_use ~__context ~self = - let interface = Db.PIF.get_device ~__context ~self in - let output, _ = - Forkhelpers.execute_command_get_output !Xapi_globs.fcoe_driver - ["-t"; interface] - in - let output = String.trim output in - debug "Scsi ids on %s are: %s" interface output ; - let fcoe_scsids = Str.split (Str.regexp " ") output in - Helpers.get_my_pbds __context - |> List.iter (fun (_, pbd_rec) -> - let sr = pbd_rec.API.pBD_SR in - match Db.SR.get_type ~__context ~self:sr with - | "lvmofcoe" -> ( - try - let scsid = List.assoc "SCSIid" pbd_rec.API.pBD_device_config in - if List.mem scsid fcoe_scsids then - raise - (Api_errors.Server_error - ( Api_errors.pif_has_fcoe_sr_in_use - , [Ref.string_of self; Ref.string_of sr] - ) - ) - with Not_found -> () + match Sys.file_exists !Xapi_globs.fcoe_driver with + | false -> + (* Does not support FCoE from XS9, presuming not in use + * Upgrade plugin will block upgrade with FCoE in use *) + debug "%s not found, does not support FCoE" !Xapi_globs.fcoe_driver + | true -> + let interface = Db.PIF.get_device ~__context ~self in + let output, _ = + Forkhelpers.execute_command_get_output !Xapi_globs.fcoe_driver + ["-t"; interface] + in + let output = String.trim output in + debug "%s: SCSI ids on %s are: %s" __FUNCTION__ interface output ; + let fcoe_scsids = Str.split (Str.regexp " ") output in + Helpers.get_my_pbds __context + |> List.iter (fun (_, pbd_rec) -> + let sr = pbd_rec.API.pBD_SR in + match Db.SR.get_type ~__context ~self:sr with + | "lvmofcoe" -> ( + match List.assoc_opt "SCSIid" pbd_rec.API.pBD_device_config with + | Some scsid -> + if List.mem scsid fcoe_scsids then + raise + (Api_errors.Server_error + ( Api_errors.pif_has_fcoe_sr_in_use + , [Ref.string_of self; Ref.string_of sr] + ) + ) + | None -> + () + ) + | _ -> + () ) - | _ -> - () - ) let find_or_create_network (bridge : string) (device : string) ~managed ~__context = diff --git a/ocaml/xapi/xapi_plugins.ml b/ocaml/xapi/xapi_plugins.ml index 68447081136..3d9b7f0a2d0 100644 --- a/ocaml/xapi/xapi_plugins.ml +++ b/ocaml/xapi/xapi_plugins.ml @@ -49,12 +49,7 @@ let call_plugin session_id plugin_name fn_name args = raise (Api_errors.Server_error ( Api_errors.xenapi_plugin_failure - , [ - Printf.sprintf "signal: %s" - (Xapi_stdext_unix.Unixext.string_of_signal i) - ; output - ; log - ] + , [Printf.sprintf "signal: %a" Debug.Pp.signal i; output; log] ) ) | Forkhelpers.Spawn_internal_error (log, output, Unix.WEXITED _) -> diff --git a/ocaml/xapi/xapi_pool_update.ml b/ocaml/xapi/xapi_pool_update.ml index daed914ccdf..c7f3b4ebdfb 100644 --- a/ocaml/xapi/xapi_pool_update.ml +++ b/ocaml/xapi/xapi_pool_update.ml @@ -291,7 +291,7 @@ let attach_helper ~__context ~uuid ~vdi ~use_localhost_proxy = "/dev/" ^ Client.VBD.get_device ~rpc ~session_id ~self:vbd ) in - with_api_errors (mount device) mount_point ; + with_api_errors (mount ~ty:(Some "iso9660") device) mount_point ; debug "pool_update.attach_helper Mounted %s" mount_point ) ; let ip = diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index c31182e4142..b8419b12fb8 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -5,7 +5,6 @@ (modules (:standard \ xcp_rrdd)) (libraries astring - ezxenstore gzip http_lib @@ -41,7 +40,6 @@ (modules xcp_rrdd) (libraries astring - ezxenstore.core ezxenstore.watch forkexec diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml index c46a33d6f96..3decd260673 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml @@ -51,10 +51,10 @@ let merge_new_dss rrdi dss = !Rrdd_shared.enable_all_dss || ds.ds_default in let default_dss = StringMap.filter should_enable_ds dss in - (* NOTE: It's enough to check if all the default datasources have been added - to the RRD_INFO, because if a non-default one has been enabled at runtime, - it's added to the RRD immediately and we don't need to bother *) - let new_dss = + (* NOTE: Only add enabled dss to the live rrd, ignoring non-default ones. + This is because non-default ones are added to the RRD when they are + enabled. *) + let new_enabled_dss = StringMap.filter (fun ds_name _ -> not (StringMap.mem ds_name rrdi.dss)) default_dss @@ -73,7 +73,7 @@ let merge_new_dss rrdi dss = rrd_add_ds_unsafe rrd timestamp (Rrd.ds_create ds.ds_name ds.Ds.ds_type ~mrhb:300.0 Rrd.VT_Unknown) ) - new_dss rrdi.rrd + new_enabled_dss rrdi.rrd ) module OwnerMap = Map.Make (struct diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml index f8f3c99bf8b..fdae263d867 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -99,6 +99,7 @@ let archive_rrd vm_uuid (remote_address : string option) : unit = master host, exclusively. Any attempt to send the rrds to pools outside the host will fail. *) let backup_rrds (remote_address : string option) () : unit = + let __FUN = __FUNCTION__ in let transport = Option.map (fun address -> @@ -119,50 +120,39 @@ let backup_rrds (remote_address : string option) () : unit = | Some address -> Printf.sprintf "host %s" address in - info "%s: trying to back up RRDs to %s" __FUNCTION__ destination ; + info "%s: trying to back up RRDs to %s" __FUN destination ; let total_cycles = 5 in let cycles_tried = ref 0 in + let host_uuid = Inventory.lookup Inventory._installation_uuid in while !cycles_tried < total_cycles do if Mutex.try_lock mutex then ( cycles_tried := total_cycles ; - let vrrds = - try Hashtbl.fold (fun k v acc -> (k, v.rrd) :: acc) vm_rrds [] - with exn -> Mutex.unlock mutex ; raise exn - in - Mutex.unlock mutex ; - List.iter - (fun (uuid, rrd) -> - debug "%s: saving RRD for VM uuid=%s" __FUNCTION__ uuid ; - let rrd = with_lock mutex (fun () -> Rrd.copy_rrd rrd) in - archive_rrd_internal ~transport ~uuid ~rrd () - ) - vrrds ; - Mutex.lock mutex ; - let srrds = - try Hashtbl.fold (fun k v acc -> (k, v.rrd) :: acc) sr_rrds [] - with exn -> Mutex.unlock mutex ; raise exn + let rrds_copy = + [ + Hashtbl.fold + (fun k v acc -> ("VM", k, Rrd.copy_rrd v.rrd) :: acc) + vm_rrds [] + ; Hashtbl.fold + (fun k v acc -> ("SR", k, Rrd.copy_rrd v.rrd) :: acc) + sr_rrds [] + ; Option.fold ~none:[] + ~some:(fun rrdi -> [("host", host_uuid, Rrd.copy_rrd rrdi.rrd)]) + !host_rrd + ] + |> List.concat in Mutex.unlock mutex ; + List.iter - (fun (uuid, rrd) -> - debug "%s: saving RRD for SR uuid=%s" __FUNCTION__ uuid ; - let rrd = with_lock mutex (fun () -> Rrd.copy_rrd rrd) in + (fun (cls, uuid, rrd) -> + debug "%s: saving RRD for %s uuid=%s" __FUN cls uuid ; archive_rrd_internal ~transport ~uuid ~rrd () ) - srrds ; - match !host_rrd with - | Some rrdi -> - debug "%s: saving RRD for host" __FUNCTION__ ; - let rrd = with_lock mutex (fun () -> Rrd.copy_rrd rrdi.rrd) in - archive_rrd_internal ~transport - ~uuid:(Inventory.lookup Inventory._installation_uuid) - ~rrd () - | None -> - () + rrds_copy ) else ( cycles_tried := 1 + !cycles_tried ; if !cycles_tried >= total_cycles then - warn "%s: Could not acquire RRD lock, skipping RRD backup" __FUNCTION__ + warn "%s: Could not acquire RRD lock, skipping RRD backup" __FUN else Thread.delay 1. ) @@ -347,7 +337,7 @@ let send_host_rrd_to_master master_address = let fail_missing name = raise (Rrdd_error (Datasource_missing name)) (** {add_ds rrdi ds_name} creates a new time series (rrd) in {rrdi} with the - name {ds_name}. The operation fails if rrdi does not contain any live + name {ds_name}. The operation fails if rrdi does not contain any datasource with the name {ds_name} *) let add_ds ~rrdi ~ds_name = match Rrd.StringMap.find_opt ds_name rrdi.dss with diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml index 08807e39b74..883f9844cb5 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml @@ -77,10 +77,13 @@ let mutex = Mutex.create () type rrd_info = { rrd: Rrd.rrd + (** Contains the live metrics, i.e. The datasources that are enabled + and being collected .*) ; mutable dss: (float * Ds.ds) Rrd.StringMap.t - (* Important: this must contain the entire list of datasources associated - with the RRD, even the ones disabled by default, as rrd_add_ds calls - can enable DSs at runtime *) + (** Important: this must contain the entire list of datasources + associated with the RRD, even the ones disabled by default, because + functions like rrd_add_ds or rrd_remove_ds expect disabled + datasources to be present. e.g. to enable DSs at runtime *) ; mutable domid: int } diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index 455723633bb..afca11c3ced 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -292,7 +292,7 @@ let dss_mem_vms doms = | Ok mem -> Some ( Rrd.VM uuid - , Ds.ds_make ~name:"memory_internal_free" ~units:"B" + , Ds.ds_make ~name:"memory_internal_free" ~units:"KiB" ~description:"Dom0 current free memory" ~value:(Rrd.VT_Int64 mem) ~ty:Rrd.Gauge ~min:0.0 ~default:true () @@ -735,7 +735,7 @@ let configure_writers () = (** we need to make sure we call exit on fatal signals to make sure profiling data is dumped *) let stop err writers signal = - debug "caught signal %d" signal ; + debug "caught signal %a" Debug.Pp.signal signal ; List.iter (fun (_, writer) -> writer.Rrd_writer.cleanup ()) writers ; exit err diff --git a/ocaml/xcp-rrdd/lib/plugin/reporter.ml b/ocaml/xcp-rrdd/lib/plugin/reporter.ml index 683af78b243..b7c9c018cbd 100644 --- a/ocaml/xcp-rrdd/lib/plugin/reporter.ml +++ b/ocaml/xcp-rrdd/lib/plugin/reporter.ml @@ -12,6 +12,8 @@ * GNU Lesser General Public License for more details. *) +module Delay = Xapi_stdext_threads.Threadext.Delay + let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute (* This exception is setup to be raised on sigint by Process.initialise, @@ -57,10 +59,20 @@ type state = | Cancelled | Stopped of [`New | `Cancelled | `Failed of exn] -type t = {mutable state: state; lock: Mutex.t; condition: Condition.t} +type t = { + mutable state: state + ; lock: Mutex.t + ; condition: Condition.t + ; delay: Delay.t +} let make () = - {state= Stopped `New; lock= Mutex.create (); condition= Condition.create ()} + { + state= Stopped `New + ; lock= Mutex.create () + ; condition= Condition.create () + ; delay= Delay.make () + } let choose_protocol = function | Rrd_interface.V1 -> @@ -69,13 +81,20 @@ let choose_protocol = function Rrd_protocol_v2.protocol let wait_until_next_reading (module D : Debug.DEBUG) ~neg_shift ~uid ~protocol - ~overdue_count = + ~overdue_count ~reporter = let next_reading = RRDD.Plugin.Local.register uid Rrd.Five_Seconds protocol in let wait_time = next_reading -. neg_shift in let wait_time = if wait_time < 0.1 then wait_time +. 5. else wait_time in (* overdue count - 0 if there is no overdue; +1 if there is overdue *) if wait_time > 0. then ( - Thread.delay wait_time ; 0 + ( match reporter with + | Some reporter -> + let (_ : bool) = Delay.wait reporter.delay wait_time in + () + | None -> + Thread.delay wait_time + ) ; + 0 ) else ( if overdue_count > 1 then ( (* if register returns negative more than once in a succession, @@ -84,7 +103,12 @@ let wait_until_next_reading (module D : Debug.DEBUG) ~neg_shift ~uid ~protocol D.debug "rrdd says next reading is overdue, seems like rrdd is busy;\n\ \t\t\t\tBacking off for %.1f seconds" backoff_time ; - Thread.delay backoff_time + match reporter with + | Some reporter -> + let (_ : bool) = Delay.wait reporter.delay backoff_time in + () + | None -> + Thread.delay backoff_time ) else D.debug "rrdd says next reading is overdue by %.1f seconds; not sleeping" (-.wait_time) ; @@ -147,8 +171,10 @@ let cancel ~reporter = match reporter.state with | Running -> reporter.state <- Cancelled ; + Delay.signal reporter.delay ; Condition.wait reporter.condition reporter.lock | Cancelled -> + Delay.signal reporter.delay ; Condition.wait reporter.condition reporter.lock | Stopped _ -> () diff --git a/ocaml/xcp-rrdd/lib/plugin/reporter_local.ml b/ocaml/xcp-rrdd/lib/plugin/reporter_local.ml index 42955b5ae1f..fec90d1dc8e 100644 --- a/ocaml/xcp-rrdd/lib/plugin/reporter_local.ml +++ b/ocaml/xcp-rrdd/lib/plugin/reporter_local.ml @@ -28,7 +28,7 @@ let start_local (module D : Debug.DEBUG) ~reporter ~uid ~neg_shift ~page_count overdue_count := wait_until_next_reading (module D) - ~neg_shift ~uid ~protocol ~overdue_count:!overdue_count ; + ~neg_shift ~uid ~protocol ~overdue_count:!overdue_count ~reporter ; if page_count > 0 then let payload = Rrd_protocol.{timestamp= Utils.now (); datasources= dss_f ()} diff --git a/ocaml/xcp-rrdd/lib/plugin/utils.ml b/ocaml/xcp-rrdd/lib/plugin/utils.ml index d647c25fd67..1f0f6f153e9 100644 --- a/ocaml/xcp-rrdd/lib/plugin/utils.ml +++ b/ocaml/xcp-rrdd/lib/plugin/utils.ml @@ -63,8 +63,8 @@ let exec_cmd (module D : Debug.DEBUG) ~cmdstring ~(f : string -> 'a option) = | Unix.WEXITED n -> D.debug "Process %d exited normally with code %d" pid n | Unix.WSIGNALED s -> - D.debug "Process %d was killed by signal %d" pid s + D.debug "Process %d was killed by signal %a" pid Debug.Pp.signal s | Unix.WSTOPPED s -> - D.debug "Process %d was stopped by signal %d" pid s + D.debug "Process %d was stopped by signal %a" pid Debug.Pp.signal s ) ; List.rev !vals diff --git a/ocaml/xenopsd/lib/cancellable_subprocess.ml b/ocaml/xenopsd/lib/cancellable_subprocess.ml index 0ba4edeb71c..4e80c34ac28 100644 --- a/ocaml/xenopsd/lib/cancellable_subprocess.ml +++ b/ocaml/xenopsd/lib/cancellable_subprocess.ml @@ -76,16 +76,16 @@ let run (task : Xenops_task.task_handle) ?env ?stdin fds raise (Spawn_internal_error (err, out, Unix.WEXITED n)) | Unix.WSTOPPED n -> raise (Spawn_internal_error (err, out, Unix.WSTOPPED n)) - | Unix.WSIGNALED n -> + | Unix.WSIGNALED s -> if !cancelled then ( debug - "Subprocess %s exited with signal %d and cancel requested; \ + "Subprocess %s exited with signal %a and cancel requested; \ raising Cancelled" - cmd n ; + cmd Debug.Pp.signal s ; Xenops_task.raise_cancelled task ) else ( - debug "Subprocess %s exited with signal %d" cmd n ; - raise (Spawn_internal_error (err, out, Unix.WSIGNALED n)) + debug "Subprocess %s exited with signal %a" cmd Debug.Pp.signal s ; + raise (Spawn_internal_error (err, out, Unix.WSIGNALED s)) ) ) | Success (_, Failure (_, exn)) | Failure (_, exn) -> diff --git a/ocaml/xenopsd/lib/dune b/ocaml/xenopsd/lib/dune index 2810eb88ef3..f7226792549 100644 --- a/ocaml/xenopsd/lib/dune +++ b/ocaml/xenopsd/lib/dune @@ -9,6 +9,7 @@ fd-send-recv fmt forkexec + mtime re gzip zstd diff --git a/ocaml/xenopsd/lib/suspend_image.ml b/ocaml/xenopsd/lib/suspend_image.ml index e08cb53c268..8733b9155cf 100644 --- a/ocaml/xenopsd/lib/suspend_image.ml +++ b/ocaml/xenopsd/lib/suspend_image.ml @@ -275,15 +275,15 @@ let with_conversion_script task name hvm fd f = | Unix.WSIGNALED n -> Error (Failure - (Printf.sprintf "Conversion script exited with signal %s" - (Unixext.string_of_signal n) + (Printf.sprintf "Conversion script exited with signal %a" + Debug.Pp.signal n ) ) | Unix.WSTOPPED n -> Error (Failure - (Printf.sprintf "Conversion script stopped with signal %s" - (Unixext.string_of_signal n) + (Printf.sprintf "Conversion script stopped with signal %a" + Debug.Pp.signal n ) ) ) diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index f4c784faa11..e3f0a77f5e8 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -278,6 +278,15 @@ let rec name_of_atomic = function | Best_effort atomic -> Printf.sprintf "Best_effort (%s)" (name_of_atomic atomic) +let rec atomic_expires_after = function + | Serial (_, _, ops) -> + List.map atomic_expires_after ops |> List.fold_left ( +. ) 0. + | Parallel (_, _, ops) -> + List.map atomic_expires_after ops |> List.fold_left Float.max 0. + | _ -> + (* 20 minutes, in seconds *) + 1200. + type vm_migrate_op = { vmm_id: Vm.id ; vmm_vdi_map: (string * string) list @@ -1848,7 +1857,7 @@ let with_tracing ~name ~task f = warn "Failed to start tracing: %s" (Printexc.to_string e) ; f () -let rec perform_atomic ~progress_callback ?subtask:_ ?result (op : atomic) +let rec perform_atomic ~progress_callback ?result (op : atomic) (t : Xenops_task.task_handle) : unit = let module B = (val get_backend () : S) in with_tracing ~name:(name_of_atomic op) ~task:t @@ fun () -> @@ -2341,16 +2350,17 @@ and queue_atomics_and_wait ~progress_callback ~max_parallel_atoms dbg id ops = let atom_id = Printf.sprintf "%s.chunk=%d.atom=%d" id chunk_idx atom_idx in - queue_atomic_int ~progress_callback dbg atom_id op + (queue_atomic_int ~progress_callback dbg atom_id op, op) ) ops in let timeout_start = Unix.gettimeofday () in List.map - (fun task -> + (fun (task, op) -> let task_id = Xenops_task.id_of_handle task in + let expiration = atomic_expires_after op in let completion = - event_wait updates task ~from ~timeout_start 1200.0 + event_wait updates task ~from ~timeout_start expiration (is_task task_id) task_ended in (task_id, task, completion) @@ -2386,7 +2396,7 @@ let perform_atomics atomics t = progress_callback progress (weight /. total_weight) t in debug "Performing: %s" (string_of_atomic x) ; - perform_atomic ~subtask:(string_of_atomic x) ~progress_callback x t ; + perform_atomic ~progress_callback x t ; progress_callback 1. ; progress +. (weight /. total_weight) ) @@ -2520,8 +2530,7 @@ and trigger_cleanup_after_failure_atom op t = | VM_import_metadata _ -> () -and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) - : unit = +and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit = let module B = (val get_backend () : S) in with_tracing ~name:(name_of_operation op) ~task:t @@ fun () -> match op with @@ -2648,9 +2657,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) (id, vm.Vm.memory_dynamic_min, vm.Vm.memory_dynamic_min) in let (_ : unit) = - perform_atomic ~subtask:(string_of_atomic atomic) - ~progress_callback:(fun _ -> ()) - atomic t + perform_atomic ~progress_callback:(fun _ -> ()) atomic t in (* Waiting here is not essential but adds a degree of safety and reducess unnecessary memory copying. *) @@ -3162,7 +3169,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) VUSB_DB.signal id | Atomic op -> let progress_callback = progress_callback 0. 1. t in - perform_atomic ~progress_callback ?subtask ?result op t + perform_atomic ~progress_callback ?result op t and verify_power_state op = let module B = (val get_backend () : S) in @@ -3191,7 +3198,7 @@ and perform ?subtask ?result (op : operation) (t : Xenops_task.task_handle) : unit = let one op = verify_power_state op ; - try perform_exn ?subtask ?result op t + try perform_exn ?result op t with e -> Backtrace.is_important e ; info "Caught %s executing %s: triggering cleanup actions" diff --git a/ocaml/xenopsd/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index 8d3c9b75f88..cb79fd20991 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -37,7 +37,7 @@ let vgpu_ready_timeout = ref 30. let varstored_ready_timeout = ref 30. -let swtpm_ready_timeout = ref 60 +let swtpm_ready_timeout = ref Mtime.Span.(1 * min) let use_upstream_qemu = ref false @@ -459,8 +459,11 @@ let main backend = ~rpc_fn () in (* we need to catch this to make sure at_exit handlers are triggered. In - particuar, triggers for the bisect_ppx coverage profiling *) - let signal_handler n = debug "caught signal %d" n ; exit 0 in + particular, triggers for the bisect_ppx coverage profiling *) + let signal_handler n = + debug "caught signal %a" Debug.Pp.signal n ; + exit 0 + in Sys.set_signal Sys.sigpipe Sys.Signal_ignore ; Sys.set_signal Sys.sigterm (Sys.Signal_handle signal_handler) ; Xenops_utils.set_fs_backend diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index d33fc482e5f..fce32abf19b 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -625,6 +625,7 @@ let shutdown_wait_for_ack (t : Xenops_task.task_handle) ~timeout ~xc ~xs domid (domain_type : [`pv | `pvh | `hvm]) req = let di = Xenctrl.domain_getinfo xc domid in let uuid = get_uuid ~xc domid in + let uuid = Uuidx.to_string uuid in let expecting_ack = match (di.Xenctrl.hvm_guest, domain_type) with | false, _ -> @@ -640,12 +641,12 @@ let shutdown_wait_for_ack (t : Xenops_task.task_handle) ~timeout ~xc ~xs domid debug "VM = %s; domid = %d; HVM guest without PV drivers: not expecting any \ acknowledgement" - (Uuidx.to_string uuid) domid ; + uuid domid ; Xenctrl.domain_shutdown xc domid (shutdown_to_xc_shutdown req) ) else ( debug "VM = %s; domid = %d; Waiting for domain to acknowledge shutdown request" - (Uuidx.to_string uuid) domid ; + uuid domid ; let path = control_shutdown ~xs domid in let cancel = Domain domid in if @@ -654,11 +655,10 @@ let shutdown_wait_for_ack (t : Xenops_task.task_handle) ~timeout ~xc ~xs domid [Watch.key_to_disappear path] t ~xs ~timeout () then - info "VM = %s; domid = %d; Domain acknowledged shutdown request" - (Uuidx.to_string uuid) domid - else - debug "VM = %s; domid = %d; Domain disappeared" (Uuidx.to_string uuid) + info "VM = %s; domid = %d; Domain acknowledged shutdown request" uuid domid + else + debug "VM = %s; domid = %d; Domain disappeared" uuid domid ) let sysrq ~xs domid key = diff --git a/ocaml/xenopsd/xc/service.ml b/ocaml/xenopsd/xc/service.ml index 98c942d13a9..6462852cf4a 100644 --- a/ocaml/xenopsd/xc/service.ml +++ b/ocaml/xenopsd/xc/service.ml @@ -40,7 +40,7 @@ type t = { ; exec_path: string ; pid_filename: string ; chroot: Chroot.t - ; timeout_seconds: int + ; timeout: Mtime.Span.t ; args: string list ; execute: path:string -> args:string list -> domid:Xenctrl.domid -> unit -> string @@ -180,7 +180,7 @@ let start_and_wait_for_readyness ~task ~service = Xenops_task.check_cancelling task ; - let amount = Mtime.Span.(service.timeout_seconds * s) in + let amount = service.timeout in (* wait for pidfile to appear *) Result.iter_error raise_e (wait ~amount ~service_name:syslog_key) ; @@ -797,16 +797,14 @@ module Swtpm = struct swtpm-wrapper runs as a service and getting the exact error back is difficult. *) let needs_init = check_state_needs_init task vtpm_uuid in - let timeout_seconds = !Xenopsd.swtpm_ready_timeout in + let timeout = !Xenopsd.swtpm_ready_timeout in if needs_init then ( debug "vTPM %s is empty, needs to be created" (Uuidm.to_string vtpm_uuid) ; let key = Printf.sprintf "%s-%d" (Filename.basename exec_path) domid in let _, _ = Forkhelpers.execute_command_get_output ~syslog_stdout:(Forkhelpers.Syslog_WithKey key) - ~redirect_stderr_to_stdout:true - ~timeout:(float_of_int timeout_seconds) - exec_path (args true) + ~redirect_stderr_to_stdout:true ~timeout exec_path (args true) in let state_file = Filename.concat tpm_root "tpm2-00.permall" in let state = Unixext.string_of_file state_file |> Base64.encode_exn in @@ -825,7 +823,7 @@ module Swtpm = struct ; chroot ; args= args false ; execute - ; timeout_seconds + ; timeout } in diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index d97ddede77b..7f6ede23895 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -2465,9 +2465,8 @@ module VM = struct | true -> Unixext.with_file path [Unix.O_RDONLY] 0o600 f_synced | false -> - with_mounted_dir_ro path @@ fun dir -> - let filename = Filename.concat dir "suspend-image" in - Unixext.with_file filename [Unix.O_RDONLY] 0o600 f_synced + error "%s: can't mount %s" __FUNCTION__ path ; + internal_error "can't mount %s (not a file or block dev)" path ) let wait_ballooning task vm =