Pass fd to functions in OpamFilename.with_flock*

File locking behaves differently under Windows - if a file is to be
written or read using a lock, then the same fd needs to be used. Alter
the OpamFilename.with_flock functions to pass the fd of the lock file
instead of unit.

Signed-off-by: David Allsopp <david.allsopp@metastack.com>

src/client/opamConfigCommand.ml

@@ -249,7 +249,7 @@ let set var value =
   let root = OpamStateConfig.(!r.root_dir) in
   let switch = OpamStateConfig.get_switch () in
   OpamFilename.with_flock `Lock_write (OpamPath.Switch.lock root switch)
-  @@ fun () ->
+  @@ fun _ ->
   let var = OpamVariable.Full.variable var in
   let config_f = OpamPath.Switch.switch_config root switch in
   let config = OpamFile.Switch_config.read config_f in

src/client/opamSwitchCommand.ml

@@ -471,7 +471,7 @@ let export ?(full=false) filename =
   let root = OpamStateConfig.(!r.root_dir) in
   let export =
     OpamFilename.with_flock `Lock_none (OpamPath.Switch.lock root switch)
-    @@ fun () ->
+    @@ fun _ ->
     let selections = S.safe_read (OpamPath.Switch.selections root switch) in
     let overlays =
       read_overlays (fun nv ->

src/core/opamFilename.ml

@@ -358,20 +358,35 @@ let flock flag ?dontblock file = OpamSystem.flock flag ?dontblock (to_string fil
 let with_flock flag ?dontblock file f =
   let lock = OpamSystem.flock flag ?dontblock (to_string file) in
   try
-    let r = f () in
+    let (fd, ch) =
+      match OpamSystem.get_lock_fd lock with
+      | exception Not_found ->
+        let null =
+          if OpamStd.Sys.(os () = Win32) then
+            "nul"
+          else
+            "/dev/null"
+        in
+        let ch = Pervasives.open_out null in
+        Unix.descr_of_out_channel ch, Some ch
+      | fd ->
+        fd, None
+    in
+    let r = f fd in
     OpamSystem.funlock lock;
+    OpamStd.Option.iter Pervasives.close_out ch;
     r
   with e ->
     OpamStd.Exn.finalise e @@ fun () ->
     OpamSystem.funlock lock
 
 let with_flock_upgrade flag ?dontblock lock f =
-  if OpamSystem.lock_isatleast flag lock then f ()
+  if OpamSystem.lock_isatleast flag lock then f (OpamSystem.get_lock_fd lock)
   else (
     let old_flag = OpamSystem.get_lock_flag lock in
     OpamSystem.flock_update flag ?dontblock lock;
     try
-      let r = f () in
+      let r = f (OpamSystem.get_lock_fd lock) in
       OpamSystem.flock_update old_flag lock;
       r
     with e ->
@@ -382,7 +397,7 @@ let with_flock_upgrade flag ?dontblock lock f =
 let with_flock_write_then_read ?dontblock file write read =
   let lock = OpamSystem.flock `Lock_write ?dontblock (to_string file) in
   try
-    let r = write () in
+    let r = write (OpamSystem.get_lock_fd lock) in
     OpamSystem.flock_update `Lock_read lock;
     let r = read r in
     OpamSystem.funlock lock;

src/core/opamFilename.mli

@@ -240,21 +240,21 @@ val flock: [< OpamSystem.lock_flag ] -> ?dontblock:bool -> t -> OpamSystem.lock
 
 (** Calls [f] while holding a lock file. Ensures the lock is properly released
     on [f] exit. Raises [OpamSystem.Locked] if [dontblock] is set and the lock
-    can't be acquired. *)
+    can't be acquired. [f] is passed the file_descr of the lock. *)
 val with_flock: [< OpamSystem.lock_flag ] -> ?dontblock:bool -> t ->
-  (unit -> 'a) -> 'a
+  (Unix.file_descr -> 'a) -> 'a
 
 (** Calls [f] with the file lock upgraded to at least [flag], then restores the
     previous lock level. Upgrade to [`Lock_write] should never be used in
     blocking mode as it would deadlock. Raises [OpamSystem.Locked] (but keeps
     the lock as is) if [dontblock] is set and the lock can't be upgraded. *)
 val with_flock_upgrade:
-  [< OpamSystem.lock_flag ] -> ?dontblock:bool -> OpamSystem.lock -> (unit -> 'a) -> 'a
+  [< OpamSystem.actual_lock_flag ] -> ?dontblock:bool -> OpamSystem.lock -> (Unix.file_descr -> 'a) -> 'a
 
 (** Runs first function with a write lock on the given file, then releases it to
     a read lock and runs the second function. *)
 val with_flock_write_then_read:
-  ?dontblock:bool -> t -> (unit -> 'a) -> ('a -> 'b) -> 'b
+  ?dontblock:bool -> t -> (Unix.file_descr -> 'a) -> ('a -> 'b) -> 'b
 
 module Op: sig
 

src/core/opamSystem.ml

@@ -693,7 +693,8 @@ let link src dst =
     else
       copy_file src dst
 
-type lock_flag = [ `Lock_none | `Lock_read | `Lock_write ]
+type actual_lock_flag = [ `Lock_read | `Lock_write ]
+type lock_flag = [ `Lock_none | actual_lock_flag ]
 
 type lock = {
   mutable fd: Unix.file_descr option;
@@ -770,6 +771,11 @@ let funlock lock = flock_update `Lock_none lock
 
 let get_lock_flag lock = lock.kind
 
+let get_lock_fd lock =
+  match lock.fd with
+    Some fd -> fd
+  | None -> raise Not_found
+
 let lock_max flag1 flag2 = match flag1, flag2 with
   | `Lock_write, _ | _, `Lock_write -> `Lock_write
   | `Lock_read, _ | _, `Lock_read -> `Lock_read

src/core/opamSystem.mli

@@ -207,7 +207,8 @@ type lock
 
 (** The different kinds of unix advisory locks available (`Lock_none doesn't
     actually lock anything, or even create the lock file) *)
-type lock_flag = [ `Lock_none | `Lock_read | `Lock_write ]
+type actual_lock_flag = [ `Lock_read | `Lock_write ]
+type lock_flag = [ `Lock_none | actual_lock_flag ]
 
 (** Dummy lock *)
 val lock_none: lock
@@ -238,6 +239,9 @@ val lock_isatleast: [< lock_flag ] -> lock -> bool
 (** Returns the current kind of the lock *)
 val get_lock_flag: lock -> lock_flag
 
+(** Returns the underlying fd for the lock or raises Not_found for `No_lock *)
+val get_lock_fd: lock -> Unix.file_descr
+
 (** {2 Misc} *)
 
 (** Apply a patch file in the current directory. Returns the error if the patch

src/state/opamEnv.ml

@@ -500,7 +500,7 @@ let write_dynamic_init_scripts st =
   try
     OpamFilename.with_flock_upgrade `Lock_write ~dontblock:true
       st.switch_global.global_lock
-    @@ fun () ->
+    @@ fun _ ->
     List.iter (write_script st.switch_global.root) [
       variables_sh, string_of_update st `sh updates;
       variables_csh, string_of_update st `csh updates;

src/state/opamFormatUpgrade.ml

@@ -1034,7 +1034,7 @@ let as_necessary global_lock root config =
   in
   try
     OpamFilename.with_flock_upgrade `Lock_write ?dontblock global_lock
-    @@ fun () ->
+    @@ fun _ ->
     if is_dev &&
        Some "yes" =
        OpamConsole.read "Type \"yes\" to perform the update and continue:" ||

src/state/opamGlobalState.ml

@@ -138,7 +138,7 @@ let unlock gt =
 let with_write_lock ?dontblock gt f =
   let ret, gt =
     OpamFilename.with_flock_upgrade `Lock_write ?dontblock gt.global_lock
-    @@ fun () -> f ({ gt with global_lock = gt.global_lock } : rw global_state)
+    @@ fun _ -> f ({ gt with global_lock = gt.global_lock } : rw global_state)
     (* We don't actually change the field value, but this makes restricting the
        phantom lock type possible*)
   in

src/state/opamRepositoryState.ml

@@ -81,7 +81,7 @@ module Cache = struct
   let load root =
     match OpamFilename.opt_file (OpamPath.state_cache root) with
     | Some file ->
-      OpamFilename.with_flock `Lock_read file @@ fun () ->
+      OpamFilename.with_flock `Lock_read file @@ fun _ ->
       marshal_from_file file
     | None -> None
 
@@ -91,7 +91,7 @@ module Cache = struct
     else
     let chrono = OpamConsole.timer () in
     let file = OpamPath.state_cache rt.repos_global.root in
-    OpamFilename.with_flock `Lock_write file @@ fun () ->
+    OpamFilename.with_flock `Lock_write file @@ fun _ ->
     log "Writing the cache of repository metadata to %s ...\n"
       (OpamFilename.prettify file);
     let oc = open_out_bin (OpamFilename.to_string file) in
@@ -201,7 +201,7 @@ let load lock_kind gt =
     make_rt repofiles opams
   | Some (repofiles, opams) ->
     log "Cache found, loading repositories without remote only";
-    OpamFilename.with_flock_upgrade `Lock_read lock @@ fun () ->
+    OpamFilename.with_flock_upgrade `Lock_read lock @@ fun _ ->
     let uncached_repos = OpamRepositoryName.Map.mapi mk_repo uncached in
     let uncached_repofiles = load_repos_definitions uncached_repos in
     let uncached_opams =
@@ -212,7 +212,7 @@ let load lock_kind gt =
       (OpamRepositoryName.Map.union (fun _ x -> x) opams uncached_opams)
   | None ->
     log "No cache found";
-    OpamFilename.with_flock_upgrade `Lock_read lock @@ fun () ->
+    OpamFilename.with_flock_upgrade `Lock_read lock @@ fun _ ->
     let repos = OpamRepositoryName.Map.mapi mk_repo repos_map in
     let rt =
       make_rt
@@ -254,7 +254,7 @@ let unlock rt =
 let with_write_lock ?dontblock rt f =
   let ret, rt =
     OpamFilename.with_flock_upgrade `Lock_write ?dontblock rt.repos_lock
-    @@ fun () -> f ({ rt with repos_lock = rt.repos_lock } : rw repos_state)
+    @@ fun _ -> f ({ rt with repos_lock = rt.repos_lock } : rw repos_state)
     (* We don't actually change the field value, but this makes restricting the
        phantom lock type possible *)
   in

src/state/opamSwitchState.ml

@@ -334,7 +334,7 @@ let unlock st =
 let with_write_lock ?dontblock st f =
   let ret, st =
     OpamFilename.with_flock_upgrade `Lock_write ?dontblock st.switch_lock
-    @@ fun () -> f ({ st with switch_lock = st.switch_lock } : rw switch_state)
+    @@ fun _ -> f ({ st with switch_lock = st.switch_lock } : rw switch_state)
     (* We don't actually change the field value, but this makes restricting the
        phantom lock type possible*)
   in
@@ -797,7 +797,7 @@ let with_ lock ?rt ?(switch=OpamStateConfig.get_switch ()) gt f =
 
 let update_repositories gt update_fun switch =
   OpamFilename.with_flock `Lock_write (OpamPath.Switch.lock gt.root switch)
-  @@ fun () ->
+  @@ fun _ ->
   let conf = load_switch_config gt switch in
   let repos =
     match conf.OpamFile.Switch_config.repos with