Merge pull request xapi-project#62 from jonludlam/vhd-tool-fdatasync

Vhd tool fdatasync

src/channels.ml

@@ -55,14 +55,35 @@ let rec sendfile from_fd to_fd len =
         ) (fun e ->
           Lwt_unix.set_blocking fd false;
           fail e) in
+
+  let sync_limit = Int64.(mul 4L (mul 1024L 1024L)) in
+
+  let write from_fd to_fd to_write =
+    let rec loop remaining =
+      if remaining > 0L then begin
+        _sendfile from_fd to_fd remaining
+        >>= fun written ->
+        loop (Int64.sub remaining written)
+      end else return () in
+    loop to_write >>= fun () ->
+    return to_write
+  in
+
+  let min x y =
+    if Int64.compare x y = -1 then x else y
+  in
+
   with_blocking_fd from_fd
     (fun from_fd ->
       with_blocking_fd to_fd
         (fun to_fd ->
           let rec loop remaining =
             if remaining > 0L then begin
-              _sendfile from_fd to_fd remaining
+              let to_write = min sync_limit remaining in
+              write from_fd to_fd to_write
               >>= fun written ->
+              Lwt_unix.fdatasync to_fd
+              >>= fun () ->
               loop (Int64.sub remaining written)
             end else return () in
           loop len

src/impl.ml

@@ -141,14 +141,6 @@ let create common filename size parent =
   with Failure x ->
     `Error(true, x)
 
-let open_with_creat path rw =
-  ( if not(Sys.file_exists path) then begin
-    Lwt_unix.openfile path [ Unix.O_CREAT; Unix.O_RDONLY ] 0o0644 >>= fun fd ->
-    Lwt_unix.close fd
-    end else return () ) >>= fun () ->
-  Vhd_format_lwt.IO.openfile path rw
-
-
 let check common filename =
   try
     let filename = require "filename" filename in
@@ -690,8 +682,7 @@ let write_stream common s destination source_protocol destination_protocol preze
   let use_ssl = match endpoint with Https _ -> true | _ -> false in
   ( match endpoint with
     | File path ->
-      open_with_creat path true >>= fun fd' ->
-      let fd = Vhd_format_lwt.IO.to_file_descr fd' in
+      Lwt_unix.openfile path [ Unix.O_RDWR; Unix.O_CREAT ] 0o0644 >>= fun fd ->
       Channels.of_seekable_fd fd >>= fun c ->
       return (c, [ NoProtocol; Human; Tar ])
     | Null ->
@@ -992,7 +983,11 @@ let serve common_options source source_fd source_format source_protocol destinat
         | _ -> failwith (Printf.sprintf "Not implemented: serving from source %s" source) ) >>= fun source_sock ->
       ( match destination_endpoint with
         | File path ->
-          open_with_creat path true >>= fun fd ->
+          ( if not(Sys.file_exists path) then begin
+              Lwt_unix.openfile path [ Unix.O_CREAT; Unix.O_RDONLY ] 0o0644 >>= fun fd ->
+              Lwt_unix.close fd
+            end else return () ) >>= fun () ->
+          Vhd_format_lwt.IO.openfile path true >>= fun fd ->
           let size = match destination_size with
             | None -> Vhd_format_lwt.File.get_file_size path
             | Some x -> x in