xapi_vdi_helpers: actually write raw vdi when possible (#6334)

An `if ... then raise exn;`was misread and make the code after
impossible to execute, when that was not the intention.

Remove all the ignore_<type> functions from stdext: a plain ignore with
a type annotation can replace these. We should start using those for all
ignores (there are too many of them, and can't be easily automated to do
it in this PR)

Passes internal tests: 213465 (one failure due to the recent vlan +
clustering issue)

Author: psafont

dune-project

@@ -39,7 +39,7 @@
 
 (package
   (name tgroup)
-  (depends 
+  (depends
     xapi-log
     xapi-stdext-unix)
 )
@@ -502,6 +502,21 @@ This package provides an Lwt compatible interface to the library.")
 
 (package
   (name stunnel)
+  (synopsis "Library used by xapi to herd stunnel processes")
+  (description "This library allows xapi to configure, launch and terminate stunnel processes that act as clients and servers.")
+  (depends
+    astring
+    (forkexec (= :version))
+    (safe-resources (= :version))
+    (uuid (= :version))
+    (xapi-consts (= :version))
+    xapi-inventory
+    (xapi-log (= :version))
+    (xapi-stdext-pervasives (= :version))
+    (xapi-stdext-threads (= :version))
+    (xapi-stdext-unix (= :version))
+    (odoc :with-doc)
+  )
 )
 
 (package

ocaml/database/block_device_io.ml

@@ -184,7 +184,7 @@ let get_pointer half =
 (* Lay out a blank double-buffered redo log on the given block device. *)
 (* May raise Unixext.Timeout exception *)
 let initialise_redo_log block_dev_fd target_response_time =
-  ignore_int (Unixext.seek_to block_dev_fd 0) ;
+  ignore (Unixext.seek_to block_dev_fd 0 : int) ;
   Unixext.time_limited_write_substring block_dev_fd magic_size magic
     target_response_time ;
   Unixext.time_limited_write_substring block_dev_fd 2 "\0000"
@@ -221,7 +221,7 @@ let open_block_device block_dev target_response_time =
 
 (* Within the given block device, seek to the position of the validity byte. *)
 let seek_to_validity_byte block_dev_fd =
-  ignore_int (Unixext.seek_to block_dev_fd pos_validity_byte)
+  ignore (Unixext.seek_to block_dev_fd pos_validity_byte : int)
 
 (* Read the validity byte from the given block device. *)
 let read_validity_byte block_dev_fd target_response_time =
@@ -279,14 +279,15 @@ let read_database block_dev_fd target_response_time =
   let db_fn f =
     let prev_pos = Unixext.current_cursor_pos block_dev_fd in
     (* Seek to the position of the database *)
-    ignore_int (Unixext.seek_to block_dev_fd cur_pos) ;
+    ignore (Unixext.seek_to block_dev_fd cur_pos : int) ;
     (* Read 'len' bytes from the block device and send them to the function we were given *)
-    ignore_int (Unixext.read_data_in_string_chunks f ~max_bytes:len block_dev_fd) ;
+    ignore
+      (Unixext.read_data_in_string_chunks f ~max_bytes:len block_dev_fd : int) ;
     (* Seek back to where we were before *)
-    ignore_int (Unixext.seek_to block_dev_fd prev_pos)
+    ignore (Unixext.seek_to block_dev_fd prev_pos : int)
   in
   (* For now, skip over where the database is *)
-  ignore_int (Unixext.seek_rel block_dev_fd len) ;
+  ignore (Unixext.seek_rel block_dev_fd len : int) ;
   (* Read the generation count and marker *)
   let generation_count = Int64.of_string (read generation_size) in
   let marker_end = read marker_size in
@@ -471,7 +472,7 @@ let action_writedb block_dev_fd client datasock target_response_time =
       (* if neither half is valid, use the first half *)
     in
     (* Seek to the start of the chosen half *)
-    ignore_int (Unixext.seek_to block_dev_fd (start_of_half half_to_use)) ;
+    ignore (Unixext.seek_to block_dev_fd (start_of_half half_to_use) : int) ;
     (* Check that we've got enough space for two markers, a length and a generation count. This is the smallest possible size for a db record. *)
     let min_space_needed = (marker_size * 2) + size_size + generation_size in
     let available_space = Db_globs.redo_log_length_of_half in
@@ -487,7 +488,7 @@ let action_writedb block_dev_fd client datasock target_response_time =
     R.debug "Cursor position to which the length will be written is %d"
       pos_to_write_length ;
     (* Seek forwards to the position to write the data *)
-    ignore_int (Unixext.seek_rel block_dev_fd size_size) ;
+    ignore (Unixext.seek_rel block_dev_fd size_size : int) ;
     (* Read the data from the data channel and write this directly into block_dev_fd *)
     let remaining_space =
       Db_globs.redo_log_length_of_half - marker_size - size_size
@@ -523,7 +524,7 @@ let action_writedb block_dev_fd client datasock target_response_time =
       (Bytes.make trample_size '\000')
       target_response_time ;
     (* Seek backwards in the block device to where the length is supposed to go and write it *)
-    ignore_int (Unixext.seek_to block_dev_fd pos_to_write_length) ;
+    ignore (Unixext.seek_to block_dev_fd pos_to_write_length : int) ;
     let total_length_str = Printf.sprintf "%016d" total_length in
     Unixext.time_limited_write_substring block_dev_fd size_size total_length_str
       target_response_time ;
@@ -680,7 +681,7 @@ let action_read block_dev_fd client datasock target_response_time =
     (* the log is empty *)
 
     (* Seek to the start of the chosen half *)
-    ignore_int (Unixext.seek_to block_dev_fd (start_of_half half_to_use)) ;
+    ignore (Unixext.seek_to block_dev_fd (start_of_half half_to_use) : int) ;
     (* Attempt to read a database record *)
     let length, db_fn, generation_count, marker =
       read_database block_dev_fd target_response_time
@@ -783,7 +784,7 @@ let _ =
         (fun half ->
           Printf.printf "*** [Half %s] Entering half.\n" (half_to_string half) ;
           (* Seek to the start of the chosen half *)
-          ignore_int (Unixext.seek_to block_dev_fd (start_of_half half)) ;
+          ignore (Unixext.seek_to block_dev_fd (start_of_half half) : int) ;
           (* Attempt to read a database record *)
           try
             let length, db_fn, generation_count, marker =

ocaml/libs/stunnel/stunnel.ml

@@ -16,7 +16,6 @@
 module D = Debug.Make (struct let name = "stunnel" end)
 
 open Printf
-open Xapi_stdext_pervasives.Pervasiveext
 open Xapi_stdext_unix
 open Safe_resources
 
@@ -87,8 +86,8 @@ module Unsafe = struct
       try
         pre_exec () ;
         (* CA-18955: xapi now runs with priority -3. We then set his sons priority to 0. *)
-        ignore_int (Unix.nice (-Unix.nice 0)) ;
-        ignore_int (Unix.setsid ()) ;
+        ignore (Unix.nice (-Unix.nice 0) : int) ;
+        ignore (Unix.setsid () : int) ;
         match env with
         | None ->
             Unix.execv argv0 args

ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml

@@ -42,28 +42,3 @@ let finally fct clean_f =
 
 (** execute fct ignoring exceptions *)
 let ignore_exn fct = try fct () with _ -> ()
-
-(* non polymorphic ignore function *)
-let ignore_int v =
-  let (_ : int) = v in
-  ()
-
-let ignore_int64 v =
-  let (_ : int64) = v in
-  ()
-
-let ignore_int32 v =
-  let (_ : int32) = v in
-  ()
-
-let ignore_string v =
-  let (_ : string) = v in
-  ()
-
-let ignore_float v =
-  let (_ : float) = v in
-  ()
-
-let ignore_bool v =
-  let (_ : bool) = v in
-  ()

ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.mli

@@ -17,15 +17,3 @@ val finally : (unit -> 'a) -> (unit -> unit) -> 'a
     [g ()] even if [f ()] throws an exception. *)
 
 val ignore_exn : (unit -> unit) -> unit
-
-val ignore_int : int -> unit
-
-val ignore_int32 : int32 -> unit
-
-val ignore_int64 : int64 -> unit
-
-val ignore_string : string -> unit
-
-val ignore_float : float -> unit
-
-val ignore_bool : bool -> unit

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml

@@ -219,7 +219,7 @@ let copy_file_internal ?limit reader writer =
     let num = reader buffer 0 (Int64.to_int requested) in
     let num64 = Int64.of_int num in
     limit := Option.map (fun x -> Int64.sub x num64) !limit ;
-    ignore_int (writer buffer 0 num) ;
+    ignore (writer buffer 0 num : int) ;
     total_bytes := Int64.add !total_bytes num64 ;
     finished := num = 0 || !limit = Some 0L
   done ;

ocaml/rrd2csv/src/rrd2csv.ml

@@ -655,7 +655,6 @@ let _ =
      R2.2. Ability to specify period of sampling on the command-line (in seconds)
   *)
   let user_filters, sampling_period, show_name, show_uuid =
-    let open Xapi_stdext_pervasives.Pervasiveext in
     (* R2.1.1. If none are specified, assume that all enabled data-sources are of
        interest *)
     let ds = ref [] and s = ref None and n = ref false and u = ref false in
@@ -690,15 +689,15 @@ let _ =
         ; ( "-help"
           , Arg.Unit
               (fun () ->
-                ignore_int (Sys.command "man -M /opt/xensource/man rrd2csv") ;
+                ignore (Sys.command "man -M /opt/xensource/man rrd2csv" : int) ;
                 exit 0
               )
           , " display help"
           )
         ; ( "--help"
           , Arg.Unit
               (fun () ->
-                ignore_int (Sys.command "man -M /opt/xensource/man rrd2csv") ;
+                ignore (Sys.command "man -M /opt/xensource/man rrd2csv" : int) ;
                 exit 0
               )
           , " display help"

ocaml/xapi/repository_helpers.ml

@@ -242,8 +242,7 @@ let get_remote_pool_coordinator_ip url =
       raise Api_errors.(Server_error (invalid_base_url, [url]))
 
 let assert_remote_pool_url_is_valid ~url =
-  get_remote_pool_coordinator_ip url
-  |> Xapi_stdext_pervasives.Pervasiveext.ignore_string
+  ignore (get_remote_pool_coordinator_ip url : string)
 
 let with_pool_repositories f =
   Xapi_stdext_pervasives.Pervasiveext.finally

ocaml/xapi/xapi_host.ml

@@ -1970,8 +1970,7 @@ let attach_static_vdis ~__context ~host:_ ~vdi_reason_map =
       && v.Static_vdis_list.currently_attached
     in
     if not (List.exists check static_vdis) then
-      Pervasiveext.ignore_string
-        (Static_vdis.permanent_vdi_attach ~__context ~vdi ~reason)
+      ignore (Static_vdis.permanent_vdi_attach ~__context ~vdi ~reason : string)
   in
   List.iter attach vdi_reason_map
 

ocaml/xapi/xapi_vdi_helpers.ml

@@ -261,27 +261,27 @@ module VDI_CStruct = struct
 end
 
 let write_raw ~__context ~vdi ~text =
-  if String.length text >= VDI_CStruct.(vdi_size - vdi_format_length) then (
-    let error_msg =
-      Printf.sprintf "Cannot write %d bytes to raw VDI. Capacity = %d bytes"
-        (String.length text)
-        VDI_CStruct.(vdi_size - vdi_format_length)
-    in
-    ignore (failwith error_msg) ;
-    Helpers.call_api_functions ~__context (fun rpc session_id ->
-        Sm_fs_ops.with_open_block_attached_device __context rpc session_id vdi
-          `RW (fun fd ->
-            let contents = Unixext.really_read_string fd VDI_CStruct.vdi_size in
-            let cstruct = Cstruct.of_string contents in
-            if VDI_CStruct.get_magic_number cstruct <> VDI_CStruct.magic_number
-            then
-              VDI_CStruct.format cstruct ;
-            VDI_CStruct.write cstruct text (String.length text) ;
-            Unix.ftruncate fd 0 ;
-            Unixext.seek_to fd 0 |> ignore ;
-            Unixext.really_write_string fd (VDI_CStruct.read cstruct)
-        )
-    )
+  ( if String.length text >= VDI_CStruct.(vdi_size - vdi_format_length) then
+      let error_msg =
+        Printf.sprintf "Cannot write %d bytes to raw VDI. Capacity = %d bytes"
+          (String.length text)
+          VDI_CStruct.(vdi_size - vdi_format_length)
+      in
+      failwith error_msg
+  ) ;
+  Helpers.call_api_functions ~__context (fun rpc session_id ->
+      Sm_fs_ops.with_open_block_attached_device __context rpc session_id vdi `RW
+        (fun fd ->
+          let contents = Unixext.really_read_string fd VDI_CStruct.vdi_size in
+          let cstruct = Cstruct.of_string contents in
+          if VDI_CStruct.get_magic_number cstruct <> VDI_CStruct.magic_number
+          then
+            VDI_CStruct.format cstruct ;
+          VDI_CStruct.write cstruct text (String.length text) ;
+          Unix.ftruncate fd 0 ;
+          ignore (Unixext.seek_to fd 0 : int) ;
+          Unixext.really_write_string fd (VDI_CStruct.read cstruct)
+      )
   )
 
 let read_raw ~__context ~vdi =

ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml

@@ -109,7 +109,7 @@ let start (xmlrpc_path, http_fwd_path) process =
             |> Http.Request.t_of_rpc
           in
           req.Http.Request.close <- true ;
-          ignore_bool (Http_svr.handle_one server received_fd () req)
+          ignore (Http_svr.handle_one server received_fd () req : bool)
         )
         (fun _ -> Unix.close received_fd)
   ) ;

stunnel.opam

@@ -1,33 +1,39 @@
 # This file is generated by dune, edit dune-project instead
-license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception"
 opam-version: "2.0"
-maintainer: "[email protected]"
-authors: "[email protected]"
+synopsis: "Library used by xapi to herd stunnel processes"
+description:
+  "This library allows xapi to configure, launch and terminate stunnel processes that act as clients and servers."
+maintainer: ["Xapi project maintainers"]
+authors: ["[email protected]"]
+license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception"
 homepage: "https://xapi-project.github.io/"
-bug-reports: "https://github.com/xapi-project/xen-api.git"
-dev-repo: "git+https://github.com/xapi-project/xen-api.git"
-build: [[ "dune" "build" "-p" name "-j" jobs ]]
-
-available: [ os = "linux" ]
+bug-reports: "https://github.com/xapi-project/xen-api/issues"
 depends: [
-  "ocaml"
   "dune" {>= "3.15"}
   "astring"
-  "forkexec"
-  "safe-resources"
-  "uuid"
-  "xapi-consts"
-  "xapi-log"
+  "forkexec" {= version}
+  "safe-resources" {= version}
+  "uuid" {= version}
+  "xapi-consts" {= version}
   "xapi-inventory"
-  "xapi-stdext-pervasives"
-  "xapi-stdext-threads"
-  "xapi-stdext-unix"
+  "xapi-log" {= version}
+  "xapi-stdext-pervasives" {= version}
+  "xapi-stdext-threads" {= version}
+  "xapi-stdext-unix" {= version}
+  "odoc" {with-doc}
 ]
-synopsis: "Library required by xapi"
-description: """
-These libraries are provided for backwards compatibility only.
-No new code should use these libraries."""
-url {
-  src:
-    "https://github.com/xapi-project/xen-api/archive/master.tar.gz"
-}
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/xapi-project/xen-api.git"