fswatch.ml (13982B)
1 (* Unison file synchronizer: src/fswatch.ml *) 2 (* Copyright 1999-2020, Benjamin C. Pierce 3 4 This program is free software: you can redistribute it and/or modify 5 it under the terms of the GNU General Public License as published by 6 the Free Software Foundation, either version 3 of the License, or 7 (at your option) any later version. 8 9 This program is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 GNU General Public License for more details. 13 14 You should have received a copy of the GNU General Public License 15 along with this program. If not, see <http://www.gnu.org/licenses/>. 16 *) 17 18 (* 19 Protocol description 20 ==================== 21 22 The file monitoring process receives commands from stdin and 23 responds to stdout. Commands and responds are single lines composed 24 of an identifier followed by a single space and a space separated 25 list of arguments. Arguments are percent-encoded. At the minimum, 26 spaces and newlines must be escaped. The two processes should accept 27 any other escaped character. 28 29 Unison and the child process starts by indicating the protocol 30 version they support. At the moment, they should just output the 31 line 'VERSION 1'. 32 33 Debugging is enabled by the 'DEBUG' command. 34 35 At any time, the child process can signal an error by sending an 36 "ERROR msg" message. 37 38 When Unison start scanning a part of the replica, it emits command: 39 'START hash fspath path', thus indicating the archive hash (that 40 uniquely determines the replica) the replica's fspath and the path 41 where the scanning process starts. The child process should start 42 monitoring this location, then acknowledge the command by sending an 43 'OK' response. 44 When Unison starts scanning a directory, it emits the command 45 'DIR path1', where 'path1' is relative to the path given by the 46 START command (the location of the directory can be obtained by 47 concatenation of 'fspath', 'path', and 'path1'). The child process 48 should then start monitoring the directory, before sending an 'OK' 49 response. 50 When Unison encounters a followed link, it emits the command 51 'LINK path1'. The child process is expected to start monitoring 52 the link target before replying by 'OK'. 53 Unison signals that it is done scanning the part of the replica 54 described by the START process by emitting the 'DONE' command. The 55 child process should not respond to this command. 56 57 Unison can ask for a list of paths containing changes in a given 58 replica by sending the 'CHANGES hash' command. The child process 59 responds by a sequence of 'RECURSIVE path' responses, followed by a 60 'DONE' response. These paths should be relative to the replica 61 'fspath'. The child process will not have to report this changes any 62 more: it can consider that Unison has taken this information into 63 account once and for all. Thus, it is expected to thereafter report 64 only further changes. 65 66 Unison can wait for changes in a replica by emitting a 'WAIT hash' 67 command. It can watch several replicas by sending a series of these 68 commands. The child process is expected to respond once, by a 69 'CHANGE hash1 ... hash2' response that lists the changed replicas 70 among those included in a 'WAIT' command, when changes are 71 available. It should cancel pending waits when any other command is 72 received. 73 74 Finally, the command 'RESET hash' tells the child process to stop 75 watching the given replica. In particular, it can discard any 76 pending change information for this replica. 77 *) 78 79 let debug = Util.debug "fswatch" 80 let debugverbose = Trace.debug "fswatch+" 81 82 let (>>=) = Lwt.bind 83 84 let rec really_write_substring o s pos len = 85 Lwt_unix.write_substring o s pos len >>= fun l -> 86 if l = len then 87 Lwt.return () 88 else 89 really_write_substring o s (pos + l) (len - l) 90 91 let split_on_space s = 92 try 93 let i = String.index s ' ' in 94 (String.sub s 0 i, 95 String.sub s (i + 1) (String.length s - i - 1)) 96 with Not_found -> 97 (s, "") 98 99 let disallowed_char c = 100 match c with 101 'A'..'Z' | 'a'..'z' | '0'..'9' | '-' | '_' | '.' | '~' 102 | '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&' 103 | '=' | '+' | '$' | ',' | '/' | '?' | '#' | '[' | ']' -> 104 false 105 | _ -> 106 true 107 108 let quote s = 109 let l = String.length s in 110 let n = ref 0 in 111 for i = 0 to l - 1 do if disallowed_char s.[i] then incr n done; 112 if !n = 0 then s else begin 113 let q = Bytes.create (l + 2 * !n) in 114 let j = ref 0 in 115 let hex = "0123456789ABCDEF" in 116 for i = 0 to l - 1 do 117 let c = s.[i] in 118 if disallowed_char s.[i] then begin 119 Bytes.set q !j '%'; 120 Bytes.set q (!j + 1) hex.[Char.code c lsr 4]; 121 Bytes.set q (!j + 2) hex.[Char.code c land 15]; 122 j := !j + 3 123 end else begin 124 Bytes.set q !j c; 125 incr j 126 end 127 done; 128 Bytes.to_string q 129 end 130 131 let unquote s = 132 let l = String.length s in 133 let n = ref 0 in 134 for i = 0 to l - 1 do if s.[i] = '%' then incr n done; 135 if !n = 0 then s else begin 136 let hex_char c = 137 match c with 138 '0'..'9' -> Char.code c - Char.code '0' 139 | 'a'..'f' -> Char.code c - Char.code 'a' + 10 140 | 'A'..'F' -> Char.code c - Char.code 'A' + 10 141 | _ -> invalid_arg "unquote" 142 in 143 let u = Bytes.create (l - 2 * !n) in 144 let j = ref 0 in 145 for i = 0 to l - 2 * !n - 1 do 146 let c = s.[!j] in 147 if c = '%' then begin 148 Bytes.set u i (Char.chr ((hex_char s.[!j + 1]) lsl 4 + hex_char s.[!j + 2])); 149 j := !j + 3 150 end else begin 151 Bytes.set u i c; 152 incr j 153 end 154 done; 155 Bytes.to_string u 156 end 157 158 module Cond = struct 159 type t = unit Lwt.t list ref 160 let make () = ref [] 161 let signal s = 162 let wl = !s in 163 s := []; 164 List.iter (fun w -> Lwt.wakeup w ()) wl 165 let wait s = 166 let t = Lwt.wait () in 167 s := t :: !s; 168 t 169 end 170 171 (****) 172 173 let useWatcher = 174 Prefs.createBool "watch" false 175 ~category:(`Advanced `General) 176 "when set, use a file watcher process to detect changes" 177 "Unison uses a file watcher process, when available, to detect filesystem \ 178 changes; this is used to speed up update detection. Setting this flag to \ 179 false disables the use of this process." 180 181 let printf o fmt = 182 Printf.ksprintf 183 (fun s -> 184 debugverbose (fun () -> Util.msg "<< %s" s); 185 Util.convertUnixErrorsToFatal 186 "sending command to filesystem watcher" 187 (fun () -> Lwt_unix.run (really_write_substring o s 0 (String.length s)))) 188 fmt 189 190 let read_line i = 191 let b = Buffer.create 160 in 192 let buf = Bytes.create 160 in 193 let start = ref 0 in 194 let last = ref 0 in 195 let rec read () = 196 begin 197 if !start = !last then begin 198 Lwt_unix.read i buf 0 160 >>= fun l -> 199 if l = 0 then 200 raise (Util.Fatal "Filesystem watcher died unexpectively"); 201 start := 0; last := l; 202 Lwt.return () 203 end else 204 Lwt.return () 205 end >>= fun () -> 206 try 207 let i = Bytes.index_from buf !start '\n' in 208 if i >= !last then raise Not_found; 209 Buffer.add_subbytes b buf !start (i - !start); 210 start := i + 1; 211 let s = Buffer.contents b in 212 Buffer.clear b; 213 debugverbose (fun() -> Util.msg ">> %s\n" s); 214 Lwt.return s 215 with Not_found -> 216 Buffer.add_subbytes b buf !start (!last - !start); 217 start := 0; last := 0; 218 read () 219 in 220 read 221 222 (****) 223 224 let path = 225 try 226 Str.split (Str.regexp (if Sys.win32 then ";" else ":")) 227 (Sys.getenv "PATH") 228 with Not_found -> 229 [] 230 231 let search_in_path ?(path = path) name = 232 Filename.concat 233 (List.find (fun dir -> 234 let p = Filename.concat dir name in 235 let found = System.file_exists p in 236 debug (fun () -> Util.msg "'%s' ...%s\n" p 237 (match found with true -> "found" | false -> "not found")); 238 found) 239 path) 240 name 241 242 let exec_path = [Sys.executable_name] 243 (* 244 try 245 (* Linux *) 246 [System.fspathFromString (Unix.readlink "/proc/self/exe")] 247 with Unix.Unix_error _ | Invalid_argument _ -> 248 let name = (System.argv ()).(0) in 249 if not (Filename.is_relative name) then 250 [System.fspathFromString name] 251 else if Filename.is_implicit name then 252 try 253 [search_in_path name] 254 with Not_found -> 255 [] 256 else 257 [System.fspathConcat (System.getcwd ()) name] 258 *) 259 260 let exec_dir = List.map Filename.dirname exec_path 261 262 let watcher = 263 lazy 264 (let suffix = if Sys.win32 || Sys.cygwin then ".exe" else "" in 265 debug (fun () -> Util.msg "File monitoring helper program...\n"); 266 (try 267 search_in_path ~path:(exec_dir @ path) 268 ("unison-fsmonitor-" ^ Uutil.myMajorVersion ^ suffix) 269 with Not_found -> 270 search_in_path ~path:(exec_dir @ path) 271 ("unison-fsmonitor" ^ suffix))) 272 273 type 'a exn_option = Value of 'a | Exn of exn | Nothing 274 275 type conn = 276 { output : Lwt_unix.file_descr; 277 pid : int; 278 has_changes : Cond.t; 279 has_line : Cond.t; 280 line_read : Cond.t; 281 mutable last_line : string exn_option } 282 283 let conn = ref None 284 285 let rec reader conn read_line = 286 read_line () >>= fun l -> 287 Cond.signal conn.has_changes; 288 if fst (split_on_space l) = "CHANGES" then begin 289 reader conn read_line 290 end else begin 291 conn.last_line <- Value l; 292 Cond.signal conn.has_line; 293 Cond.wait conn.line_read >>= fun () -> 294 reader conn read_line 295 end 296 297 let safeTerm pid = 298 try ignore (Terminal.safe_waitpid pid) with Unix.Unix_error _ -> () 299 300 let safeClose fd = try Lwt_unix.close fd with Unix.Unix_error _ -> () 301 302 let currentConnection () = 303 match !conn with 304 Some c -> c 305 | None -> raise (Util.Fatal ("File monitoring helper program not running")) 306 307 let closeConnection () = 308 match !conn with 309 | Some c -> conn := None; safeClose c.output; safeTerm c.pid 310 | None -> () 311 312 let connected () = !conn <> None 313 314 let startProcess () = 315 try 316 let w = Lazy.force watcher in 317 let (i1,o1) = Lwt_unix.pipe_out ~cloexec:true () in 318 let (i2,o2) = Lwt_unix.pipe_in ~cloexec:true () in 319 let pid = Util.convertUnixErrorsToFatal "starting filesystem watcher" 320 (fun () -> System.create_process w [|w|] i1 o2 Unix.stderr) in 321 Unix.close i1; Unix.close o2; 322 let c = 323 { output = o1; 324 pid; 325 has_changes = Cond.make (); 326 has_line = Cond.make (); 327 line_read = Cond.make (); 328 last_line = Nothing } 329 in 330 ignore 331 (Lwt.catch (fun () -> reader c (read_line i2)) 332 (fun e -> 333 closeConnection (); safeClose i2; 334 Cond.signal c.has_changes; 335 c.last_line <- Exn e; Cond.signal c.has_line; 336 Lwt.return ())); 337 conn := Some c; 338 true 339 with Not_found -> 340 false 341 342 let emitCmd fmt = 343 let c = currentConnection () in 344 try 345 printf c.output fmt 346 with e -> 347 closeConnection (); 348 raise e 349 350 let rec readLine () = 351 let c = currentConnection () in 352 match c.last_line with 353 Nothing -> Lwt_unix.run (Cond.wait c.has_line); readLine () 354 | Value l -> c.last_line <- Nothing; Cond.signal c.line_read; l 355 | Exn e -> raise e 356 357 let badResponse cmd args expected = 358 closeConnection (); 359 if cmd = "ERROR" then 360 raise (Util.Fatal ("Filesystem watcher error: " ^ (unquote args) ^ "\n\ 361 The watcher can be disabled by setting preference \ 362 'watch' to false")) 363 else 364 raise 365 (Util.Fatal 366 (Format.sprintf 367 "Unexpected response '%s %s' from the filesystem watcher \ 368 (expected %s)" cmd args expected)) 369 370 let readAck () = 371 let (cmd, args) = split_on_space (readLine ()) in 372 if cmd <> "OK" then badResponse cmd args "OK" 373 374 let readVersion () = 375 let (cmd, args) = split_on_space (readLine ()) in 376 if cmd <> "VERSION" then badResponse cmd args "VERSION" 377 378 let exchangeVersions () = 379 let res = startProcess () in 380 if res then begin 381 emitCmd "VERSION 1\n"; 382 debug (fun () -> Util.msg "debugging enabled\n"; emitCmd "DEBUG\n"); 383 readVersion () 384 end; 385 res 386 387 (****) 388 389 type archiveHash = string 390 391 let scanning = ref false 392 let start_path = ref "" 393 394 let relpath path = 395 let s2 = Path.toString path in 396 let l1 = String.length !start_path in 397 let l2 = String.length s2 in 398 if l1 = 0 then begin 399 s2 400 end else if l1 = l2 then begin 401 assert (s2 = !start_path); 402 "" 403 end else begin 404 assert 405 ((l2 >= l1 + 1) && String.sub s2 0 l1 = !start_path && s2.[l1] = '/'); 406 String.sub s2 (l1 + 1) (l2 - l1 - 1) 407 end 408 409 let startScanning hash fspath path = 410 if connected () then begin 411 emitCmd "START %s %s %s\n" 412 (quote hash) 413 (quote (Fspath.toString fspath)) (quote (Path.toString path)); 414 readAck (); 415 scanning := true; 416 start_path := Path.toString path 417 end 418 419 let scanDirectory path = 420 if !scanning then begin 421 emitCmd "DIR %s\n" (quote (relpath path)); 422 readAck () 423 end 424 425 let followLink path = 426 if !scanning then begin 427 emitCmd "LINK %s\n" (quote (relpath path)); 428 readAck () 429 end 430 431 let stopScanning () = 432 if !scanning then begin 433 scanning := false; 434 emitCmd "DONE\n" 435 end 436 437 let start hash = 438 if not (Prefs.read useWatcher) then 439 false 440 else if not (connected ()) then 441 exchangeVersions () 442 else begin 443 emitCmd "RESET %s\n" (quote hash); 444 true 445 end 446 447 let running _ = connected () 448 449 let wait hash = 450 let c = currentConnection () in 451 let res = Cond.wait c.has_changes in 452 emitCmd "WAIT %s\n" (quote hash); 453 res 454 455 (****) 456 457 let rec parseChanges l = 458 let (cmd, args) = split_on_space (readLine ()) in 459 match cmd with 460 "CHANGES" -> 461 parseChanges l 462 | "RECURSIVE" -> 463 parseChanges (Path.fromString (unquote args) :: l) 464 | "DONE" -> 465 List.rev l 466 | other -> 467 badResponse other args "RECURSIVE or DONE" 468 469 let getChanges hash = 470 if connected () then begin 471 emitCmd "CHANGES %s\n" (quote hash); 472 parseChanges [] 473 end else 474 raise (Util.Fatal "No file monitoring helper program found")