Graceful stop in repeat mode - part 2

doc/unison-manual.tex

@@ -1995,7 +1995,22 @@
 monitoring), interrupting with ``Ctrl-C'' or with signal \verb|SIGINT| or
 \verb|SIGTERM| works the same way as described above and will additionally stop
 the continuous process. To stop only the continuous process and let the last
-synchronization complete normally, send signal \verb|SIGUSR2| instead.
+synchronization complete normally, press ``Ctrl-D'' or send signal
+\verb|SIGUSR2| instead.
+Closing the input, receiving an EOF, or receiving a \verb|^D| (0x04) from the
+input terminal or a redirected standard input all have the same effect. EOF is
+not interpreted as a stop request when standard input is redirected from a
+regular file. If the standard input is not open or is not open for reading
+already at Unison startup then it is ignored and only signals can be used to
+send the stop request.
+
+\begin{quote}
+  {\em Tips:} For continuous synchronization the input should not be redirected
+  from any source providing a lot of input (such as an existing regular file
+  larger than a few tens of bytes or a device or a pipe that produces large
+  quantities of data). In such cases, Unison would keep reading all the input
+  looking for the stop condition.
+\end{quote}
 \end{textui}
 
 \SUBSECTION{Exit Code}{exit}

man/unison.1.in

@@ -310,9 +310,25 @@ or
 .Sy SIGTERM
 works the same way as described above and will additionally stop the continuous
 process. To stop only the continuous process and let the last synchronization
-complete normally, send signal
+complete normally, press
+.Sy Ctrl-D
+or send signal
 .Sy SIGUSR2
 instead.
+Closing the input, receiving an EOF, or receiving a
+.Sy ^D
+(0x04) from the input terminal or a redirected standard input all have the same
+effect. EOF is not interpreted as a stop request when standard input is
+redirected from a regular file. If the standard input is not open or is not
+open for reading already at Unison startup then it is ignored and only signals
+can be used to send the stop request.
+.Bd -ragged -offset indent
+Tips: For continuous synchronization the input should not be redirected from
+any source providing a lot of input (such as an existing regular file larger
+than a few tens of bytes or a device or a pipe that produces large quantities
+of data). In such cases, Unison would keep reading all the input looking for
+the stop condition.
+.Ed
 .Sh ENVIRONMENT
 .Bl -tag
 .It Ev UNISON

src/external.ml

@@ -81,7 +81,7 @@ let readChannelsTillEof l =
     l
 
 let runExternalProgram cmd =
-  if Util.osType = `Win32 && not Util.isCygwin then begin
+  if Lwt_unix.impl_platform = `Win32 then begin
     debug (fun()-> Util.msg "Executing external program windows-style\n");
     let c = openProcessIn ("\"" ^ cmd ^ "\"") in
     let log = Util.trimWhitespace (readChannelTillEof c) in

src/lwt/generic/lwt_unix_impl.ml

@@ -13,6 +13,8 @@ therefore have the following limitations:
   time, this could result in a dead-lock.
 - [connect] is blocking
 *)
+let impl_platform = `Generic
+
 let windows_hack = Sys.os_type <> "Unix"
 let recent_ocaml =
   Scanf.sscanf Sys.ocaml_version "%d.%d"
@@ -204,6 +206,8 @@ let wait_read ch =
   inputs := (ch, `Wait res) :: !inputs;
   res
 
