xenvm: Use ocaml-flock in preference to linking in core

This is a significant saving in footprint for the CLI:

Before this patch:

    $ ls -lh _build/xenvm/xenvm.native
    -rwxr-xr-x 1 root root 14M Nov  6 14:15 _build/xenvm/xenvm.native

After this patch:

    $ ls -lh _build/xenvm/xenvm.native
    -rwxr-xr-x 1 root root 4.8M Nov  6 14:15 _build/xenvm/xenvm.native

Expecting this to reduce the build time significantly too since building core
is a bear for the CI.

Signed-off-by: Si Beaumont <[email protected]>

Author: simonjbeaumont

_oasis

@@ -20,7 +20,7 @@ Library xenvmidl
   Path:               idl
   Findlibname:        xenvmidl
   Modules:            Xenvm_interface, Xenvm_client, Log, Result, Errors, ResizeRequest, ResizeResponse, Pidfile, Retrymapper
-  BuildDepends:       rpclib, rpclib.syntax, sexplib, sexplib.syntax, lvm, cohttp.lwt, threads, mirage-block-unix, devmapper, core, mirage-clock-unix
+  BuildDepends:       rpclib, rpclib.syntax, sexplib, sexplib.syntax, lvm, cohttp.lwt, threads, mirage-block-unix, devmapper, mirage-clock-unix
 
 Executable "xenvmd"
   ByteOpt:            -warn-error +a
@@ -40,7 +40,7 @@ Executable "xenvm"
   MainIs:             xenvm.ml
   Custom:             true
   Install:            false
