diff --git a/message-switch.opam b/message-switch.opam index a79ad87c4c1..7267b4725fb 100644 --- a/message-switch.opam +++ b/message-switch.opam @@ -18,7 +18,7 @@ depends: [ "cmdliner" "cohttp-async" {with-test} "cohttp-lwt-unix" - "io-page-unix" + "io-page" {>= "2.4.0"} "lwt_log" "message-switch-async" {with-test} "message-switch-lwt" diff --git a/ocaml/gencert/lib.ml b/ocaml/gencert/lib.ml index 612c0b4f374..b4ea8885ec8 100644 --- a/ocaml/gencert/lib.ml +++ b/ocaml/gencert/lib.ml @@ -22,7 +22,7 @@ type t_certificate = Leaf | Chain let () = Mirage_crypto_rng_unix.initialize () let validate_private_key pkcs8_private_key = - let ensure_key_length = function + let ensure_rsa_key_length = function | `RSA priv -> let length = Mirage_crypto_pk.Rsa.priv_bits priv in if length < 2048 || length > 4096 then @@ -34,6 +34,9 @@ let validate_private_key pkcs8_private_key = ) else Ok (`RSA priv) + | key -> + let key_type = X509.(Key_type.to_string (Private_key.key_type key)) in + Error (`Msg (server_certificate_key_algorithm_not_supported, [key_type])) in let raw_pem = Cstruct.of_string pkcs8_private_key in X509.Private_key.decode_pem raw_pem @@ -55,7 +58,7 @@ let validate_private_key pkcs8_private_key = `Msg (server_certificate_key_invalid, []) ) ) - >>= ensure_key_length + >>= ensure_rsa_key_length let pem_of_string x ~error_invalid = let raw_pem = Cstruct.of_string x in diff --git a/ocaml/gencert/selfcert.ml b/ocaml/gencert/selfcert.ml index 212bcbacd1d..0f488ee80a9 100644 --- a/ocaml/gencert/selfcert.ml +++ b/ocaml/gencert/selfcert.ml @@ -118,16 +118,14 @@ let generate_pub_priv_key length = |> X509.Private_key.decode_pem |> R.reword_error (fun _ -> R.msg "decoding private key failed") in - let* rsa = - try match privkey with `RSA x -> Ok x - with _ -> R.error_msg "generated private key does not use RSA" - in + let err_not_rsa = R.error_msg "generated private key does not use RSA" in + let* rsa = match privkey with `RSA x -> Ok x | _ -> err_not_rsa in let pubkey = `RSA (Rsa.pub_of_priv rsa) in Ok (privkey, pubkey) let selfsign' issuer extensions key_length expiration = let* privkey, pubkey = generate_pub_priv_key key_length in - let req = X509.Signing_request.create issuer privkey in + let* req = X509.Signing_request.create issuer privkey in let* cert = sign expiration privkey pubkey issuer req extensions in let key_pem = X509.Private_key.encode_pem privkey in let cert_pem = X509.Certificate.encode_pem cert in diff --git a/ocaml/gencert/test_lib.ml b/ocaml/gencert/test_lib.ml index 7c8804eefd9..7f61e0ecf4d 100644 --- a/ocaml/gencert/test_lib.ml +++ b/ocaml/gencert/test_lib.ml @@ -5,6 +5,8 @@ open Gencertlib.Lib open Api_errors open Rresult.R.Infix +let ( let* ) = Rresult.R.bind + (* Initialize RNG for testing certificates *) let () = Mirage_crypto_rng_unix.initialize () @@ -36,10 +38,7 @@ let invalid_private_keys = ("pkey_rsa_1024", server_certificate_key_rsa_length_not_supported, ["1024"]) ; ("pkey_rsa_8192", server_certificate_key_rsa_length_not_supported, ["8192"]) ; ("pkey_rsa_n3_2048", server_certificate_key_rsa_multi_not_supported, []) - ; ( "pkey_ed25519" - , server_certificate_key_algorithm_not_supported - , ["1.3.101.112"] - ) + ; ("pkey_ed25519", server_certificate_key_algorithm_not_supported, ["ed25519"]) ; ("pkey_bogus", server_certificate_key_invalid, []) ] @@ -194,9 +193,9 @@ let load_pkcs8 name = ) let sign_cert host_name ~pkey_sign digest pkey_leaf = - let csr = X509.Signing_request.create [host_name] ~digest pkey_leaf in + let* csr = X509.Signing_request.create [host_name] ~digest pkey_leaf in X509.Signing_request.sign csr ~valid_from ~valid_until ~digest - ~hash_whitelist:[digest] pkey_sign [host_name] + ~allowed_hashes:[digest] pkey_sign [host_name] |> Rresult.R.error_to_msg ~pp_error:X509.Validation.pp_signature_error let sign_leaf_cert host_name digest pkey_leaf = diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 0c603e13e84..706fc37b0e2 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -20,9 +20,9 @@ let prototyped_of_field = function | "host", "last_software_update" -> Some "22.20.0" | "VM", "actions__after_softreboot" -> - Some "22.34.0-next" + Some "22.37.0-next" | "pool", "coordinator_bias" -> - Some "22.34.0-next" + Some "22.37.0" | "pool", "migration_compression" -> Some "22.33.0" | _ -> diff --git a/ocaml/idl/ocaml_backend/gen_server.ml b/ocaml/idl/ocaml_backend/gen_server.ml index fe14e698e20..88d8996c99b 100644 --- a/ocaml/idl/ocaml_backend/gen_server.ml +++ b/ocaml/idl/ocaml_backend/gen_server.ml @@ -300,8 +300,9 @@ let operation (obj : obj) (x : message) = let session_check_exp = if x.msg_session then [ - Printf.sprintf "Session_check.check ~intra_pool_only:%b ~session_id;" - x.msg_pool_internal + Printf.sprintf + {|Session_check.check ~intra_pool_only:%b ~session_id ~action:"%s";|} + x.msg_pool_internal wire_name ] else [] @@ -528,19 +529,19 @@ let gen_module api : O.Module.t = ^ debug "This is not a built-in rpc \"%s\"" ["__call"] ; " begin match __params with" ; " | session_id_rpc :: _->" + ; " (* based on the Host.call_extension call *)" + ; " let action = \"Host.call_extension\" in" ; " let session_id = ref_session_of_rpc session_id_rpc in" ; " Session_check.check ~intra_pool_only:false \ - ~session_id;" - ; " (* based on the Host.call_extension call *)" + ~session_id ~action;" ; " let call_rpc = Rpc.String __call in " ; " let arg_names_values =" ; " [(\"session_id\", session_id_rpc); (__call, \ call_rpc)]" ; " in" ; " let key_names = [] in" - ; " let rbac __context fn = Rbac.check session_id \ - \"Host.call_extension\" ~args:arg_names_values \ - ~keys:key_names ~__context ~fn in" + ; " let rbac __context fn = Rbac.check session_id action \ + ~args:arg_names_values ~keys:key_names ~__context ~fn in" ; " Server_helpers.forward_extension ~__context rbac { \ call with Rpc.name = __call }" ; " | _ ->" diff --git a/ocaml/message-switch/async/protocol_async.ml b/ocaml/message-switch/async/protocol_async.ml index 9d8684f64fd..e4fb209a166 100644 --- a/ocaml/message-switch/async/protocol_async.ml +++ b/ocaml/message-switch/async/protocol_async.ml @@ -56,7 +56,7 @@ module M = struct Monitor.try_with ~extract_exn:true connect >>= function | Error (Unix.Unix_error - (Core.(Unix.ECONNREFUSED | Unix.ECONNABORTED | Unix.ENOENT), _, _) + (Core_unix.(ECONNREFUSED | ECONNABORTED | ENOENT), _, _) ) -> let delay = Float.min maximum_delay delay in Clock.after (Time.Span.of_sec delay) >>= fun () -> diff --git a/ocaml/message-switch/switch/dune b/ocaml/message-switch/switch/dune index 6bd7df7f5a9..d05877491d2 100644 --- a/ocaml/message-switch/switch/dune +++ b/ocaml/message-switch/switch/dune @@ -8,7 +8,7 @@ cohttp-lwt-unix conduit-lwt-unix cstruct - io-page-unix + io-page lwt lwt.unix lwt_log diff --git a/ocaml/nbd/src/main.ml b/ocaml/nbd/src/main.ml index cd1d22d427f..21c48b5acac 100644 --- a/ocaml/nbd/src/main.ml +++ b/ocaml/nbd/src/main.ml @@ -84,7 +84,7 @@ let init_tls_get_server_ctx ~certfile = Some (Nbd_unix.TlsServer (Nbd_unix.init_tls_get_ctx ~curve:"secp384r1" ~certfile - ~ciphersuites:Constants.good_ciphersuites + ~ciphersuites:Constants.good_ciphersuites () ) ) diff --git a/ocaml/vhd-tool/src/dune b/ocaml/vhd-tool/src/dune index 31a8b24a41a..0d8436915ae 100644 --- a/ocaml/vhd-tool/src/dune +++ b/ocaml/vhd-tool/src/dune @@ -11,7 +11,7 @@ cohttp cohttp-lwt cstruct - io-page.unix + io-page lwt lwt.unix lwt_ssl diff --git a/ocaml/xapi-guard/lib/varstored_interface.ml b/ocaml/xapi-guard/lib/varstored_interface.ml index 9f4ee22584b..6ba2839fbd8 100644 --- a/ocaml/xapi-guard/lib/varstored_interface.ml +++ b/ocaml/xapi-guard/lib/varstored_interface.ml @@ -154,7 +154,8 @@ let with_xapi ~cache f = let rec wait_connectable path = let* res = Lwt_result.catch - (Conduit_lwt_unix.connect ~ctx:Conduit_lwt_unix.default_ctx + (Conduit_lwt_unix.connect + ~ctx:(Lazy.force Conduit_lwt_unix.default_ctx) (`Unix_domain_socket (`File path)) ) in diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 892d7103203..5851006be5c 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -1709,12 +1709,10 @@ let main ~root_dir ~state_path ~switch_path = Attached_SRs.reload state_path >>= fun () -> let datapath_root = Filename.concat root_dir "datapath" in Async_inotify.create ~recursive:false ~watch_new_dirs:false datapath_root - >>= fun (watch, _) -> - let datapath = Async_inotify.pipe watch in + >>= fun (_, _, datapath) -> let volume_root = Filename.concat root_dir "volume" in Async_inotify.create ~recursive:false ~watch_new_dirs:false volume_root - >>= fun (watch, _) -> - let volume = Async_inotify.pipe watch in + >>= fun (_, _, volume) -> let rec loop () = Monitor.try_with (fun () -> Deferred.all_unit diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index 2ff1363d725..202d7b420c3 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -1936,13 +1936,13 @@ let handle_all __context config rpc session_id (xs : obj list) = (** Read the next file in the archive as xml *) let read_xml hdr fd = - Unixext.really_read_string fd (Int64.to_int hdr.Tar_unix.Header.file_size) + Unixext.really_read_string fd (Int64.to_int hdr.Tar.Header.file_size) let assert_filename_is hdr = let expected = Xapi_globs.ova_xml_filename in - let actual = hdr.Tar_unix.Header.file_name in + let actual = hdr.Tar.Header.file_name in if expected <> actual then ( - let hex = Tar_unix.Header.to_hex in + let hex = Tar.Header.to_hex in error "import expects the next file in the stream to be [%s]; got [%s]" (hex expected) (hex actual) ; raise (IFailure (Unexpected_file (expected, actual))) @@ -1953,17 +1953,17 @@ let assert_filename_is hdr = the lot through an appropriate decompressor and try again *) let with_open_archive fd ?length f = (* Read the first header's worth into a buffer *) - let buffer = Cstruct.create Tar_unix.Header.length in + let buffer = Cstruct.create Tar.Header.length in let retry_with_compression = ref true in try Tar_unix.really_read fd buffer ; (* we assume the first block is not all zeroes *) - let hdr = Option.get (Tar_unix.Header.unmarshal buffer) in + let hdr = Option.get (Tar.Header.unmarshal buffer) in assert_filename_is hdr ; (* successfully opened uncompressed stream *) retry_with_compression := false ; let xml = read_xml hdr fd in - Tar_helpers.skip fd (Tar_unix.Header.compute_zero_padding_length hdr) ; + Tar_helpers.skip fd (Tar.Header.compute_zero_padding_length hdr) ; f xml fd with e -> if not !retry_with_compression then raise e ; @@ -1994,11 +1994,11 @@ let with_open_archive fd ?length f = Tar_unix.really_write compressed_in buffer ; let limit = Option.map - (fun x -> Int64.sub x (Int64.of_int Tar_unix.Header.length)) + (fun x -> Int64.sub x (Int64.of_int Tar.Header.length)) length in let n = Unixext.copy_file ?limit fd compressed_in in - debug "Written a total of %d + %Ld bytes" Tar_unix.Header.length n + debug "Written a total of %d + %Ld bytes" Tar.Header.length n ) ) (fun () -> ignore_exn (fun () -> Unix.close pipe_in)) @@ -2006,11 +2006,10 @@ let with_open_archive fd ?length f = let consumer pipe_out feeder_t = finally (fun () -> - let hdr = Tar_unix.Header.get_next_header pipe_out in + let hdr = Tar_unix.get_next_header pipe_out in assert_filename_is hdr ; let xml = read_xml hdr pipe_out in - Tar_helpers.skip pipe_out - (Tar_unix.Header.compute_zero_padding_length hdr) ; + Tar_helpers.skip pipe_out (Tar.Header.compute_zero_padding_length hdr) ; f xml pipe_out ) (fun () -> @@ -2103,7 +2102,7 @@ let with_error_handling f = (Api_errors.import_error_attached_disks_not_found, []) ) | Unexpected_file (expected, actual) -> - let hex = Tar_unix.Header.to_hex in + let hex = Tar.Header.to_hex in error "Invalid XVA file: import expects the next file in the stream to \ be \"%s\" [%s]; got \"%s\" [%s]" @@ -2159,7 +2158,7 @@ let metadata_handler (req : Request.t) s _ = (fun metadata s -> debug "Got XML" ; (* Skip trailing two zero blocks *) - Tar_helpers.skip s (Tar_unix.Header.length * 2) ; + Tar_helpers.skip s (Tar.Header.length * 2) ; let header = metadata |> Xmlrpc.of_string |> header_of_rpc in assert_compatible ~__context header.version ; if full_restore then diff --git a/ocaml/xapi/session_check.ml b/ocaml/xapi/session_check.ml index 324e8de46a8..16fef1ac30b 100644 --- a/ocaml/xapi/session_check.ml +++ b/ocaml/xapi/session_check.ml @@ -28,7 +28,7 @@ let is_local_session __context session_id = !check_local_session_hook (* intra_pool_only is true iff the call that's invoking this check can only be called from host<->host intra-pool communication *) -let check ~intra_pool_only ~session_id = +let check ~intra_pool_only ~session_id ~action = Server_helpers.exec_with_new_task ~quiet:true "session_check" (fun __context -> (* First see if this is a "local" session *) @@ -40,17 +40,16 @@ let check ~intra_pool_only ~session_id = Db_actions.DB_Action.Session.get_pool ~__context ~self:session_id in (* If the session is not a pool login, but this call is only supported for pool logins then fail *) - if (not pool) && intra_pool_only then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - "Internal API call attempted with non-pool (external) \ - session" - ] - ) - ) ; - (* If the session isn't a pool login, and we're a slave, fail *) + ( if (not pool) && intra_pool_only then + let msg = + Printf.sprintf + {|Internal API "%s" call attempted with non-pool (external) session|} + action + in + raise Api_errors.(Server_error (internal_error, [msg])) + ) ; + + (* If the session isn't a pool login, and we're a supporter, fail *) if (not pool) && not (Pool_role.is_master ()) then raise Non_master_login_on_slave ; if Pool_role.is_master () then diff --git a/ocaml/xapi/session_check.mli b/ocaml/xapi/session_check.mli new file mode 100644 index 00000000000..73c8bcf282f --- /dev/null +++ b/ocaml/xapi/session_check.mli @@ -0,0 +1,9 @@ +exception Non_master_login_on_slave + +val check_local_session_hook : + (__context:Context.t -> session_id:[`session] Ref.t -> bool) option ref + +val is_local_session : Context.t -> [`session] Ref.t -> bool + +val check : + intra_pool_only:bool -> session_id:[`session] Ref.t -> action:string -> unit diff --git a/ocaml/xapi/stream_vdi.ml b/ocaml/xapi/stream_vdi.ml index f70940f1964..64b1da93eee 100644 --- a/ocaml/xapi/stream_vdi.ml +++ b/ocaml/xapi/stream_vdi.ml @@ -372,8 +372,8 @@ exception Invalid_checksum of string (* Rio GA and later only *) let verify_inline_checksum ifd checksum_table hdr = - let file_name = hdr.Tar_unix.Header.file_name in - let length = hdr.Tar_unix.Header.file_size in + let file_name = hdr.Tar.Header.file_name in + let length = hdr.Tar.Header.file_size in if not (List.exists @@ -394,7 +394,7 @@ let verify_inline_checksum ifd checksum_table hdr = let csum = Bytes.make length' ' ' in Unixext.really_read ifd csum 0 length' ; let csum = Bytes.unsafe_to_string csum in - Tar_helpers.skip ifd (Tar_unix.Header.compute_zero_padding_length hdr) ; + Tar_helpers.skip ifd (Tar.Header.compute_zero_padding_length hdr) ; (* Look up the relevant file_name in the checksum_table *) let original_file_name = Filename.remove_extension file_name in let csum' = List.assoc original_file_name !checksum_table in @@ -434,9 +434,9 @@ let recv_all_vdi refresh_session ifd (__context : Context.t) rpc session_id refresh_session () ; let remaining = Int64.sub size offset in if remaining > 0L then ( - let hdr = Tar_unix.Header.get_next_header ifd in - let file_name = hdr.Tar_unix.Header.file_name in - let length = hdr.Tar_unix.Header.file_size in + let hdr = Tar_unix.get_next_header ifd in + let file_name = hdr.Tar.Header.file_name in + let length = hdr.Tar.Header.file_size in (* First chunk will always be there *) if !firstchunklength < 0 then ( firstchunklength := Int64.to_int length ; @@ -487,9 +487,9 @@ let recv_all_vdi refresh_session ifd (__context : Context.t) rpc session_id Unixext.really_read ifd buffer 0 (Int64.to_int length) ; Unix.write ofd buffer 0 (Int64.to_int length) |> ignore ; let buffer_string = Bytes.unsafe_to_string buffer in - let csum_hdr = Tar_unix.Header.get_next_header ifd in + let csum_hdr = Tar_unix.get_next_header ifd in (* Header of the checksum file *) - let csum_file_name = csum_hdr.Tar_unix.Header.file_name in + let csum_file_name = csum_hdr.Tar.Header.file_name in let csum = (* Infer checksum algorithm from the file extension *) match Filename.extension csum_file_name with @@ -505,8 +505,7 @@ let recv_all_vdi refresh_session ifd (__context : Context.t) rpc session_id error "%s" msg ; raise (Failure msg) in checksum_table := (file_name, csum) :: !checksum_table ; - Tar_helpers.skip ifd - (Tar_unix.Header.compute_zero_padding_length hdr) ; + Tar_helpers.skip ifd (Tar.Header.compute_zero_padding_length hdr) ; made_progress __context progress (Int64.add skipped_size length) ; ( if has_inline_checksums then try verify_inline_checksum ifd checksum_table csum_hdr @@ -542,8 +541,8 @@ let recv_all_zurich refresh_session ifd (__context : Context.t) rpc session_id let hdr = ref None in let next () = hdr := - try Some (Tar_unix.Header.get_next_header ifd) with - | Tar_unix.Header.End_of_stream -> + try Some (Tar_unix.get_next_header ifd) with + | Tar.Header.End_of_stream -> None | e -> raise e @@ -558,8 +557,8 @@ let recv_all_zurich refresh_session ifd (__context : Context.t) rpc session_id match !hdr with | Some hdr -> refresh_session () ; - let file_name = hdr.Tar_unix.Header.file_name in - let length = hdr.Tar_unix.Header.file_size in + let file_name = hdr.Tar.Header.file_name in + let length = hdr.Tar.Header.file_size in if Astring.String.is_prefix ~affix:prefix file_name then ( let suffix = String.sub file_name (String.length prefix) @@ -576,8 +575,7 @@ let recv_all_zurich refresh_session ifd (__context : Context.t) rpc session_id Gzip.Default.decompress ofd (fun zcat_in -> Tar_helpers.copy_n ifd zcat_in length ) ; - Tar_helpers.skip ifd - (Tar_unix.Header.compute_zero_padding_length hdr) ; + Tar_helpers.skip ifd (Tar.Header.compute_zero_padding_length hdr) ; (* XXX: this is totally wrong: *) made_progress __context progress length ; next () ; diff --git a/ocaml/xcp-rrdd/lib/transport/page/dune b/ocaml/xcp-rrdd/lib/transport/page/dune index 7e396f2da29..b61de41c8bf 100644 --- a/ocaml/xcp-rrdd/lib/transport/page/dune +++ b/ocaml/xcp-rrdd/lib/transport/page/dune @@ -5,7 +5,7 @@ (libraries bigarray-compat cstruct - io-page.unix + io-page rrd_transport_lib threads.posix xen-gnt diff --git a/ocaml/xen-api-client/async_examples/event_test.ml b/ocaml/xen-api-client/async_examples/event_test.ml index a381c0484e8..7489fd7ac7e 100644 --- a/ocaml/xen-api-client/async_examples/event_test.ml +++ b/ocaml/xen-api-client/async_examples/event_test.ml @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -open Core_kernel +open Core open Async open Xen_api_async_unix diff --git a/ocaml/xen-api-client/lwt_examples/watch_metrics.ml b/ocaml/xen-api-client/lwt_examples/watch_metrics.ml index 05c85c77985..0f5151d3a54 100644 --- a/ocaml/xen-api-client/lwt_examples/watch_metrics.ml +++ b/ocaml/xen-api-client/lwt_examples/watch_metrics.ml @@ -55,9 +55,7 @@ let main () = Client.call ~headers `GET uri >>= fun (res, body) -> let headers = Response.headers res in - Cohttp.Header.iter - (fun k v -> List.iter (Printf.eprintf "%s: %s\n%!" k) v) - headers ; + Cohttp.Header.iter (fun k v -> Printf.eprintf "%s: %s\n%!" k v) headers ; Cohttp_lwt.Body.to_string body >>= fun s -> let update = Xen_api_metrics.Updates.parse s in Printf.eprintf "%s\n%!" (Rrd_updates.string_of update) ; diff --git a/ocaml/xenopsd/xc/service.ml b/ocaml/xenopsd/xc/service.ml index 7ca0969b046..8a00f6ef8fd 100644 --- a/ocaml/xenopsd/xc/service.ml +++ b/ocaml/xenopsd/xc/service.ml @@ -456,7 +456,7 @@ module Vgpu = struct } -> (* The VGPU UUID is not available. Create a fresh one; xapi will deal with it. *) - let uuid = Uuidm.to_string (Uuidm.create `V4) in + let uuid = Uuidx.(to_string (make ())) in debug "NVidia vGPU config: using config file %s and uuid %s" config_file uuid ; make addr diff --git a/quality-gate.sh b/quality-gate.sh index 1fcb1d2e88d..559a0884cc3 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=511 + N=510 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)