Prevent ssh process from receiving SIGINT, SIGQUIT

Certain signals can be generated by the terminal based on user input
(for example, Ctrl-C -> SIGINT). The generated signals are sent not just
to the process the user considers to be foreground but to all processes
in the foreground process group. As a consequence, if one process needs
the other(s) to do cleanup before terminating, it's no longer possible.
This happens to Unison when it tries to do cleanup with the remote
server. The ssh process has already died and the remote connection is
broken.

To prevent the ssh process from terminating too early, block some
signals (here, SIGINT and SIGQUIT) before spawning the ssh child
process. Child processes inherit the signal mask and signal settings so
blocking some signals before spawning effectively blocks these signals
for the ssh process (unless it changes the sigmask for itself).

src/remote.ml

@@ -1851,8 +1851,64 @@ let buildShellConnection shell host userOpt portOpt rootName termInteract =
   let (term, termPid) =
     Util.convertUnixErrorsToFatal "starting shell connection" (fun () ->
     match termInteract with
-      None ->
-        (None, System.create_process shellCmd argsarray i1 o2 Unix.stderr)
+    | None ->
+        (* Signals generated by the terminal from user input are sent to all
+           processes in the foreground process group. This means that the ssh
+           child process will receive SIGINT at the same time as Unison and
+           close the connection before Unison has the chance to do cleanup with
+           the remote end. To make matters more complicated, the ssh process
+           must be in the foreground process group because interaction with the
+           user is done via the terminal (not via stdin, stdout) and background
+           processes can't read from the terminal (unless we'd set up a pty
+           like is done for the GUI).
+
+           Don't let these signals reach ssh by blocking them.
+
+           The signals could be ignored instead of being blocked because ssh
+           does not set handlers for SIGINT and SIGQUIT if they've been ignored
+           at startup. But this triggers an error in ssh. The interactive
+           passphrase reading function captures these signals for the purpose
+           of restoring terminal settings (echo). When receiving a signal, and
+           after restoring previous signal handlers, it resends the signal to
+           itself. But now the signal is ignored and instead of terminating,
+           the process will continue running as if passphrase reading function
+           had returned with an empty result.
+
+           Since the ssh process no longer receives the signals generated by
+           user input we have to make sure that it terminates when Unison does.
+           This usually happens due to its stdin and stdout being closed,
+           except for when it is interacting with the user via terminal. To get
+           around that, an [at_exit] handler is registered to send a SIGTERM
+           and SIGKILL to the ssh process.  (Note, for [at_exit] handlers to
+           run, unison process must terminate normally, not be killed. For
+           SIGINT, this means that [Sys.catch_break true] (or an alternative
+           SIGINT handler) must be set before creating the ssh process.) *)
+        let blockSignals sigs f =
+          let (prevMask, ok) =
+            try (Unix.sigprocmask SIG_BLOCK sigs, true)
+            with Invalid_argument _ -> ([], false) in
+          let restoreMask () =
+            if ok then Unix.sigprocmask SIG_SETMASK prevMask |> ignore in
+          try let r = f () in restoreMask (); r
+          with e ->
+            let origbt = Printexc.get_raw_backtrace () in
+            restoreMask ();
+            Printexc.raise_with_backtrace e origbt
+        in
+        let pid = blockSignals [Sys.sigint; Sys.sigquit] (fun () ->
+          System.create_process shellCmd argsarray i1 o2 Unix.stderr) in
+        let end_ssh () =
+          let kill_noerr si = try Unix.kill pid si
+            with Unix.Unix_error _ -> () | Invalid_argument _ -> () in
+          match Unix.waitpid [WNOHANG] pid with
+          | (0, _) ->
+              (* Grace period before killing. Important to give ssh a chance
+                 to restore terminal settings, should that be needed. *)
+              kill_noerr Sys.sigterm; Unix.sleepf 0.01; kill_noerr Sys.sigkill
+          | _ | exception Unix.Unix_error _ -> ()
+        in
+        let () = at_exit end_ssh in
+        (None, pid)
     | Some callBack ->
         Terminal.create_session shellCmd argsarray i1 o2 Unix.stderr)
   in

src/uitext.ml

@@ -1451,6 +1451,7 @@ let rec start interface =
   if interface <> Uicommon.Text then
     Util.msg "This Unison binary only provides the text GUI...\n";
   begin try
+    Sys.catch_break true;
     (* Just to make sure something is there... *)
     setWarnPrinterForInitialization();
     let errorOut s =