-  BuildDepends:       lwt, lwt.unix, lvm, cmdliner, xenvmidl, devmapper, lvm.mapper, io-page.unix, mirage-clock-unix, sexplib.syntax, stringext
+  BuildDepends:       lwt, lwt.unix, lvm, cmdliner, xenvmidl, devmapper, lvm.mapper, io-page.unix, mirage-clock-unix, sexplib.syntax, stringext, flock
 
 Executable "xenvm-local-allocator"
   ByteOpt:            -warn-error +a

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 3881ba5bc364f876f6da3b99d6fed505)
+# DO NOT EDIT (digest: ee9005e9cd3e685e6bba5947ce145357)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -21,7 +21,6 @@ true: annot, bin_annot
 <idl/xenvmidl.{cma,cmxa}>: oasis_library_xenvmidl_native
 <idl/*.ml{,i,y}>: oasis_library_xenvmidl_native
 <idl/*.ml{,i,y}>: pkg_cohttp.lwt
-<idl/*.ml{,i,y}>: pkg_core
 <idl/*.ml{,i,y}>: pkg_devmapper
 <idl/*.ml{,i,y}>: pkg_lvm
 <idl/*.ml{,i,y}>: pkg_mirage-block-unix
@@ -38,7 +37,6 @@ true: annot, bin_annot
 <xenvmd/*.ml{,i,y}>: oasis_executable_xenvmd_native
 <xenvmd/xenvmd.{native,byte}>: pkg_cmdliner
 <xenvmd/xenvmd.{native,byte}>: pkg_cohttp.lwt
-<xenvmd/xenvmd.{native,byte}>: pkg_core
 <xenvmd/xenvmd.{native,byte}>: pkg_cstruct
 <xenvmd/xenvmd.{native,byte}>: pkg_devmapper
 <xenvmd/xenvmd.{native,byte}>: pkg_io-page
@@ -61,7 +59,6 @@ true: annot, bin_annot
 <xenvmd/xenvmd.{native,byte}>: use_xenvmidl
 <xenvmd/*.ml{,i,y}>: pkg_cmdliner
 <xenvmd/*.ml{,i,y}>: pkg_cohttp.lwt
-<xenvmd/*.ml{,i,y}>: pkg_core
 <xenvmd/*.ml{,i,y}>: pkg_cstruct
 <xenvmd/*.ml{,i,y}>: pkg_devmapper
 <xenvmd/*.ml{,i,y}>: pkg_io-page
@@ -90,8 +87,8 @@ true: annot, bin_annot
 <xenvm/*.ml{,i,y}>: oasis_executable_xenvm_native
 <xenvm/xenvm.{native,byte}>: pkg_cmdliner
 <xenvm/xenvm.{native,byte}>: pkg_cohttp.lwt
-<xenvm/xenvm.{native,byte}>: pkg_core
 <xenvm/xenvm.{native,byte}>: pkg_devmapper
+<xenvm/xenvm.{native,byte}>: pkg_flock
 <xenvm/xenvm.{native,byte}>: pkg_io-page.unix
 <xenvm/xenvm.{native,byte}>: pkg_lvm
 <xenvm/xenvm.{native,byte}>: pkg_lvm.mapper
@@ -108,8 +105,8 @@ true: annot, bin_annot
 <xenvm/xenvm.{native,byte}>: use_xenvmidl
 <xenvm/*.ml{,i,y}>: pkg_cmdliner
 <xenvm/*.ml{,i,y}>: pkg_cohttp.lwt
-<xenvm/*.ml{,i,y}>: pkg_core
 <xenvm/*.ml{,i,y}>: pkg_devmapper
+<xenvm/*.ml{,i,y}>: pkg_flock
 <xenvm/*.ml{,i,y}>: pkg_io-page.unix
 <xenvm/*.ml{,i,y}>: pkg_lvm
 <xenvm/*.ml{,i,y}>: pkg_lvm.mapper
@@ -132,7 +129,6 @@ true: annot, bin_annot
 <xenvm-local-allocator/*.ml{,i,y}>: oasis_executable_xenvm_local_allocator_native
 <xenvm-local-allocator/local_allocator.{native,byte}>: pkg_cmdliner
 <xenvm-local-allocator/local_allocator.{native,byte}>: pkg_cohttp.lwt
-<xenvm-local-allocator/local_allocator.{native,byte}>: pkg_core
 <xenvm-local-allocator/local_allocator.{native,byte}>: pkg_cstruct
 <xenvm-local-allocator/local_allocator.{native,byte}>: pkg_devmapper
 <xenvm-local-allocator/local_allocator.{native,byte}>: pkg_io-page
@@ -153,7 +149,6 @@ true: annot, bin_annot
 <xenvm-local-allocator/local_allocator.{native,byte}>: use_xenvmidl
 <xenvm-local-allocator/*.ml{,i,y}>: pkg_cmdliner
 <xenvm-local-allocator/*.ml{,i,y}>: pkg_cohttp.lwt
-<xenvm-local-allocator/*.ml{,i,y}>: pkg_core
 <xenvm-local-allocator/*.ml{,i,y}>: pkg_cstruct
 <xenvm-local-allocator/*.ml{,i,y}>: pkg_devmapper
 <xenvm-local-allocator/*.ml{,i,y}>: pkg_io-page
@@ -179,7 +174,6 @@ true: annot, bin_annot
 <test/test.{native,byte}>: oasis_executable_test_native
 <test/*.ml{,i,y}>: oasis_executable_test_native
 <test/test.{native,byte}>: pkg_cohttp.lwt
-<test/test.{native,byte}>: pkg_core
 <test/test.{native,byte}>: pkg_devmapper
 <test/test.{native,byte}>: pkg_io-page.unix
 <test/test.{native,byte}>: pkg_lvm
@@ -195,7 +189,6 @@ true: annot, bin_annot
 <test/test.{native,byte}>: pkg_threads
 <test/test.{native,byte}>: use_xenvmidl
 <test/*.ml{,i,y}>: pkg_cohttp.lwt
-<test/*.ml{,i,y}>: pkg_core
 <test/*.ml{,i,y}>: pkg_devmapper
 <test/*.ml{,i,y}>: pkg_io-page.unix
 <test/*.ml{,i,y}>: pkg_lvm

idl/META

@@ -1,9 +1,9 @@
 # OASIS_START
-# DO NOT EDIT (digest: 0a291b806c1d54b924bacb021711794e)
+# DO NOT EDIT (digest: 8bc29dfea892cb47998acdb65583145c)
 version = "0.1"
 description = "LVM-like volume manager supporting thinly provisioned LVs"
 requires =
-"rpclib rpclib.syntax sexplib sexplib.syntax lvm cohttp.lwt threads mirage-block-unix devmapper core mirage-clock-unix"
+"rpclib rpclib.syntax sexplib sexplib.syntax lvm cohttp.lwt threads mirage-block-unix devmapper mirage-clock-unix"
 archive(byte) = "xenvmidl.cma"
 archive(byte, plugin) = "xenvmidl.cma"
 archive(native) = "xenvmidl.cmxa"

idl/flock.ml

@@ -16,7 +16,7 @@ depends: [
   "ounit" {test}
   "cstruct" {>= "0.7.1"}
   "lwt"
-  "core"
+  "flock"
   "shared-block-ring"
   "mirage-block-volume" {>= "0.9.2"}
   "mirage-clock-unix"

opam

@@ -84,7 +84,7 @@ let format config name filenames =
 let with_lvm_lock config vg_name f =
   if config.mock_dm then f () else
     let lock_path = Filename.concat "/run/lock/lvm" ("V_" ^ vg_name ^ ":aux") in
-    Flock.with_flock lock_path f
+    with_flock lock_path f
 
 (* Change the label on the PV and revert it if the function [f] fails *)
 let with_label_change block magic f =

xenvm/xenvm.ml

@@ -28,6 +28,22 @@ let mkdir_rec dir perm =
     mkdir_safe dir perm in
   p_mkdir dir
 
+
+let finally f g = let res = try f () with exn -> g (); raise exn in g (); res
+
+let with_flock path f =
+  let open Flock in
+  mkdir_rec (Filename.dirname path) 0o700;
+  let fd = Unix.(openfile path [O_WRONLY; O_CREAT] 0o644) in
+  let rec try_lock tries =
+    if tries > 0 then
+      if try flock ~nonblocking:true fd LOCK_EX; true with _ -> false then ()
+      else begin Unix.sleep 1; try_lock (tries - 1) end
+    else failwith ("Could not obtain flock: " ^ path)
+  in
+  try_lock 5;
+  finally f (fun () -> flock fd LOCK_UN)
+
 module Time = struct
   type 'a io = 'a Lwt.t
   let sleep = Lwt_unix.sleep