xapi_vdi_helpers: actually write raw vdi when possible

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"