watcher.ml (5881B)
1 (* Unison file synchronizer: src/monitoring/windows/watcher.ml *) 2 (* Copyright 2012, 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 LIMITATIONS 20 - we do not detect when a directory below a path is moved; 21 - we do not watch non-existent or non-directory roots 22 23 REMARK 24 ReadDirectoryChangesW fails with ERROR_INVALID_PARAMETER when 25 we are not on a directory, and ERROR_ACCESS_DENIED when the directory 26 is removed. 27 28 Maybe we should ignore Unison temporary files 29 *) 30 31 let (>>=) = Lwt.bind 32 33 module StringMap = Watchercommon.StringMap 34 35 type watch_def = { mutable handle : Lwt_win.directory_handle option } 36 37 module M = Watchercommon.F (struct type watch = watch_def end) 38 include M 39 40 (****) 41 42 module Windows = struct 43 44 let print_event (nm, act) = 45 Format.eprintf "%s %d@." nm (Obj.magic act : int) 46 47 let event_kind (_, act) = 48 match act with 49 Lwt_win.FILE_ACTION_ADDED -> `CREAT 50 | Lwt_win.FILE_ACTION_MODIFIED -> `MODIF 51 | Lwt_win.FILE_ACTION_RENAMED_NEW_NAME -> `MOVED 52 | Lwt_win.FILE_ACTION_REMOVED 53 | Lwt_win.FILE_ACTION_RENAMED_OLD_NAME -> `DEL 54 55 let rec follow_win_path dir path pos = 56 try 57 let i = String.index_from path pos '\\' in 58 let nm = String.sub path pos (i - pos) in 59 try 60 let dir = StringMap.find nm (get_subdirs dir) in 61 follow_win_path dir path (i + 1) 62 with Not_found -> 63 if !Watchercommon.debug then 64 Format.eprintf "Ignored directory %s in path %s@." nm path; 65 None 66 with Not_found -> 67 Some (dir, Some (String.sub path pos (String.length path - pos))) 68 69 let rec follow_win_path_parent root dir path pos = 70 try 71 let i = String.index_from path pos '\\' in 72 let nm = String.sub path pos (i - pos) in 73 let getn nm = 74 let dir = StringMap.find nm (get_subdirs dir) in 75 follow_win_path_parent (root ^ "\\" ^ nm) dir path (i + 1) 76 in 77 try getn nm with Not_found -> getn (Lwt_win.longpathname root nm) 78 with Not_found -> 79 Some (dir, None) 80 81 let get_win_path root dir ((ev_path, act) as ev) = 82 (* Blindly expand the event path to long names form. If event path 83 is not found among the watched paths then try to find the nearest 84 parent directory and report a modification on it. MSDN states the 85 following: "If there is both a short and long name for the file, 86 [Lwt_win.readdirectorychanges] will return one of these names, 87 but it is unspecified which one." *) 88 let p = if event_kind ev = `DEL then None else 89 follow_win_path dir (Lwt_win.longpathname root ev_path) 0 in 90 match p with 91 | Some _ -> (p, ev) 92 | None -> 93 (* If path is not found or event is a deletion then look up the 94 parent directory and report a modification on it. It is not 95 possible to expand the name of the deleted file or directory 96 (it doesn't exist). *) 97 (follow_win_path_parent root dir ev_path 0, 98 (ev_path, Lwt_win.FILE_ACTION_MODIFIED)) 99 100 let previous_event = ref None 101 102 let clear_event_memory () = previous_event := None 103 104 let flags = 105 Lwt_win.([FILE_NOTIFY_CHANGE_FILE_NAME; FILE_NOTIFY_CHANGE_DIR_NAME; 106 FILE_NOTIFY_CHANGE_ATTRIBUTES; (*FILE_NOTIFY_CHANGE_SIZE;*) 107 FILE_NOTIFY_CHANGE_LAST_WRITE; FILE_NOTIFY_CHANGE_CREATION; 108 (*FILE_NOTIFY_CHANGE_SECURITY*)]) 109 110 let watch_root_directory path dir = 111 let h = Lwt_win.open_directory path in 112 let path = Lwt_win.longpathname "" path in 113 let rec loop () = 114 Lwt_win.readdirectorychanges h true flags >>= fun l -> 115 let time = Unix.gettimeofday () in 116 List.iter 117 (fun ev -> 118 if !previous_event <> Some ev then begin 119 previous_event := Some ev; 120 if !Watchercommon.debug then print_event ev; 121 let pathnm, ev = get_win_path path dir ev in 122 match pathnm with 123 None -> 124 () 125 | Some (subdir, nm) -> 126 let kind = event_kind ev in 127 signal_change time subdir nm kind 128 end) 129 l; 130 if l = [] && get_watch dir <> None then begin 131 if !Watchercommon.debug then Format.eprintf "OVERFLOW@."; 132 signal_overflow () 133 end; 134 if get_watch dir <> None then loop () 135 else Lwt.return () 136 in 137 ignore (Lwt.catch loop 138 (fun e -> 139 set_watch dir None; 140 begin try Lwt_win.close_dir h with Unix.Unix_error _ -> () end; 141 if !Watchercommon.debug then 142 Format.eprintf "Error while reading directory changes: %s@." 143 (Watchercommon.format_exc e); Lwt.return ())); 144 h 145 146 let add_watch path file _ = 147 if get_watch file = None then begin 148 let watch_info = { handle = None } in 149 set_watch file (Some watch_info); 150 if is_root file then 151 try 152 watch_info.handle <- Some (watch_root_directory path file) 153 with Unix.Unix_error _ as e -> 154 Watchercommon.error 155 (Format.sprintf 156 "Error while starting to watch for changes: %s@." 157 (Watchercommon.format_exc e)) 158 end 159 160 let release_watch file = 161 match get_watch file with 162 Some {handle = Some h} -> 163 set_watch file None; 164 begin try Lwt_win.close_dir h with Unix.Unix_error _ -> () end 165 | _ -> 166 set_watch file None 167 168 let watch () = () (* No global loop under Windows... *) 169 170 end 171 172 (****) 173 174 include F(Windows)