+let wait_read' = wait_read
+
 let wait_write ch =
   let res = Lwt.wait () in
   outputs := (ch, `Wait res) :: !outputs;

src/lwt/lwt_unix.mli

@@ -38,6 +38,7 @@ val read : file_descr -> bytes -> int -> int -> int Lwt.t
 val write : file_descr -> bytes -> int -> int -> int Lwt.t
 val write_substring : file_descr -> string -> int -> int -> int Lwt.t
 val wait_read : file_descr -> unit Lwt.t
+val wait_read' : Unix.file_descr -> unit Lwt.t
 val wait_write : file_descr -> unit Lwt.t
 val pipe_in : ?cloexec:bool -> unit -> file_descr * Unix.file_descr
 val pipe_out : ?cloexec:bool -> unit -> Unix.file_descr * file_descr
@@ -55,3 +56,9 @@ type lwt_in_channel
 
 val intern_in_channel : in_channel -> lwt_in_channel
 val input_line : lwt_in_channel -> string Lwt.t
+
+(* Not all functions are implemented on Win32. [impl_platform] indicates
+   which implementation has been built. This value must not be used to
+   detect the OS platform; it's intendend to be used for guarding code
+   which uses functions that are not implemented on Win32. *)
+val impl_platform : [ `Generic | `Win32 ]

src/lwt/win/lwt_unix_impl.ml

@@ -3,6 +3,7 @@
   conditions...
   (we have the first, scan the subsequent ones)
 *)
+let impl_platform = `Win32
 
 let no_overlapped_io = false
 let d = ref false
@@ -335,6 +336,7 @@ if !d then prerr_endline "ACCEPT";
 (****)
 
 let wait_read ch = assert false
+let wait_read' = wait_read
 
 let wait_write ch = assert false
 

src/pty.c

@@ -85,6 +85,59 @@ CAMLprim value c_openpty(value unit) {
 
 #endif
 
+#ifndef _WIN32
+
+#include <unistd.h>    // pgrp
+#include <fcntl.h>
+
+CAMLprim value unsn_getpgrp(value unit)
+{
+  CAMLparam0();
+  CAMLreturn(Val_int(getpgrp()));
+}
+
+CAMLprim value unsn_tcgetpgrp(value fd)
+{
+  CAMLparam1(fd);
+  pid_t pgrp = tcgetpgrp(Int_val(fd));
+  if (pgrp == -1) {
+    caml_uerror("tcgetpgrp", Nothing);
+  }
+  CAMLreturn(Val_int(pgrp));
+}
+
+CAMLprim value unsn_fd_readable(value fd)
+{
+  CAMLparam1(fd);
+  int fl = fcntl(Int_val(fd), F_GETFL);
+  if (fl == -1) {
+    caml_uerror("fcntl", Nothing);
+  }
+  CAMLreturn(Val_bool(!(fl & O_WRONLY)));
+}
+
+#else  // _WIN32
+
+CAMLprim value unsn_getpgrp(value unit)
+{
+  CAMLparam0();
+  CAMLreturn(Val_int(-1));
+}
+
+CAMLprim value unsn_tcgetpgrp(value fd)
+{
+  CAMLparam0();
+  CAMLreturn(Val_int(-1));
+}
+
+CAMLprim value unsn_fd_readable(value fd)
+{
+  CAMLparam0();
+  CAMLreturn(Val_bool(1));
+}
+
+#endif
+
 #ifdef _WIN32
 
 #include <windows.h>

src/strings.ml

@@ -2785,6 +2785,26 @@ let docs =
       \032      cleanup procedures and terminates the process forcibly (similar to\n\
       \032      SIGKILL). Doing so may leave the archives or replicas in an\n\
       \032      inconsistent state or locked.\n\
+      \032      When synchronizing continuously (time interval repeat or with\n\
+      \032      filesystem monitoring), interrupting with \226\128\156Ctrl-C\226\128\157 or with signal\n\
+      \032      SIGINT or SIGTERM works the same way as described above and will\n\
+      \032      additionally stop the continuous process. To stop only the\n\
+      \032      continuous process and let the last synchronization complete\n\
+      \032      normally, press \226\128\156Ctrl-D\226\128\157 or send signal SIGUSR2 instead. Closing\n\
+      \032      the input, receiving an EOF, or receiving a ^D (0x04) from the\n\
+      \032      input terminal or a redirected standard input all have the same\n\
+      \032      effect. EOF is not interpreted as a stop request when standard\n\
+      \032      input is redirected from a regular file. If the standard input is\n\
+      \032      not open or is not open for reading already at Unison startup then\n\
+      \032      it is ignored and only signals can be used to send the stop\n\
+      \032      request.\n\
+      \n\
+      \032    Tips: For continuous synchronization the input should not be\n\
+      \032    redirected from any source providing a lot of input (such as an\n\
+      \032    existing regular file larger than a few tens of bytes or a device or\n\
+      \032    a pipe that produces large quantities of data). In such cases,\n\
+      \032    Unison would keep reading all the input looking for the stop\n\
+      \032    condition.\n\
       \n\
       Exit Code\n\
       \n\

src/uitext.ml

@@ -1248,7 +1248,106 @@ let setupSafeStop () =
     if ok then stopPipe := Some (Lwt_unix.pipe_in ~cloexec:true ()))
   end
 
+(*** Requesting safe termination via stdin ***)
+
+let nonEofStopCond s =
+  String.contains s '\004' (* ^D *)
+
+(* [Unix.select] emulation in Windows does not manage to capture all
+   events (for fds other than sockets/files) if timeout is zero. *)
+let selectTimeout = if Sys.win32 then 0.01 else 0.
+
+let selectStdin () =
+  match Unix.select [Unix.stdin] [] [] selectTimeout with
+  | ([r1], _, _) when r1 ==(*phys*) Unix.stdin -> true
+  | _ -> false
+
+let rec readStdinNoIntr b l =
+  try Unix.read Unix.stdin b 0 l
+  with Unix.Unix_error (EINTR, _, _) -> readStdinNoIntr b l
+
+external fdIsReadable : Unix.file_descr -> bool = "unsn_fd_readable"
+
+let stdinIsatty = Unix.isatty Unix.stdin
+
+let stdinIsRegfile, stdinOkForStopReq =
+  let readingOk = function
+    | { Unix.LargeFile.st_kind = S_REG; st_size; _ } when st_size > 32L -> false
+    | _ -> begin try fdIsReadable Unix.stdin with Unix.Unix_error _ -> true end
+  in
+  let rec notEOF st =
+    if stdinIsatty then true else
+    match selectStdin () with
+    | true ->
+        let l = 32 in
+        let b = Bytes.create l in
+        begin match readStdinNoIntr b l with
+        | 0 -> false
+        | n ->
+            if nonEofStopCond (Bytes.sub_string b 0 n) then requestSafeStop ();
+            true
+        | exception Unix.Unix_error _ -> true
+        end
+    | false -> true
+    | exception Unix.Unix_error (EINTR, _, _) -> notEOF st
+    | exception Unix.Unix_error (EBADF, _, _) -> true
+  in
+  match Unix.LargeFile.fstat Unix.stdin with
+  | { st_kind = S_REG; _ } as st -> true, readingOk st
+  | st -> false, readingOk st && notEOF st
+  | exception Unix.Unix_error _ -> false, false
+
+external getpgrp : unit -> int = "unsn_getpgrp"
+external tcgetpgrp : Unix.file_descr -> int = "unsn_tcgetpgrp"
+
+let isBackgroundProcess () =
+  try
+    stdinIsatty && (getpgrp () <> tcgetpgrp Unix.stdin)
+  with Unix.Unix_error ((EBADF | ENOTTY), _, _) -> false
+
+let ignoreSignal signa f =
+  let prev =
+    try Some (Sys.signal signa Signal_ignore)
+    with Invalid_argument _ | Sys_error _ -> None in
+  let restoreSig () =
+    match prev with
+    | None -> ()
+    | Some prev -> try Sys.set_signal signa prev with Sys_error _ -> ()
+  in
+  try let r = f () in restoreSig (); r
+  with e ->
+    let origbt = Printexc.get_raw_backtrace () in
+    restoreSig ();
+    Printexc.raise_with_backtrace e origbt
+
+let isStdinStopCond n s =
+  (n = 0 && not stdinIsRegfile) (* Assuming terminal_io.c_vmin > 0, this is true EOF *)
+    || nonEofStopCond s
+
+let readStopFromStdin () =
+  let l = 32 in
+  let b = Bytes.create l in
+  let ignoreTtin f = if stdinIsatty then ignoreSignal Sys.sigttin f else f () in
+  try
+    let n = ignoreTtin (fun () -> readStdinNoIntr b l) in
+    isStdinStopCond n (Bytes.sub_string b 0 n)
+  with
+  | Unix.Unix_error ((EAGAIN | EWOULDBLOCK), _, _) -> false
+  | Unix.Unix_error (EIO, _, _) -> false
+  | Unix.Unix_error (EBADF, _, _) -> true
+
+let rec checkStdinStopReq () =
+  if not stdinOkForStopReq || isBackgroundProcess () then () else
+  match selectStdin () with
+  | true ->
+      if readStopFromStdin () then requestSafeStop ()
+      else if not stdinIsRegfile then checkStdinStopReq ()
+  | false -> ()
+  | exception Unix.Unix_error (EINTR, _, _) -> checkStdinStopReq ()
+  | exception Unix.Unix_error (EBADF, _, _) -> ()
+
 let safeStopRequested () =
+  if not (safeStopReqd ()) then checkStdinStopReq ();
   safeStopReqd ()
 
 (*** Sleep interruptible by a termination request ***)
@@ -1260,15 +1359,31 @@ let safeStopWait =
       | None -> Lwt.wait ()
       | Some (i, _) -> Lwt_unix.wait_read i
     in
+    let winFd = ref None in
+    let winReadStdin () =
+      let (b, fd) = match !winFd with Some x -> x | None ->
+        let x = (Bytes.create 32, Lwt_unix.of_unix_file_descr Unix.stdin) in
+        winFd := Some x; x in
+      Lwt_unix.read fd b 0 (Bytes.length b) >>= fun n ->
+      if (isStdinStopCond n (Bytes.sub_string b 0 n)) then
+        requestSafeStop ();
+      Lwt.return ()
+    in
     let readFail = function
       | Unix.Unix_error (EBADF, _, _) -> Lwt.return (requestSafeStop ())
       | e -> Lwt.fail e
     in
     let rec loop () =
+      let waitStdin () =
+        if not stdinOkForStopReq then Lwt.wait ()
+        else if Lwt_unix.impl_platform = `Win32 then winReadStdin ()
+        else Lwt_unix.wait_read' Unix.stdin
+      in
       Lwt.catch
-        (fun () -> readStop) readFail >>= fun () ->
+        (fun () -> Lwt.choose [waitStdin (); readStop]) readFail >>= fun () ->
       if not (safeStopRequested ()) then
-        Lwt_unix.sleep 0.15 >>= loop
+        (if stdinIsRegfile || isBackgroundProcess () then 1. else 0.15)
+        |> Lwt_unix.sleep >>= loop
       else
         Lwt.return ()
     in