1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
open Lwt.Infix
open Astring
module Digests = Core.Digests
let ( / ) = Filename.concat
let src = Logs.Src.create "irw-hook" ~doc:"Irmin watcher shared code"
module Log = (val Logs.src_log src : Logs.LOG)
let list_files kind dir =
if Sys.file_exists dir && Sys.is_directory dir then
let d = Sys.readdir dir in
let d = Array.to_list d in
let d = List.map (Filename.concat dir) d in
let d = List.filter kind d in
let d = List.sort String.compare d in
Lwt.return d
else Lwt.return_nil
let directories dir =
list_files (fun f -> try Sys.is_directory f with Sys_error _ -> false) dir
let files dir =
list_files
(fun f -> try not (Sys.is_directory f) with Sys_error _ -> false)
dir
let rec_files dir =
let rec aux accu dir =
directories dir >>= fun ds ->
files dir >>= fun fs -> Lwt_list.fold_left_s aux (fs @ accu) ds
in
aux [] dir
let read_file ~prefix f =
try
if (not (Sys.file_exists f)) || Sys.is_directory f then None
else
let r = String.with_range ~first:(String.length prefix) f in
Some (r, Digest.file f)
with ex ->
Log.info (fun fm -> fm "read_file(%s): %a" f Fmt.exn ex);
None
let read_files dir =
rec_files dir >|= fun new_files ->
let prefix = dir / "" in
List.fold_left
(fun acc f ->
match read_file ~prefix f with None -> acc | Some d -> Digests.add d acc)
Digests.empty new_files
type event = [ `Unknown | `File of string ]
let rec poll n ~callback ~wait_for_changes dir files (event : event) =
(match event with
| `Unknown -> read_files dir
| `File f -> (
let prefix = dir / "" in
let short_f = String.with_range ~first:(String.length prefix) f in
let files = Digests.filter (fun (x, _) -> x <> short_f) files in
match read_file ~prefix f with
| None -> Lwt.return files
| Some d -> Lwt.return (Digests.add d files)))
>>= fun new_files ->
Log.debug (fun l ->
l "files=%a new_files=%a" Digests.pp files Digests.pp new_files);
let diff = Digests.sdiff files new_files in
let process () =
if Digests.is_empty diff then Lwt.return_unit
else (
Log.debug (fun f -> f "[%d] polling %s: diff:%a" n dir Digests.pp diff);
let files = Digests.files diff in
Lwt_list.iter_p callback files)
in
process () >>= fun () ->
wait_for_changes () >>= fun event ->
poll n ~callback ~wait_for_changes dir new_files event
let id = ref 0
let v ~wait_for_changes ~dir callback =
let n = !id in
incr id;
read_files dir >|= fun files ->
Core.stoppable (fun () ->
poll n ~callback ~wait_for_changes dir files `Unknown)