Merge pull request #4786 from psafont/private/paus/refresh

fixes #4686

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"

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

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

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 =

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"
   | _ ->

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 }"
                  ; "    | _ ->"

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 () ->

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

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 ()
        )
     )
 

ocaml/vhd-tool/src/dune

@@ -11,7 +11,7 @@
     cohttp
     cohttp-lwt
     cstruct
-    io-page.unix
+    io-page
     lwt
     lwt.unix
     lwt_ssl

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

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

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,23 +1994,22 @@ 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))
     in
     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

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

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