Less scanning

.merlin

@@ -1,5 +1,5 @@
-PKG bytes topkg inotify fsevents alcotest lwt fmt logs
-PKG osx-fsevents.lwt inotify.lwt
+PKG bytes topkg inotify alcotest lwt fmt logs
+PKG osx-fsevents.lwt inotify.lwt ocb-stubblr mtime.os
 S src
 S test
 B _build/**

CHANGES.md

@@ -1,3 +1,15 @@
+### 0.2.0
+
+- When using fsevents/inotify do not scan the whole tree everytime
+  (#6, @samoht)
+- Use realpath(3) on Linux and GetFullPathName on Windows to
+  normalise the path to watch (#6, @samoht)
+- inotify: close the inotify file descriptor when stopping the
+  watch (#6. @samoht)
+- inotify: fix the path of watched events (inotify uses relative
+  patch, unless fsevents which uses absolute paths) (#6, @samoht)
+- fix detection of removed files (#6, @samoht)
+
 ### 0.1.4
 
 - Use osx-fsevents > 0.2.0 to avoid an fd leak when starting/stoping

Makefile

@@ -5,7 +5,7 @@ INOTIFY=$(shell opam config var inotify:installed)
 
 all:
 	ocaml pkg/pkg.ml build \
-	  --with-fsevents $(FSEVENTS) --with-inotify $(INOTIFY)
+	  --with-fsevents $(FSEVENTS) --with-inotify $(INOTIFY) --tests true
 
 test:
 	ocaml pkg/pkg.ml build --tests true \

_tags

@@ -1,10 +1,12 @@
 true: bin_annot, safe_string, package(bytes)
 true: warn_error(+1..49), warn(A-4-41-44)
 
-true: package(lwt), package(logs), package(fmt), package(astring)
+true: package(lwt logs fmt astring)
 
 <src> : include
 <src/irmin_watcher_fsevents.*>: package(osx-fsevents.lwt), thread
 <src/irmin_watcher_inotify.*>: package(inotify.lwt)
 
-<test/*>: package(alcotest), package(lwt.unix), package(logs.fmt)
+<src/irmin-watcher-core.cm{,x}a>: link_stubs(src/librealpath)
+
+<test/*>: package(alcotest lwt.unix logs.fmt mtime.os), use_irmin-watcher-core

appveyor.yml

@@ -7,7 +7,7 @@ environment:
 
 install:
   - appveyor DownloadFile https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/appveyor-opam.sh
-  - "%CYG_ROOT%\\setup-x86.exe -qnNdO -R %CYG_ROOT% -s http://cygwin.mirror.constant.com -l C:/cygwin/var/cache/setup -P rsync -P patch -P diffutils -P curl -P make -P unzip -P git -P m4 -P perl -P mingw64-x86_64-gcc-core"
+  - "%CYG_ROOT%\\setup-x86.exe -qnNdO -R %CYG_ROOT% -s http://cygwin.mirror.constant.com -l C:/cygwin/var/cache/setup -P rsync -P patch -P diffutils -P make -P unzip -P git -P m4 -P perl -P mingw64-x86_64-gcc-core"
 
 build_script:
   - "%CYG_BASH% '${APPVEYOR_BUILD_FOLDER}/appveyor-opam.sh'"

myocamlbuild.ml

@@ -19,10 +19,11 @@ let dispatch pkgs =
       let flags = S[A "-pp"; A ("cppo " ^ String.concat " " flags)] in
       flag ([main_file; "ocamldep"] @ tags) flags;
       flag ([main_file; "ocaml"; "compile"] @ tags) flags
-    ) options
+    ) options;
+  flag ["file:src/irmin-watcher-core.cmxs"] (S[A"-I"; A"src"])
 
 let dispatch = function
 | After_rules -> dispatch [ ("fsevents", "FSEVENTS"); ("inotify" , "INOTIFY")]
 | _ -> ()
 
-let () = Ocamlbuild_plugin.dispatch dispatch
+let () = Ocb_stubblr.dispatchv [ Ocb_stubblr.init; dispatch ]

opam

@@ -13,6 +13,8 @@ depends: [
   "topkg"      {build}
   "cppo"       {build}
   "alcotest"   {test}
+  "mtime"      {test}
+  "ocb-stubblr"
   "lwt" "logs" "fmt" "astring"
 ]
 depopts: ["inotify" "osx-fsevents"]

pkg/pkg.ml

@@ -44,8 +44,10 @@ module Build = struct
     let build_dir = Conf.build_dir c in
     let debug = Cmd.(on (Conf.debug c) (v "-tag" % "debug")) in
     OS.Cmd.run @@
-    Cmd.(ocamlbuild % "-use-ocamlfind" % "-classic-display" %% debug %% cppo c %
-         "-build-dir" % build_dir %% of_list files)
+    Cmd.(ocamlbuild % "-use-ocamlfind" % "-classic-display" %% debug
+         %% cppo c (* use cppo *)
+         % "-plugin-tag" % "package(ocb-stubblr)" (* ocb-stubblr plugin *)
+         % "-build-dir" % build_dir %% of_list files)
 
   let clean os ~build_dir =
     OS.Cmd.run @@ Pkg.clean_cmd os ~build_dir >>= fun () ->
@@ -69,10 +71,11 @@ let () =
   let inotify  = Conf.value c inotify in
   Ok [
     Pkg.lib ~built:false "pkg/META";
+    Pkg.clib  "src/librealpath.clib";
     Pkg.mllib "src/irmin-watcher.mllib";
     Pkg.mllib "src/irmin-watcher-core.mllib";
     Pkg.mllib "src/irmin-watcher-polling.mllib";
     Pkg.mllib ~cond:fsevents "src/irmin-watcher-fsevents.mllib";
     Pkg.mllib ~cond:inotify "src/irmin-watcher-inotify.mllib";
-    Pkg.test "test/test";
+    Pkg.test "test/test" ~args:(Cmd.v "-e");
   ]

src/irmin_watcher.ml

@@ -16,17 +16,17 @@ let uname () =
 let _is_linux () =
   Sys.os_type = "Unix" && uname () = Some "Linux"
 
-let hook id dir fn =
+let hook =
 #ifdef HAVE_FSEVENTS
   let _ = uname in
-  Irmin_watcher_fsevents.hook id dir fn
+  Irmin_watcher_fsevents.hook
 #elif defined HAVE_INOTIFY
   if _is_linux () then
-    Irmin_watcher_inotify.hook id dir fn
+    Irmin_watcher_inotify.hook
   else
-    Irmin_watcher_polling.(hook !default_polling_time) id dir fn
+    Irmin_watcher_polling.(hook !default_polling_time)
 #else
-  Irmin_watcher_polling.(hook !default_polling_time) id dir fn
+  Irmin_watcher_polling.(hook !default_polling_time)
 #endif
 
 let mode =

src/irmin_watcher.mli

@@ -8,7 +8,7 @@
 
     {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *)
 
-val hook: Irmin_watcher_core.t
+val hook: Irmin_watcher_core.t Lwt.t
 (** [hook id p f] is the hook calling [f] everytime a sub-path of [p]
     is modified. Return a function to call to remove the hook. Default
     to polling if no better solution is available. FSevents and

src/irmin_watcher_core.ml

@@ -8,18 +8,17 @@ open Astring
 open Lwt.Infix
 
 let src = Logs.Src.create "irmin-watcher" ~doc:"Irmin watcher logging"
-module Logs = (val Logs.src_log src : Logs.LOG)
+module Log = (val Logs.src_log src : Logs.LOG)
 
-type t = int -> string -> (string -> unit Lwt.t) -> (unit -> unit) Lwt.t
+type t = int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t
 
 (* run [t] and returns an handler to stop the task. *)
 let stoppable t =
   let s, u = Lwt.task () in
   Lwt.async (fun () -> Lwt.pick ([s; t ()]));
-  function () -> Lwt.wakeup u ()
+  function () -> Lwt.wakeup u (); Lwt.return_unit
 
-let realdir dir =
-  if Filename.is_relative dir then Filename.concat (Sys.getcwd ()) dir else dir
+external realpath : string -> string = "unix_realpath"
 
 module Digests = struct
   include Set.Make(struct
@@ -29,7 +28,8 @@ module Digests = struct
   let of_list l = List.fold_left (fun set elt -> add elt set) empty l
   let sdiff x y = union (diff x y) (diff y x)
   let digest_pp ppf d = Fmt.string ppf @@ Digest.to_hex d
-  let pp ppf t = Fmt.(Dump.list (Dump.pair string digest_pp)) ppf @@ elements t
+  let pp_elt = Fmt.(Dump.pair string digest_pp)
+  let pp ppf t = Fmt.(Dump.list pp_elt) ppf @@ elements t
   let files t =
     elements t |> List.map fst |> String.Set.of_list |> String.Set.elements
 end
@@ -48,7 +48,7 @@ module Callback = struct
   let apply t ~dir ~file =
     let fns = try Hashtbl.find t dir with Not_found -> [] in
     Lwt_list.iter_p (fun (id, f) ->
-        Logs.debug (fun f -> f "callback %d" id); f file
+        Log.debug (fun f -> f "callback %d" id); f file
       ) fns
 
   let add t ~id ~dir fn =
@@ -67,21 +67,22 @@ end
 module Watchdog = struct
 
   type t = {
-    t: (string, unit -> unit) Hashtbl.t;
+    t: (string, unit -> unit Lwt.t) Hashtbl.t;
     c: Callback.t;
   }
 
   let callback t = t.c
 
-  type hook = (string -> unit Lwt.t) -> (unit -> unit) Lwt.t
+  type hook = (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t
 
   let empty (): t = {
     t = Hashtbl.create 10;
     c = Callback.empty ();
   }
 
   let clear { t; c } =
-    Hashtbl.iter (fun _dir stop -> stop ()) t;
+    Hashtbl.fold (fun _dir stop acc -> acc >>= stop) t Lwt.return_unit
+    >|= fun () ->
     Hashtbl.clear t;
     Callback.clear c
 
@@ -93,38 +94,42 @@ module Watchdog = struct
     | Some _ -> assert (Callback.stats c ~dir <> 0); Lwt.return_unit
     | None   ->
         (* Note: multiple threads can wait here *)
-        listen (fun file -> Callback.apply c ~dir ~file) >|= fun u ->
+        listen (fun file -> Callback.apply c ~dir ~file) >>= fun u ->
         match watchdog t dir with
         | Some _ ->
             (* Note: someone else won the race, cancel our own thread
                to avoid avoid having too many wathdogs for [dir]. *)
             u ()
         | None   ->
-            Logs.debug (fun f -> f "Start watchdog for %s" dir);
-            Hashtbl.add t dir u
+            Log.debug (fun f -> f "Start watchdog for %s" dir);
+            Hashtbl.add t dir u;
+            Lwt.return_unit
 
   let stop { t; c } ~dir =
     match watchdog t dir with
-    | None      -> assert (Callback.stats c ~dir = 0)
+    | None      ->
+        assert (Callback.stats c ~dir = 0);
+        Lwt.return_unit
     | Some stop ->
-        if Callback.stats c ~dir = 0 then (
-          Logs.debug (fun f -> f "Stop watchdog for %s" dir);
+        if Callback.stats c ~dir <> 0 then Lwt.return_unit
+        else (
+          Log.debug (fun f -> f "Stop watchdog for %s" dir);
           Hashtbl.remove t dir;
           stop ()
         )
 end
 
 let create t listen =
-  Watchdog.clear t;
   let listen_dir id dir fn =
-    let dir = realdir dir in
+    let dir = realpath dir in
     let c = Watchdog.callback t in
     Callback.add c ~id ~dir fn;
     Watchdog.start t ~dir (listen dir) >|= fun () ->
     function () ->
       Callback.remove c ~id ~dir;
       Watchdog.stop t ~dir
   in
+  Watchdog.clear t >|= fun () ->
   listen_dir
 
 (*---------------------------------------------------------------------------

src/irmin_watcher_core.mli

@@ -8,7 +8,7 @@
 
     {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *)
 
-type t = int -> string -> (string -> unit Lwt.t) -> (unit -> unit) Lwt.t
+type t = int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t
 (** The type for notifications hooks. A hook [f] is applied by Irmin's
     runtime by calling it with [f id dir fn], where [id] is a unique
     identifier to identify the hook in the debug messages, [dir] is
@@ -19,6 +19,9 @@ type t = int -> string -> (string -> unit Lwt.t) -> (unit -> unit) Lwt.t
 module Digests: sig
   include Set.S with type elt = string * Digest.t
 
+  val pp_elt: elt Fmt.t
+  (** [pp_elt] is the pretty-printing function for digest elements. *)
+
   val pp: t Fmt.t
   (** [pp] is the pretty-printer for digest sets. *)
 
@@ -70,33 +73,33 @@ module Watchdog: sig
   val callback: t -> Callback.t
   (** [callback t] is [t]'s callback table. *)
 
-  type hook = (string -> unit Lwt.t) -> (unit -> unit) Lwt.t
+  type hook = (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t
   (** The type for watchdog hook. *)
 
   val empty: unit -> t
   (** [empty ()] is the empty watchdog, monitoring no directory. *)
 
-  val clear: t -> unit
+  val clear: t -> unit Lwt.t
   (** [clear ()] stops all the currently active watchdogs. *)
 
   val start: t -> dir:string -> hook -> unit Lwt.t
   (** [start t ~dir h] adds a new callback hook on the directory
       [dir], starting a new watchdog if needed otherwise re-using the
       previous one. *)
 
-  val stop: t -> dir:string -> unit
+  val stop: t -> dir:string -> unit Lwt.t
   (** [stop t ~dir] stops the filesystem watchdog on directory [dir]
       (if any). *)
 
 end
 
-val create: Watchdog.t -> (string -> Watchdog.hook) -> t
+val create: Watchdog.t -> (string -> Watchdog.hook) -> t Lwt.t
 (** [create t h] is the Irmin watcher using the watchdogs defined in
     [t] and the update hook [h]. *)
 
 (** {1 Helpers} *)
 
-val stoppable: (unit -> unit Lwt.t) -> (unit -> unit)
+val stoppable: (unit -> unit Lwt.t) -> (unit -> unit Lwt.t)
 (** [stoppable t] is a function [f] such that calling [f] will cancel
     the thread [t]. *)