├── src ├── backend.polling.ml ├── backend.polling.mli ├── dune ├── backend.fsevents.mli ├── backend.inotify.mli ├── irmin_watcher.ml ├── polling.mli ├── hook.mli ├── polling.ml ├── realpath.c ├── irmin_watcher.mli ├── backend.fsevents.ml ├── hook.ml ├── backend.inotify.ml ├── core.mli └── core.ml ├── .ocp-indent ├── .ocamlformat ├── Makefile ├── .gitignore ├── test ├── dune └── test.ml ├── appveyor.yml ├── LICENSE.md ├── .github └── workflows │ └── test.yml ├── README.md ├── dune-project ├── irmin-watcher.opam └── CHANGES.md /src/backend.polling.ml: -------------------------------------------------------------------------------- 1 | include Polling 2 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never 2 | -------------------------------------------------------------------------------- /src/backend.polling.mli: -------------------------------------------------------------------------------- 1 | include module type of struct 2 | include Polling 3 | end 4 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.18.0 2 | break-infix = fit-or-vertical 3 | parse-docstrings = true 4 | indicate-multiline-delimiters = no 5 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all test clean 2 | 3 | all: 4 | dune build 5 | 6 | test: 7 | dune runtest 8 | 9 | clean: 10 | dune clean 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.install 7 | *.native 8 | *.byte 9 | pkg/META 10 | test/_tags 11 | .merlin 12 | _opam 13 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries alcotest logs.fmt irmin-watcher mtime mtime.clock.os)) 4 | 5 | (rule 6 | (alias runtest) 7 | (deps test.exe) 8 | (action 9 | (run ./test.exe -q --color=always))) 10 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | platform: 2 | - x86 3 | 4 | environment: 5 | CYG_ROOT: "C:\\cygwin" 6 | CYG_BASH: "%CYG_ROOT%\\bin\\bash -lc" 7 | 8 | install: 9 | - appveyor DownloadFile https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/appveyor-opam.sh 10 | - "%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" 11 | 12 | build_script: 13 | - "%CYG_BASH% '${APPVEYOR_BUILD_FOLDER}/appveyor-opam.sh'" 14 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (foreign_stubs 3 | (language c) 4 | (names realpath)) 5 | (name irmin_watcher) 6 | (public_name irmin-watcher) 7 | (libraries 8 | fmt 9 | lwt 10 | logs 11 | astring 12 | (select 13 | backend.ml 14 | from 15 | (cf-lwt fsevents-lwt -> backend.fsevents.ml) 16 | (inotify.lwt -> backend.inotify.ml) 17 | (lwt.unix -> backend.polling.ml)) 18 | (select 19 | backend.mli 20 | from 21 | (cf-lwt fsevents-lwt -> backend.fsevents.mli) 22 | (inotify.lwt -> backend.inotify.mli) 23 | (lwt.unix -> backend.polling.mli)))) 24 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Thomas Gazagnaire 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | - pull_request 5 | - push 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: 13 | - macos-latest 14 | ocaml-version: 15 | - 4.12.0 16 | - 4.11.1 17 | - 4.10.2 18 | - 4.09.1 19 | - 4.08.1 20 | 21 | runs-on: ${{ matrix.os }} 22 | 23 | steps: 24 | - name: Checkout code 25 | uses: actions/checkout@v2 26 | - name: Use OCaml ${{ matrix.ocaml-version }} 27 | uses: avsm/setup-ocaml@v2 28 | with: 29 | ocaml-compiler: ${{ matrix.ocaml-version }} 30 | - run: opam pin add . --no-action 31 | - run: opam install . --deps-only --with-doc --with-test 32 | - run: opam exec -- dune build 33 | - run: opam exec -- dune runtest 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## irmin-watcher — Portable Irmin watch backends using FSevents or Inotify 2 | 3 | %%VERSION%% 4 | 5 | irmin-watcher implements [Irmin's watch hooks][watch] for various OS, 6 | using FSevents in OSX and Inotify on Linux. 7 | 8 | irmin-watcher is distributed under the ISC license. 9 | 10 | [watch]: https://mirage.github.io/irmin/irmin/Irmin/Private/Watch/index.html 11 | 12 | ## Installation 13 | 14 | irmin-watcher can be installed with `opam`: 15 | 16 | opam install irmin-watcher 17 | 18 | If you don't use `opam` consult the [`opam`](irmin-watcher.opam) file for build 19 | instructions. 20 | 21 | ## Documentation 22 | 23 | The documentation and API reference is automatically generated by 24 | `ocamldoc` from the interfaces. It can be consulted [online][doc] 25 | and there is a generated version in the `doc` directory of the 26 | distribution. 27 | 28 | [doc]: https://mirage.github.io/irmin-watcher/ 29 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (name irmin-watcher) 3 | 4 | (generate_opam_files true) 5 | 6 | (source (github mirage/irmin-watcher)) 7 | (license ISC) 8 | (authors "Thomas Gazagnaire") 9 | (maintainers "Thomas Gazagnaire") 10 | (documentation "https://mirage.github.io/irmin-watcher/") 11 | 12 | (package 13 | (name irmin-watcher) 14 | (synopsis "Portable Irmin watch backends using FSevents or Inotify") 15 | (description "irmin-watcher implements [Irmin's watch hooks][watch] for various OS, 16 | using FSevents in macOS and Inotify on Linux. 17 | 18 | irmin-watcher is distributed under the ISC license. 19 | 20 | [watch]: http://mirage.github.io/irmin/irmin/Irmin/Private/Watch/index.html#type-hook 21 | ") 22 | (depends 23 | (ocaml (>= "4.02.0")) 24 | (alcotest :with-test) 25 | (mtime (and :with-test (>= "2.0.0"))) 26 | (inotify (= :os "linux")) 27 | (cf-lwt (>="0.4")) 28 | lwt 29 | logs 30 | fmt 31 | astring 32 | fsevents-lwt 33 | ) 34 | ) 35 | -------------------------------------------------------------------------------- /irmin-watcher.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Portable Irmin watch backends using FSevents or Inotify" 4 | description: """ 5 | irmin-watcher implements [Irmin's watch hooks][watch] for various OS, 6 | using FSevents in macOS and Inotify on Linux. 7 | 8 | irmin-watcher is distributed under the ISC license. 9 | 10 | [watch]: http://mirage.github.io/irmin/irmin/Irmin/Private/Watch/index.html#type-hook 11 | """ 12 | maintainer: ["Thomas Gazagnaire"] 13 | authors: ["Thomas Gazagnaire"] 14 | license: "ISC" 15 | homepage: "https://github.com/mirage/irmin-watcher" 16 | doc: "https://mirage.github.io/irmin-watcher/" 17 | bug-reports: "https://github.com/mirage/irmin-watcher/issues" 18 | depends: [ 19 | "dune" {>= "2.8"} 20 | "ocaml" {>= "4.02.0"} 21 | "alcotest" {with-test} 22 | "mtime" {with-test & >= "2.0.0"} 23 | "inotify" {os = "linux"} 24 | "cf-lwt" {>= "0.4"} 25 | "lwt" 26 | "logs" 27 | "fmt" 28 | "astring" 29 | "fsevents-lwt" 30 | "odoc" {with-doc} 31 | ] 32 | build: [ 33 | ["dune" "subst"] {dev} 34 | [ 35 | "dune" 36 | "build" 37 | "-p" 38 | name 39 | "-j" 40 | jobs 41 | "@install" 42 | "@runtest" {with-test} 43 | "@doc" {with-doc} 44 | ] 45 | ] 46 | dev-repo: "git+https://github.com/mirage/irmin-watcher.git" 47 | -------------------------------------------------------------------------------- /src/backend.fsevents.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** FSevents backend for Irmin watchers. 8 | 9 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%%} homepage}} *) 10 | 11 | val v : Core.t Lazy.t 12 | (** [v id p f] is the hook calling [f] everytime a sub-path of [p] is modified. 13 | Return a function to call to remove the hook. Use the FSevent framework to 14 | be notified on filesystem changes. *) 15 | 16 | val mode : [ `FSEvents ] 17 | 18 | (*--------------------------------------------------------------------------- 19 | Copyright (c) 2016 Thomas Gazagnaire 20 | 21 | Permission to use, copy, modify, and/or distribute this software for any 22 | purpose with or without fee is hereby granted, provided that the above 23 | copyright notice and this permission notice appear in all copies. 24 | 25 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 26 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 27 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 28 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 29 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 30 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 31 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 32 | ---------------------------------------------------------------------------*) 33 | -------------------------------------------------------------------------------- /src/backend.inotify.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** Inotify backend for Irmin watchers. 8 | 9 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%%} homepage}} *) 10 | 11 | val v : Core.t Lazy.t 12 | (** [v id p f] is the hook calling [f] everytime a sub-path of [p] is modified. 13 | Return a function to call to remove the hook. Use inofity to be notified on 14 | filesystem changes. *) 15 | 16 | val mode : [ `Inotify | `Polling ] 17 | (** [mode] is [Inotify] on Linux and [`Polling] on Darwin. *) 18 | 19 | (*--------------------------------------------------------------------------- 20 | Copyright (c) 2016 Thomas Gazagnaire 21 | 22 | Permission to use, copy, modify, and/or distribute this software for any 23 | purpose with or without fee is hereby granted, provided that the above 24 | copyright notice and this permission notice appear in all copies. 25 | 26 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 27 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 28 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 29 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 30 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 31 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 32 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 33 | ---------------------------------------------------------------------------*) 34 | -------------------------------------------------------------------------------- /src/irmin_watcher.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let v = Lazy.force Backend.v 8 | 9 | let mode = (Backend.mode :> [ `FSEvents | `Inotify | `Polling ]) 10 | 11 | let hook = Core.hook v 12 | 13 | type stats = { watchdogs : int; dispatches : int } 14 | 15 | let stats () = 16 | let w = Core.watchdog v in 17 | let d = Core.Watchdog.dispatch w in 18 | { watchdogs = Core.Watchdog.length w; dispatches = Core.Dispatch.length d } 19 | 20 | let set_polling_time f = 21 | match mode with `Polling -> Core.default_polling_time := f | _ -> () 22 | 23 | (*--------------------------------------------------------------------------- 24 | Copyright (c) 2016 Thomas Gazagnaire 25 | 26 | Permission to use, copy, modify, and/or distribute this software for any 27 | purpose with or without fee is hereby granted, provided that the above 28 | copyright notice and this permission notice appear in all copies. 29 | 30 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 31 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 32 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 33 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 34 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 35 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 36 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 37 | ---------------------------------------------------------------------------*) 38 | -------------------------------------------------------------------------------- /src/polling.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** Active polling backend for Irmin watchers. 8 | 9 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%%} homepage}} *) 10 | 11 | open Core 12 | 13 | val with_delay : float -> t 14 | (** [with_delay delay id p f] is the hook calling [f] everytime a sub-path of 15 | [p] is modified. Return a function to call to remove the hook. Active 16 | polling is done every [delay] seconds. *) 17 | 18 | val v : t Lazy.t 19 | (** [v] is [with_delay !default_polling_time]. *) 20 | 21 | val mode : [ `Polling ] 22 | 23 | (*--------------------------------------------------------------------------- 24 | Copyright (c) 2016 Thomas Gazagnaire 25 | 26 | Permission to use, copy, modify, and/or distribute this software for any 27 | purpose with or without fee is hereby granted, provided that the above 28 | copyright notice and this permission notice appear in all copies. 29 | 30 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 31 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 32 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 33 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 34 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 35 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 36 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 37 | ---------------------------------------------------------------------------*) 38 | -------------------------------------------------------------------------------- /src/hook.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** Active polling backend for Irmin watchers. 8 | 9 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%%} homepage}} *) 10 | 11 | open Core 12 | 13 | type event = [ `Unknown | `File of string ] 14 | (** The type for change event. *) 15 | 16 | val v : wait_for_changes:(unit -> event Lwt.t) -> dir:string -> Watchdog.hook 17 | (** [v ~wait_for_changes ~dir] is the watchdog hook using [wait_for_changes] to 18 | detect filesystem updates in the directory [dir]. The polling implemention 19 | just calls [Lwt_unix.sleep]. *) 20 | 21 | (*--------------------------------------------------------------------------- 22 | Copyright (c) 2016 Thomas Gazagnaire 23 | 24 | Permission to use, copy, modify, and/or distribute this software for any 25 | purpose with or without fee is hereby granted, provided that the above 26 | copyright notice and this permission notice appear in all copies. 27 | 28 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 29 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 30 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 31 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 32 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 33 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 34 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 35 | ---------------------------------------------------------------------------*) 36 | -------------------------------------------------------------------------------- /src/polling.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Lwt.Infix 8 | 9 | let src = Logs.Src.create "irw-polling" ~doc:"Irmin watcher using using polling" 10 | 11 | module Log = (val Logs.src_log src : Logs.LOG) 12 | 13 | let listen ~wait_for_changes dir = 14 | Log.info (fun l -> l "Polling mode"); 15 | Hook.v ~wait_for_changes ~dir 16 | 17 | let with_delay delay = 18 | let wait_for_changes () = Lwt_unix.sleep delay >|= fun () -> `Unknown in 19 | Core.create (listen ~wait_for_changes) 20 | 21 | let mode = `Polling 22 | 23 | let v = 24 | let wait_for_changes () = 25 | Lwt_unix.sleep !Core.default_polling_time >|= fun () -> `Unknown 26 | in 27 | lazy (Core.create (listen ~wait_for_changes)) 28 | 29 | (*--------------------------------------------------------------------------- 30 | Copyright (c) 2016 Thomas Gazagnaire 31 | 32 | Permission to use, copy, modify, and/or distribute this software for any 33 | purpose with or without fee is hereby granted, provided that the above 34 | copyright notice and this permission notice appear in all copies. 35 | 36 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 37 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 38 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 39 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 40 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 41 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 42 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 43 | ---------------------------------------------------------------------------*) 44 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### Pending 2 | 3 | - Use _WIN32 and MAX_PATH on Windows to support MSVC (#34, @jonahbeckford) 4 | 5 | ### 0.5.0 (2020-04-30) 6 | 7 | - Switch to GitHub Actions from Travis (#31, @avsm) 8 | - Initialise backends only when needed via a 9 | lazy watcher interface (#31, @samoht @avsm) 10 | - Use fsevents and cf-lwt packages (#31, @avsm) 11 | - Use ocamlformat.0.18.0 (#31, @avsm) 12 | 13 | ### 0.4.1 (2019-07-02) 14 | 15 | - Clearer name for hook logger (@talex5, #21) 16 | - Fix race when scanning directories (@talex5, #21) 17 | - Make listen loop tail-recursive (@talex5, #21) 18 | 19 | ### 0.4.0 (2018-10-08) 20 | 21 | - use dune (#13, @mc10) 22 | - rename `unix_realpath` function name to avoid name clashes (#17, @samoht) 23 | 24 | ### 0.3.0 (2017-06-21) 25 | 26 | - Use jbuilder (#11, @samoht) 27 | 28 | ### 0.2.0 (2016-11-14) 29 | 30 | - Allow to watch non-existing directories (#8, @samoht) 31 | - Expose `Irmin_watches.stats` to get stats about the numbers 32 | of active watchdogs, and callback dispatchers (#7, @samoht) 33 | - When using fsevents/inotify do not scan the whole tree everytime 34 | (#6, @samoht) 35 | - Use realpath(3) on Linux and GetFullPathName on Windows to 36 | normalise the path to watch (#6, @samoht) 37 | - inotify: close the inotify file descriptor when stopping the 38 | watch (#6. @samoht) 39 | - inotify: fix the path of watched events (inotify uses relative 40 | patch, unless fsevents which uses absolute paths) (#6, @samoht) 41 | - fix detection of removed files (#6, @samoht) 42 | 43 | ### 0.1.4 (2016-08-16) 44 | 45 | - Use osx-fsevents > 0.2.0 to avoid an fd leak when starting/stoping 46 | the main watch scheduler. 47 | 48 | ### 0.1.3 (2016-08-15) 49 | 50 | - Fix `uname` runtime checks on Windows 51 | 52 | ### 0.1.2 (2016-08-10) 53 | 54 | - Fix link issue when no inotify/fsevents backends are available 55 | - Use topkg 0.7.8 56 | 57 | ### 0.1.1 (2016-08-09) 58 | 59 | - Fix link issue with the inotify backend 60 | 61 | ### 0.1.0 (2016-08-09) 62 | 63 | - Initial release 64 | -------------------------------------------------------------------------------- /src/realpath.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2009 Anil Madhavapeddy 3 | * Copyright (c) 2016 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | */ 17 | 18 | #ifdef _MSC_VER 19 | /* https://docs.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation */ 20 | #define PATH_MAX MAX_PATH 21 | #else 22 | #include 23 | #endif 24 | #include 25 | #include 26 | 27 | #include 28 | #include 29 | #include 30 | #include 31 | #include 32 | #include 33 | #include 34 | 35 | #ifdef _WIN32 36 | CAMLprim value irmin_watcher_unix_realpath(value path) 37 | { 38 | TCHAR buffer[PATH_MAX]=TEXT(""); 39 | DWORD error = 0; 40 | DWORD retval = 0; 41 | retval = GetFullPathName(String_val(path), PATH_MAX, buffer, NULL); 42 | if (retval == 0) { 43 | error = GetLastError(); 44 | uerror("realpath", path); 45 | }; 46 | return caml_copy_string(buffer); 47 | } 48 | #else 49 | CAMLprim value irmin_watcher_unix_realpath(value path) 50 | { 51 | char buffer[PATH_MAX]; 52 | char *r; 53 | r = realpath(String_val(path), buffer); 54 | if (r == NULL) uerror("realpath", path); 55 | return caml_copy_string(buffer); 56 | } 57 | #endif 58 | -------------------------------------------------------------------------------- /src/irmin_watcher.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** Irmin watchers. 8 | 9 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%%} homepage}} *) 10 | 11 | val v : Core.t 12 | (** [v id p f] is the listen hook calling [f] everytime a sub-path of [p] is 13 | modified. Return a function to call to remove the hook. Default to polling 14 | if no better solution is available. FSevents and Inotify backends are 15 | available. *) 16 | 17 | val mode : [ `FSEvents | `Inotify | `Polling ] 18 | 19 | type stats = { watchdogs : int; dispatches : int } 20 | 21 | val hook : Core.hook 22 | (** [hook t] is an {!Irmin.Watcher} compatible representation of {!v}. *) 23 | 24 | val stats : unit -> stats 25 | (** [stats ()] is a snapshot of [v]'s stats. *) 26 | 27 | val set_polling_time : float -> unit 28 | (** [set_polling_time f] set the polling interval to [f]. Only valid when 29 | [mode = `Polling]. *) 30 | 31 | (*--------------------------------------------------------------------------- 32 | Copyright (c) 2016 Thomas Gazagnaire 33 | 34 | Permission to use, copy, modify, and/or distribute this software for any 35 | purpose with or without fee is hereby granted, provided that the above 36 | copyright notice and this permission notice appear in all copies. 37 | 38 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 39 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 40 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 41 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 42 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 43 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 44 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 45 | ---------------------------------------------------------------------------*) 46 | -------------------------------------------------------------------------------- /src/backend.fsevents.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Lwt.Infix 8 | 9 | let src = Logs.Src.create "irw-fsevents" ~doc:"Irmin watcher using FSevents" 10 | 11 | module Log = (val Logs.src_log src : Logs.LOG) 12 | 13 | let create_flags = Fsevents.CreateFlags.detailed_interactive 14 | 15 | let run_loop_mode = Cf.RunLoop.Mode.Default 16 | 17 | let start_runloop dir = 18 | Log.debug (fun l -> l "start_runloop %s" dir); 19 | let watcher = Fsevents_lwt.create 0. create_flags [ dir ] in 20 | let stream = Fsevents_lwt.stream watcher in 21 | let event_stream = Fsevents_lwt.event_stream watcher in 22 | Cf_lwt.RunLoop.run_thread (fun runloop -> 23 | Fsevents.schedule_with_run_loop event_stream runloop run_loop_mode; 24 | if not (Fsevents.start event_stream) then 25 | prerr_endline "failed to start FSEvents stream") 26 | >|= fun _scheduler -> 27 | (* FIXME: should probably do something with the scheduler *) 28 | let stop_scheduler () = 29 | Fsevents_lwt.flush watcher >|= fun () -> 30 | Fsevents_lwt.stop watcher; 31 | Fsevents_lwt.invalidate watcher; 32 | Fsevents_lwt.release watcher 33 | in 34 | (stream, stop_scheduler) 35 | 36 | let listen stream fn = 37 | let path_of_event { Fsevents_lwt.path; _ } = path in 38 | let iter () = 39 | Lwt_stream.iter_s 40 | (fun e -> 41 | let path = path_of_event e in 42 | Log.debug (fun l -> l "fsevents: %s" path); 43 | fn @@ path) 44 | stream 45 | in 46 | Core.stoppable iter 47 | 48 | (* Note: we use FSevents to detect any change, and we re-read the full 49 | tree on every change (so very similar to active polling, but 50 | blocking on incoming FSevents instead of sleeping). We could 51 | probably do better, but at the moment it is more robust to do so, 52 | to avoid possible duplicated events. *) 53 | let v = 54 | let listen dir f = 55 | Log.info (fun l -> l "FSevents mode"); 56 | let events = ref [] in 57 | let cond = Lwt_condition.create () in 58 | start_runloop dir >>= fun (stream, stop_runloop) -> 59 | let rec wait_for_changes () = 60 | match List.rev !events with 61 | | [] -> Lwt_condition.wait cond >>= wait_for_changes 62 | | h :: t -> 63 | events := List.rev t; 64 | Lwt.return (`File h) 65 | in 66 | let unlisten = 67 | listen stream (fun path -> 68 | events := path :: !events; 69 | Lwt_condition.signal cond (); 70 | Lwt.return_unit) 71 | in 72 | Hook.v ~wait_for_changes ~dir f >|= fun unpoll () -> 73 | stop_runloop () >>= fun () -> 74 | unlisten () >>= fun () -> unpoll () 75 | in 76 | lazy (Core.create listen) 77 | 78 | let mode = `FSEvents 79 | 80 | (*--------------------------------------------------------------------------- 81 | Copyright (c) 2016 Thomas Gazagnaire 82 | 83 | Permission to use, copy, modify, and/or distribute this software for any 84 | purpose with or without fee is hereby granted, provided that the above 85 | copyright notice and this permission notice appear in all copies. 86 | 87 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 88 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 89 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 90 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 91 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 92 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 93 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 94 | ---------------------------------------------------------------------------*) 95 | -------------------------------------------------------------------------------- /src/hook.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Lwt.Infix 8 | open Astring 9 | module Digests = Core.Digests 10 | 11 | let ( / ) = Filename.concat 12 | 13 | let src = Logs.Src.create "irw-hook" ~doc:"Irmin watcher shared code" 14 | 15 | module Log = (val Logs.src_log src : Logs.LOG) 16 | 17 | let list_files kind dir = 18 | if Sys.file_exists dir && Sys.is_directory dir then 19 | let d = Sys.readdir dir in 20 | let d = Array.to_list d in 21 | let d = List.map (Filename.concat dir) d in 22 | let d = List.filter kind d in 23 | let d = List.sort String.compare d in 24 | Lwt.return d 25 | else Lwt.return_nil 26 | 27 | let directories dir = 28 | list_files (fun f -> try Sys.is_directory f with Sys_error _ -> false) dir 29 | 30 | let files dir = 31 | list_files 32 | (fun f -> try not (Sys.is_directory f) with Sys_error _ -> false) 33 | dir 34 | 35 | let rec_files dir = 36 | let rec aux accu dir = 37 | directories dir >>= fun ds -> 38 | files dir >>= fun fs -> Lwt_list.fold_left_s aux (fs @ accu) ds 39 | in 40 | aux [] dir 41 | 42 | let read_file ~prefix f = 43 | try 44 | if (not (Sys.file_exists f)) || Sys.is_directory f then None 45 | else 46 | let r = String.with_range ~first:(String.length prefix) f in 47 | Some (r, Digest.file f) 48 | with ex -> 49 | Log.info (fun fm -> fm "read_file(%s): %a" f Fmt.exn ex); 50 | None 51 | 52 | let read_files dir = 53 | rec_files dir >|= fun new_files -> 54 | let prefix = dir / "" in 55 | List.fold_left 56 | (fun acc f -> 57 | match read_file ~prefix f with None -> acc | Some d -> Digests.add d acc) 58 | Digests.empty new_files 59 | 60 | type event = [ `Unknown | `File of string ] 61 | 62 | let rec poll n ~callback ~wait_for_changes dir files (event : event) = 63 | (match event with 64 | | `Unknown -> read_files dir 65 | | `File f -> ( 66 | let prefix = dir / "" in 67 | let short_f = String.with_range ~first:(String.length prefix) f in 68 | let files = Digests.filter (fun (x, _) -> x <> short_f) files in 69 | match read_file ~prefix f with 70 | | None -> Lwt.return files 71 | | Some d -> Lwt.return (Digests.add d files))) 72 | >>= fun new_files -> 73 | Log.debug (fun l -> 74 | l "files=%a new_files=%a" Digests.pp files Digests.pp new_files); 75 | let diff = Digests.sdiff files new_files in 76 | let process () = 77 | if Digests.is_empty diff then Lwt.return_unit 78 | else ( 79 | Log.debug (fun f -> f "[%d] polling %s: diff:%a" n dir Digests.pp diff); 80 | let files = Digests.files diff in 81 | Lwt_list.iter_p callback files) 82 | in 83 | process () >>= fun () -> 84 | wait_for_changes () >>= fun event -> 85 | poll n ~callback ~wait_for_changes dir new_files event 86 | 87 | let id = ref 0 88 | 89 | let v ~wait_for_changes ~dir callback = 90 | let n = !id in 91 | incr id; 92 | read_files dir >|= fun files -> 93 | Core.stoppable (fun () -> 94 | poll n ~callback ~wait_for_changes dir files `Unknown) 95 | 96 | (*--------------------------------------------------------------------------- 97 | Copyright (c) 2016 Thomas Gazagnaire 98 | 99 | Permission to use, copy, modify, and/or distribute this software for any 100 | purpose with or without fee is hereby granted, provided that the above 101 | copyright notice and this permission notice appear in all copies. 102 | 103 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 104 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 105 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 106 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 107 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 108 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 109 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 110 | ---------------------------------------------------------------------------*) 111 | -------------------------------------------------------------------------------- /src/backend.inotify.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Lwt.Infix 8 | 9 | let src = Logs.Src.create "irw-inotify" ~doc:"Irmin watcher using Inotify" 10 | 11 | module Log = (val Logs.src_log src : Logs.LOG) 12 | 13 | let rec mkdir d = 14 | let perm = 0o0700 in 15 | try Unix.mkdir d perm with 16 | | Unix.Unix_error (Unix.EEXIST, "mkdir", _) -> () 17 | | Unix.Unix_error (Unix.ENOENT, "mkdir", _) -> 18 | mkdir (Filename.dirname d); 19 | Unix.mkdir d perm 20 | 21 | let start_watch dir = 22 | Log.debug (fun l -> l "start_watch %s" dir); 23 | if not (Sys.file_exists dir) then mkdir dir; 24 | Lwt_inotify.create () >>= fun i -> 25 | Lwt_inotify.add_watch i dir 26 | [ Inotify.S_Create; Inotify.S_Modify; Inotify.S_Move; Inotify.S_Delete ] 27 | >|= fun u -> 28 | let stop () = Lwt_inotify.rm_watch i u >>= fun () -> Lwt_inotify.close i in 29 | (i, stop) 30 | 31 | let listen dir i fn = 32 | let event_kinds (_, es, _, _) = es in 33 | let pp_kind = Fmt.of_to_string Inotify.string_of_event_kind in 34 | let path_of_event (_, _, _, p) = 35 | match p with None -> dir | Some p -> Filename.concat dir p 36 | in 37 | let rec iter i = 38 | Lwt.try_bind 39 | (fun () -> 40 | Lwt_inotify.read i >>= fun e -> 41 | let path = path_of_event e in 42 | let es = event_kinds e in 43 | Log.debug (fun l -> l "inotify: %s %a" path Fmt.(Dump.list pp_kind) es); 44 | fn path; 45 | Lwt.return_unit) 46 | (fun () -> iter i) 47 | (function 48 | | Unix.Unix_error (Unix.EBADF, _, _) -> 49 | Lwt.return_unit (* i has just been closed by {!stop} *) 50 | | e -> Lwt.fail e) 51 | in 52 | Core.stoppable (fun () -> iter i) 53 | 54 | (* Note: we use Inotify to detect any change, and we re-read the full 55 | tree on every change (so very similar to active polling, but 56 | blocking on incoming Inotify events instead of sleeping). We could 57 | probably do better, but at the moment it is more robust to do so, 58 | to avoid possible duplicated events. *) 59 | let v = 60 | let listen dir f = 61 | Log.info (fun l -> l "Inotify mode"); 62 | let events = ref [] in 63 | let cond = Lwt_condition.create () in 64 | start_watch dir >>= fun (i, stop_watch) -> 65 | let rec wait_for_changes () = 66 | match List.rev !events with 67 | | [] -> Lwt_condition.wait cond >>= wait_for_changes 68 | | h :: t -> 69 | events := List.rev t; 70 | Lwt.return (`File h) 71 | in 72 | let unlisten = 73 | listen dir i (fun path -> 74 | events := path :: !events; 75 | Lwt_condition.signal cond ()) 76 | in 77 | Hook.v ~wait_for_changes ~dir f >|= fun unpoll () -> 78 | stop_watch () >>= fun () -> 79 | unlisten () >>= fun () -> unpoll () 80 | in 81 | lazy (Core.create listen) 82 | 83 | let mode = `Inotify 84 | 85 | let uname () = 86 | try 87 | let ic = Unix.open_process_in "uname" in 88 | let uname = input_line ic in 89 | let () = close_in ic in 90 | Some uname 91 | with Unix.Unix_error _ -> None 92 | 93 | let is_linux () = Sys.os_type = "Unix" && uname () = Some "Linux" 94 | 95 | type mode = [ `Polling | `Inotify ] 96 | 97 | let mode, v = 98 | if is_linux () then ((mode :> mode), v) else Polling.((mode :> mode), v) 99 | 100 | (*--------------------------------------------------------------------------- 101 | Copyright (c) 2016 Thomas Gazagnaire 102 | 103 | Permission to use, copy, modify, and/or distribute this software for any 104 | purpose with or without fee is hereby granted, provided that the above 105 | copyright notice and this permission notice appear in all copies. 106 | 107 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 108 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 109 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 110 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 111 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 112 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 113 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 114 | ---------------------------------------------------------------------------*) 115 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let ( / ) = Filename.concat 4 | 5 | let tmpdir = Filename.get_temp_dir_name () / "irmin-watcher" 6 | 7 | let clean () = 8 | if Sys.file_exists tmpdir then 9 | let _ = Sys.command (Printf.sprintf "rm -rf '%s'" tmpdir) in 10 | () 11 | 12 | let run f () = 13 | clean (); 14 | Lwt_main.run (f ()) 15 | 16 | let rec mkdir d = 17 | let perm = 0o0700 in 18 | try Unix.mkdir d perm with 19 | | Unix.Unix_error (Unix.EEXIST, "mkdir", _) -> () 20 | | Unix.Unix_error (Unix.ENOENT, "mkdir", _) -> 21 | mkdir (Filename.dirname d); 22 | Unix.mkdir d perm 23 | 24 | let write f d = 25 | let f = tmpdir / f in 26 | mkdir (Filename.dirname f); 27 | let oc = open_out f in 28 | output_string oc d; 29 | close_out oc 30 | 31 | let move a b = Unix.rename (tmpdir / a) (tmpdir / b) 32 | 33 | let remove f = 34 | try Unix.unlink (tmpdir / f) with e -> Alcotest.fail (Printexc.to_string e) 35 | 36 | let poll ~mkdir:m i () = 37 | if m then mkdir tmpdir; 38 | let events = ref [] in 39 | let cond = Lwt_condition.create () in 40 | Irmin_watcher.hook 0 tmpdir (fun e -> 41 | events := e :: !events; 42 | Lwt_condition.broadcast cond (); 43 | Lwt.return_unit) 44 | >>= fun unwatch -> 45 | let reset () = events := [] in 46 | let rec wait ?n () = 47 | match !events with 48 | | [] -> Lwt_condition.wait cond >>= fun () -> wait ?n () 49 | | e -> ( 50 | match n with 51 | | None -> 52 | reset (); 53 | Lwt.return e 54 | | Some n -> 55 | if List.length e < n then Lwt_condition.wait cond >>= wait ~n 56 | else ( 57 | reset (); 58 | Lwt.return e)) 59 | in 60 | 61 | write "foo" ("foo" ^ string_of_int i); 62 | wait () >>= fun events -> 63 | Alcotest.(check (slist string String.compare)) "updte foo" [ "foo" ] events; 64 | 65 | remove "foo"; 66 | wait () >>= fun events -> 67 | Alcotest.(check (slist string String.compare)) "remove foo" [ "foo" ] events; 68 | 69 | write "foo" ("foo" ^ string_of_int i); 70 | wait () >>= fun events -> 71 | Alcotest.(check (slist string String.compare)) "create foo" [ "foo" ] events; 72 | 73 | write "bar" ("bar" ^ string_of_int i); 74 | wait () >>= fun events -> 75 | Alcotest.(check (slist string String.compare)) "create bar" [ "bar" ] events; 76 | 77 | move "bar" "barx"; 78 | wait ~n:2 () >>= fun events -> 79 | Alcotest.(check (slist string String.compare)) 80 | "move bar" [ "bar"; "barx" ] events; 81 | 82 | unwatch () 83 | 84 | let random_letter () = Char.(chr @@ (code 'a' + Random.int 26)) 85 | 86 | let rec random_filename () = 87 | Bytes.init (1 + Random.int 20) (fun _ -> random_letter ()) |> Bytes.to_string 88 | |> fun x -> if x = "foo" || x = "bar" then random_filename () else x 89 | 90 | let random_path n = 91 | let rec aux = function 0 -> [] | n -> random_filename () :: aux (n - 1) in 92 | String.concat "/" (aux (n + 1)) 93 | 94 | let prepare_fs n = 95 | let fs = Array.init n (fun i -> (random_path 4, string_of_int i)) in 96 | Array.iter (fun (k, v) -> write k v) fs 97 | 98 | let random_polls n () = 99 | mkdir tmpdir; 100 | let rec aux = function 101 | | 0 -> Lwt.return_unit 102 | | i -> poll ~mkdir:false i () >>= fun () -> aux (i - 1) 103 | in 104 | prepare_fs n; 105 | match Irmin_watcher.mode with `Polling -> aux 10 | _ -> aux 100 106 | 107 | let polling_tests = 108 | [ 109 | ("enoent", `Quick, run (poll ~mkdir:false 0)); 110 | ("basic", `Quick, run (poll ~mkdir:true 0)); 111 | ("100s", `Quick, run (random_polls 100)); 112 | ("1000s", `Slow, run (random_polls 1000)); 113 | ] 114 | 115 | let mode = 116 | match Irmin_watcher.mode with 117 | | `FSEvents -> "fsevents" 118 | | `Inotify -> "inotify" 119 | | `Polling -> "polling" 120 | 121 | let tests = [ (mode, polling_tests) ] 122 | 123 | let reporter () = 124 | let pad n x = 125 | if String.length x > n then x 126 | else x ^ Astring.String.v ~len:(n - String.length x) (fun _ -> ' ') 127 | in 128 | let report src level ~over k msgf = 129 | let k _ = 130 | over (); 131 | k () 132 | in 133 | let ppf = match level with Logs.App -> Fmt.stdout | _ -> Fmt.stderr in 134 | let with_stamp h _tags k fmt = 135 | let dt = Mtime.Span.to_float_ns (Mtime_clock.elapsed ()) in 136 | Fmt.kpf k ppf 137 | ("%+04.0fus %a %a @[" ^^ fmt ^^ "@]@.") 138 | dt 139 | Fmt.(styled `Magenta string) 140 | (pad 10 @@ Logs.Src.name src) 141 | Logs_fmt.pp_header (level, h) 142 | in 143 | msgf @@ fun ?header ?tags fmt -> with_stamp header tags k fmt 144 | in 145 | { Logs.report } 146 | 147 | let () = 148 | Logs.set_level (Some Logs.Debug); 149 | Logs.set_reporter (reporter ()); 150 | Irmin_watcher.set_polling_time 0.1; 151 | Alcotest.run "irmin-watch" tests 152 | -------------------------------------------------------------------------------- /src/core.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** Core functions for Irmin watchers. 8 | 9 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%%} homepage}} *) 10 | 11 | (** Sets of filenames and their digests. *) 12 | module Digests : sig 13 | include Set.S with type elt = string * Digest.t 14 | 15 | val pp_elt : elt Fmt.t 16 | (** [pp_elt] is the pretty-printing function for digest elements. *) 17 | 18 | val pp : t Fmt.t 19 | (** [pp] is the pretty-printer for digest sets. *) 20 | 21 | val sdiff : t -> t -> t 22 | (** [sdiff x y] is [union (diff x y) (diff y x)]. *) 23 | 24 | val files : t -> string list 25 | (** [files t] is the list of files whose digest is stored in [t]. *) 26 | end 27 | 28 | (** Dispatch listening functions. *) 29 | module Dispatch : sig 30 | type t 31 | (** The type for callback dispatches. *) 32 | 33 | val empty : unit -> t 34 | (** [create ()] is the empty dispatch table. *) 35 | 36 | val clear : t -> unit 37 | (** [clear t] clears the contents of the dispatch table [t]. All previous 38 | callbacks are discarded. *) 39 | 40 | val stats : t -> dir:string -> int 41 | (** [stats t ~dir] is the number of active callbacks registered for the 42 | directory [dir]. *) 43 | 44 | val apply : t -> dir:string -> file:string -> unit Lwt.t 45 | (** [apply t ~dir ~file] calls [f file] for every callback [f] registered for 46 | the directory [dir]. *) 47 | 48 | val add : t -> id:int -> dir:string -> (string -> unit Lwt.t) -> unit 49 | (** [add t ~id ~dir f] adds a new callback [f] to the directory [dir], using 50 | the unique identifier [id]. *) 51 | 52 | val remove : t -> id:int -> dir:string -> unit 53 | (** [remove t ~id ~dir] removes the callback with ID [id] on the directory 54 | [dir]. *) 55 | 56 | val length : t -> int 57 | (** [length t] is [t]'s length. *) 58 | end 59 | 60 | (** Watchdog functions. Ensure that only one background process is monitoring 61 | events for a given directory. *) 62 | module Watchdog : sig 63 | type t 64 | (** The type for filesystem watchdogs. *) 65 | 66 | val dispatch : t -> Dispatch.t 67 | (** [dispath t] is the table of [t]'s callback dispatch. *) 68 | 69 | type hook = (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t 70 | (** The type for watchdog hook. *) 71 | 72 | val empty : unit -> t 73 | (** [empty ()] is the empty watchdog, monitoring no directory. *) 74 | 75 | val clear : t -> unit Lwt.t 76 | (** [clear ()] stops all the currently active watchdogs. *) 77 | 78 | val start : t -> dir:string -> hook -> unit Lwt.t 79 | (** [start t ~dir h] adds a new callback hook on the directory [dir], starting 80 | a new watchdog if needed otherwise re-using the previous one. *) 81 | 82 | val stop : t -> dir:string -> unit Lwt.t 83 | (** [stop t ~dir] stops the filesystem watchdog on directory [dir] (if any). *) 84 | 85 | val length : t -> int 86 | (** [length t] is the number of watchdog threads. *) 87 | end 88 | 89 | type hook = 90 | int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t 91 | (** The type for Irmin.Watch hooks. *) 92 | 93 | type t 94 | (** The type for listeners. *) 95 | 96 | val create : (string -> Watchdog.hook) -> t 97 | (** [create h] is the Irmin watcher using the update hook [h]. *) 98 | 99 | val watchdog : t -> Watchdog.t 100 | (** [watchdog t] is [t]'s watchdog. *) 101 | 102 | val hook : t -> hook 103 | (** [hook t] is [t]'s hook. *) 104 | 105 | (** {1 Helpers} *) 106 | 107 | val stoppable : (unit -> unit Lwt.t) -> unit -> unit Lwt.t 108 | (** [stoppable t] is a function [f] such that calling [f] will cancel the thread 109 | [t]. *) 110 | 111 | val default_polling_time : float ref 112 | 113 | (*--------------------------------------------------------------------------- 114 | Copyright (c) 2016 Thomas Gazagnaire 115 | 116 | Permission to use, copy, modify, and/or distribute this software for any 117 | purpose with or without fee is hereby granted, provided that the above 118 | copyright notice and this permission notice appear in all copies. 119 | 120 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 121 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 122 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 123 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 124 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 125 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 126 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 127 | ---------------------------------------------------------------------------*) 128 | -------------------------------------------------------------------------------- /src/core.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Thomas Gazagnaire. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | open Astring 8 | open Lwt.Infix 9 | 10 | let src = Logs.Src.create "irmin-watcher" ~doc:"Irmin watcher logging" 11 | 12 | module Log = (val Logs.src_log src : Logs.LOG) 13 | 14 | (* run [t] and returns an handler to stop the task. *) 15 | let stoppable t = 16 | let s, u = Lwt.task () in 17 | Lwt.async (fun () -> Lwt.pick [ s; t () ]); 18 | function 19 | | () -> 20 | Lwt.wakeup u (); 21 | Lwt.return_unit 22 | 23 | external unix_realpath : string -> string = "irmin_watcher_unix_realpath" 24 | 25 | let realpath dir = 26 | let ( / ) x y = match y with None -> x | Some y -> Filename.concat x y in 27 | let rec aux dir file = 28 | try unix_realpath dir / file 29 | with Unix.Unix_error (Unix.ENOENT, _, _) -> 30 | let file = Filename.basename dir / file in 31 | aux (Filename.dirname dir) (Some file) 32 | in 33 | aux dir None 34 | 35 | module Digests = struct 36 | include Set.Make (struct 37 | type t = string * Digest.t 38 | 39 | let compare = compare 40 | end) 41 | 42 | let of_list l = List.fold_left (fun set elt -> add elt set) empty l 43 | 44 | let sdiff x y = union (diff x y) (diff y x) 45 | 46 | let digest_pp ppf d = Fmt.string ppf @@ Digest.to_hex d 47 | 48 | let pp_elt = Fmt.(Dump.pair string digest_pp) 49 | 50 | let pp ppf t = Fmt.(Dump.list pp_elt) ppf @@ elements t 51 | 52 | let files t = 53 | elements t |> List.map fst |> String.Set.of_list |> String.Set.elements 54 | end 55 | 56 | module Dispatch = struct 57 | type t = (string, (int * (string -> unit Lwt.t)) list) Hashtbl.t 58 | 59 | let empty () : t = Hashtbl.create 10 60 | 61 | let clear t = Hashtbl.clear t 62 | 63 | let stats t ~dir = try List.length (Hashtbl.find t dir) with Not_found -> 0 64 | 65 | (* call all the callbacks on the file *) 66 | let apply t ~dir ~file = 67 | let fns = try Hashtbl.find t dir with Not_found -> [] in 68 | Lwt_list.iter_p 69 | (fun (id, f) -> 70 | Log.debug (fun f -> f "callback %d" id); 71 | f file) 72 | fns 73 | 74 | let add t ~id ~dir fn = 75 | let fns = try Hashtbl.find t dir with Not_found -> [] in 76 | let fns = (id, fn) :: fns in 77 | Hashtbl.replace t dir fns 78 | 79 | let remove t ~id ~dir = 80 | let fns = try Hashtbl.find t dir with Not_found -> [] in 81 | let fns = List.filter (fun (x, _) -> x <> id) fns in 82 | if fns = [] then Hashtbl.remove t dir else Hashtbl.replace t dir fns 83 | 84 | let length t = Hashtbl.fold (fun _ v acc -> acc + List.length v) t 0 85 | end 86 | 87 | module Watchdog = struct 88 | type t = { t : (string, unit -> unit Lwt.t) Hashtbl.t; d : Dispatch.t } 89 | 90 | let length t = Hashtbl.length t.t 91 | 92 | let dispatch t = t.d 93 | 94 | type hook = (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t 95 | 96 | let empty () : t = { t = Hashtbl.create 10; d = Dispatch.empty () } 97 | 98 | let clear { t; d } = 99 | Hashtbl.fold (fun _dir stop acc -> acc >>= stop) t Lwt.return_unit 100 | >|= fun () -> 101 | Hashtbl.clear t; 102 | Dispatch.clear d 103 | 104 | let watchdog t dir = try Some (Hashtbl.find t dir) with Not_found -> None 105 | 106 | let start { t; d } ~dir listen = 107 | match watchdog t dir with 108 | | Some _ -> 109 | assert (Dispatch.stats d ~dir <> 0); 110 | Lwt.return_unit 111 | | None -> ( 112 | (* Note: multiple threads can wait here *) 113 | listen (fun file -> Dispatch.apply d ~dir ~file) 114 | >>= fun u -> 115 | match watchdog t dir with 116 | | Some _ -> 117 | (* Note: someone else won the race, cancel our own thread 118 | to avoid avoid having too many wathdogs for [dir]. *) 119 | u () 120 | | None -> 121 | Log.debug (fun f -> f "Start watchdog for %s" dir); 122 | Hashtbl.add t dir u; 123 | Lwt.return_unit) 124 | 125 | let stop { t; d } ~dir = 126 | match watchdog t dir with 127 | | None -> 128 | assert (Dispatch.stats d ~dir = 0); 129 | Lwt.return_unit 130 | | Some stop -> 131 | if Dispatch.stats d ~dir <> 0 then ( 132 | Log.debug (fun f -> f "Active allback are registered for %s" dir); 133 | Lwt.return_unit) 134 | else ( 135 | Log.debug (fun f -> f "Stop watchdog for %s" dir); 136 | Hashtbl.remove t dir; 137 | stop ()) 138 | end 139 | 140 | type hook = 141 | int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t 142 | 143 | type t = { 144 | mutable listen : int -> string -> (string -> unit Lwt.t) -> unit Lwt.t; 145 | mutable stop : unit -> unit Lwt.t; 146 | watchdog : Watchdog.t; 147 | } 148 | 149 | let watchdog t = t.watchdog 150 | 151 | let hook t id dir f = t.listen id dir f >|= fun () -> t.stop 152 | 153 | let create listen = 154 | let watchdog = Watchdog.empty () in 155 | let t = 156 | { 157 | listen = (fun _ _ _ -> Lwt.return_unit); 158 | stop = (fun _ -> Lwt.return_unit); 159 | watchdog; 160 | } 161 | in 162 | let listen id dir fn = 163 | let dir = realpath dir in 164 | let d = Watchdog.dispatch watchdog in 165 | Dispatch.add d ~id ~dir fn; 166 | Watchdog.start watchdog ~dir (listen dir) >|= fun () -> 167 | let stop () = 168 | Dispatch.remove d ~id ~dir; 169 | Watchdog.stop watchdog ~dir 170 | in 171 | t.stop <- stop 172 | in 173 | t.listen <- listen; 174 | t 175 | 176 | let default_polling_time = ref 1. 177 | 178 | (*--------------------------------------------------------------------------- 179 | Copyright (c) 2016 Thomas Gazagnaire 180 | 181 | Permission to use, copy, modify, and/or distribute this software for any 182 | purpose with or without fee is hereby granted, provided that the above 183 | copyright notice and this permission notice appear in all copies. 184 | 185 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 186 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 187 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 188 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 189 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 190 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 191 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 192 | ---------------------------------------------------------------------------*) 193 | --------------------------------------------------------------------------------