unison

watcher.ml (13843B)

---

 (* Unison file synchronizer: src/fsmonitor/solaris/watcher.ml *)
 (* Copyright 2021, Tõivo Leedjärv
 
     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU General Public License as published by
     the Free Software Foundation, either version 3 of the License, or
     (at your option) any later version.
 
     This program is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU General Public License for more details.
 
     You should have received a copy of the GNU General Public License
     along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)
 
 (* A brief overview of the File Event Notification (FEN) interface
  *
  * Events are delivered via ports. A port is created by [port_create].
  * Each file or directory to be watched must be individually associated
  * with the port by [port_associate].
  *
  * When associating an object with a port, the stat times of the object
  * can be passed in. During association, the FEN system will compare these
  * times with their current values to detect if there has been a change
  * between the stat() call and the association. If yes, then an event is
  * delivered immediately. If the times have not changed, or they are all
  * passed in as zero, then the next event is monitored and delivered when
  * it occurs.
  *
  * Objects are associated and events monitored per vnode. It is due to this
  * approach that all files must be watched individually. For example, while
  * adding and deleting a file will be detected as a modification event on the
  * parent directory, modifying an existing file within the same directory
  * will not be detected by watching the directory.
  *
  * For each association, only one event is delivered. The object is then
  * automatically dissociated (equivalent of [port_dissociate]) and must
  * be associated again to receive further events.
  *
  * Events are polled and retrieved by [port_get].
  *
  * A port has a limit to the number of objects associated with it. As all
  * files must be watched individually, the number of objects can grow very
  * large. This implementation maintains a pool of ports and automatically
  * creates new ports as needed, and closes ports that are no longer needed.
  *)
 
 let (>>=) = Lwt.bind
 
 let () = Gc.set { (Gc.get()) with space_overhead = 40 }
 
 (****)
 
 type port = int
 
 (* event_objects are allocated in C heap and are not GC'd by OCaml. Care must
  * be taken to free each event_object explicitly and not use them after having
  * been freed.
  *
  * event_objects have released their backing system resources and must be freed
  * with [free_event_object] in the following cases:
  *  - after [port_get] when having received an event and event_object is not
  *    re-associated, and
  *  - after calling [port_dissociate] (exceptions here must be fatal or
  *    ensure that [free_event_object] still gets called).
  *
  * Current implementation builds on the following assumption:
  *  - A Watchercommon watch (= value that keeps track of live event_objects) is
  *    not discarded without explicitly closing it.
  *
  *    All watches are closed explicitly by either [release_watch] or
  *    in [cleanup_watch]. These functions take care of releasing the resources
  *    if needed and freeing the objects properly after they've been released.
  *    This also means that exceptions must be fatal or take care not to discard
  *    event_objects without properly releasing and freeing them.
  *
  * If the above assumption changes or can no longer be guaranteed then the
  * implementation may have to be changed. There are a few ways to make
  * event_objects GC'd. All of these solutions carry a rather high memory
  * overhead as FEN requires each file to be monitored individually.
  *
  * One possible way is to change the type event_object to nativeint and use
  * [Gc.finalise] to attach a [free_event_object] to the returned event_object
  * after every successful [port_associate].
  *
  * The other is to in C stub wrap the event object in a Custom block with
  * [free_event_object] as the finalizer. Ultimately, this could be the safest
  * solution, as in addition to enabling GC on event_objects, it makes it
  * possible to prevent use-after-free by setting the value to NULL after free.
  *)
 
 type event_object = int
 
 let string_of_eo eo = Format.sprintf "%#x" (eo * 2)
 
 type assocs = (event_object, string) Hashtbl.t
 
 type watch_t = (port, assocs) Hashtbl.t * bool
 
 module M = Watchercommon.F (struct type watch = watch_t end)
 include M
 
 (****)
 
 module Solaris = struct
 
 let clear_event_memory () = ()
 
 (****)
 
 type cookie = int
 
 type fen_event =
   | FILE_ACCESS | FILE_MODIFIED | FILE_ATTRIB | FILE_DELETE | FILE_RENAME_TO
   | FILE_RENAME_FROM | FILE_TRUNC | FILE_NOFOLLOW | UNMOUNTED | MOUNTEDOVER
 
 let print_event ev =
   let print_ev ev =
     let s = match ev with
     | FILE_ACCESS -> "FILE_ACCESS"
     | FILE_MODIFIED -> "FILE_MODIFIED"
     | FILE_ATTRIB -> "FILE_ATTRIB"
     | FILE_DELETE -> "FILE_DELETE"
     | FILE_RENAME_TO -> "FILE_RENAME_TO"
     | FILE_RENAME_FROM -> "FILE_RENAME_FROM"
     | FILE_TRUNC -> "FILE_TRUNC"
     | FILE_NOFOLLOW -> "FILE_NOFOLLOW"
     | UNMOUNTED -> "UNMOUNTED"
     | MOUNTEDOVER -> "MOUNTEDOVER"
     in
     Format.eprintf "%s " s
   in
   List.iter print_ev ev;
   Format.eprintf "@."
 
 let event_kind =
   let kind = function
   | FILE_ACCESS -> `OTHER
   | FILE_MODIFIED -> `MODIF
   | FILE_ATTRIB -> `MODIF
   | FILE_DELETE -> `DEL
   | FILE_RENAME_TO -> `CREAT
   | FILE_RENAME_FROM -> `DEL
   | FILE_TRUNC -> `MODIF
   | FILE_NOFOLLOW -> `OTHER
   | UNMOUNTED -> `OTHER
   | MOUNTEDOVER -> `OTHER
   in
   List.fold_left (fun k v -> if k = `OTHER then kind v else k) `OTHER
 
 (****)
 
 external port_create : unit -> port = "unsn_port_create"
 external port_close : port -> unit = "unsn_port_close"
 external port_associate : port -> string -> bool -> cookie -> event_object = "unsn_port_associate"
 external port_reassociate : port -> event_object -> bool -> bool = "unsn_port_reassociate"
 external port_dissociate : port -> event_object -> unit = "unsn_port_dissociate"
 external port_get : port -> (port * event_object * cookie * (fen_event list)) list = "unsn_port_get"
 external free_event_object : event_object -> unit = "unsn_free_event_object"
 
 (****)
 
 let max_ev_per_port = 65000 (* A safe max. The OS limit should be at 64k. *)
      (* The number of ports is limited at 8k per process, so not a worry. *)
 
 let ports = ref []
 
 let allocate_port () =
   let avail_port, _ =
     try
       List.find (fun (_, count) -> count < max_ev_per_port) !ports
     with Not_found ->
       let p = port_create (), 0 in ports := p :: !ports; p
   in
   ports := List.map (fun p' ->
     let port, count = p' in
     if port <> avail_port then
       p'
     else
       port, count + 1
   ) !ports;
   avail_port
 
 let release_port p =
   ports := List.fold_left (fun nl p' ->
     let port, count = p' in
     if p <> port then
       p' :: nl
     else begin
       if count > 1 then
         (port, count - 1) :: nl
       else begin
         let () = port_close port in
         nl
       end
     end
   ) [] !ports
 
 (****)
 
 let is_directory path follow =
   let st = match follow with
   | false -> Unix.lstat path
   | true -> begin
       try
         Unix.stat path
       with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
         Watchercommon.error (Format.sprintf
           "Unable to follow link '%s' because its target is missing" path)
     end
   in
   Unix.S_DIR = st.st_kind
 
 let associate is_child wh id follow absname name =
   if not is_child || not (is_directory absname follow) then begin
     let port = allocate_port () in
     let wh_p = try Hashtbl.find wh port with Not_found ->
       let wh_p = Hashtbl.create (if is_child then 1 else 1024) in
       Hashtbl.add wh port wh_p;
       wh_p
     in
     let eo = port_associate port absname follow id in
     Hashtbl.add wh_p eo name
   end
 
 let add_watch_children path assoc_f =
   let rec loop dir =
     match Unix.readdir dir with
     | exception End_of_file -> ()
     | "." | ".." -> loop dir
     | name ->
         let () = assoc_f name in
         loop dir
   in
   let dir = Unix.opendir path in
   try
     let () = loop dir in
     Unix.closedir dir
   with Unix.Unix_error _ as e ->
     begin try
       Unix.closedir dir
     with Unix.Unix_error _ -> () end;
     raise e
 
 let rec add_watch path file follow =
   match get_watch file with
   | Some (_, follow') when follow = follow' ->
       ()
   | Some _ ->
       release_watch file;
       add_watch path file follow
   | None ->
       let id = get_id file
       and wh = Hashtbl.create 1 in
       let () = set_watch file (Some (wh, follow)) in
       try
         let () = associate false wh id follow path "" in
         if is_directory path follow then add_watch_children path
           (fun nm -> associate true wh id follow (Filename.concat path nm) nm)
       with
       | Unix.Unix_error (ENOENT, _, _) ->
           raise Watchercommon.Already_lost
       | Unix.Unix_error (EACCES, _, _)
       | Unix.Unix_error (ENOTDIR, _, _)
       | Unix.Unix_error (ELOOP, _, _) ->
           (* These are handled well by Unison *)
           ()
       | Unix.Unix_error _ as e ->
           Watchercommon.error
             (Format.sprintf
               "Error while starting to watch for changes: [%s] %s"
               path (Watchercommon.format_exc e))
 
 and release_watch file =
   match get_watch file with
   | None -> ()
   | Some (wh, _) ->
       set_watch file None;
       let unwatch port eo name =
         port_dissociate port eo;
         free_event_object eo;
         release_port port
       in
       Hashtbl.iter (fun port wh_p -> Hashtbl.iter (unwatch port) wh_p) wh
 
 (* Once an event is delivered, the FEN automatically dissociates the object.
  *
  * The object must be re-associated in the following cases:
  *  - It was not requested by [add_watch] but was implicitly added by
  *    [add_watch_children]. In other words, the name is not "".
  *
  * When the object is not to be re-associated or re-association did not
  * succeed then the following must be done:
  *  - The associated port must be released.
  *  - The event object must be freed and then discarded (event object must
  *    no longer be referenced or used in any way).
  *  - The watch must be released completely by calling [release_watch],
  *    even if it was an implicitly added child that failed re-association.
  *
  * Unison and Watchercommon will associate the path again if and when needed.
  *
  * This releasing and associating can potentially be terrible for performance
  * on large directories (with several tens or hundreds of thousands of files)
  * but it is the easiest way to guarantee that all children in a directory are
  * watched.
  *)
 let cleanup_watch file name port eo id ev =
   match get_watch file with
   | None -> ()
   | Some (wh, follow) ->
       let reassoc =
         try
           let wh_p = Hashtbl.find wh port in
           let r =
             match name with
             | "" -> false
             | _ -> port_reassociate port eo follow
           in
           if not r then begin
             Hashtbl.remove wh_p eo;
             free_event_object eo;
             release_port port
           end;
           r
         with Not_found -> false
       in
       if not reassoc then release_watch file
       (* [release_watch] here is safe because even if some events within the
        * watch may not have been processed yet, all event objects in a watch
        * will be dissociated, freed and the entire watch discarded.
        *
        * Dissocating an already dissociated object is a noop.
        *
        * Since the watch is discarded, there will not be any use-after-free
        * or double free possible as event objects are always looked up from
        * a watch before any processing. *)
 
 let process_ev time ((file, name), (port, eo, id, ev)) =
   if !Watchercommon.debug then begin
     Format.eprintf " %i: [%s] %s \"%s\": " port (string_of_eo eo)
       (dir_path file "") name;
     print_event ev
   end;
   let () = cleanup_watch file name port eo id ev in
   let name = match name with
   | "" -> None
   | _ -> Some name
   in
   signal_change time file name (event_kind ev)
 
 (* Always process events on children first and on parents last because
  * the cleanup procedure clears out children together with the parent. *)
 let compare_event e e' =
   match e, e' with
   | ((_, ""), _), ((_, ""), _) -> 0
   | ((_, ""), _), ((_, n), _) -> 1
   | ((_, n), _), ((_, ""), _) -> -1
   | ((_, n), _), ((_, n'), _) -> 0
 
 let process_ev_list ev_list =
   let time = Unix.gettimeofday () in
   let ev_list = List.fold_left
     (fun k ((port, eo, id, _) as o) ->
       try
         let file = Hashtbl.find file_by_id id in
         match get_watch file with
         | None ->
             k
         | Some (wh, _) ->
             let wh_p = Hashtbl.find wh port in
             let name = Hashtbl.find wh_p eo in
             ((file, name), o) :: k
       with Not_found ->
         k
     ) [] ev_list
   in
   let ev_list = List.sort compare_event ev_list in
   List.iter (process_ev time) ev_list
 
 let rec read_events () =
   (* FIXME: List.concat_map is available since OCaml 4.10.0 *)
   let ev_list = List.map (fun (port, _) -> port_get port) !ports in
   let ev_list = Safelist.concat ev_list in
   if List.length ev_list > 0 then
     Lwt_unix.yield () >>= fun () ->
     Lwt.return ev_list
   else
     Lwt_unix.sleep 1.5 >>=
     read_events
 
 let watch () =
   let rec watch_rec () =
     read_events () >>= fun ev_list ->
     let () = process_ev_list ev_list in
     watch_rec ()
   in
   ignore
     (Lwt.catch watch_rec
        (fun e ->
           Watchercommon.error
             ("error while handling events: " ^ Watchercommon.format_exc e)))
 
 end
 
 (****)
 
 include F(Solaris)