Merge pull request #810 from tleedjarv/connection-cleanup+new-transpo…

…rt+stop-propagation

Make it possible to stop update propagation by user request

doc/unison-manual.tex

@@ -1963,6 +1963,35 @@
 terminal alone and process input a line at a time.
 \end{itemize}
 
+\SUBSECTION{Interrupting a Synchronization}{intr}
+
+It is possible to interrupt an ongoing synchronization process before it
+completes. Different user interfaces offer different ways of doing it.
+
+\begin{tkui}
+In the graphical user interface the synchronization process can be interrupted
+before it is finished by pressing the ``Stop'' button or by closing the window.
+The ``Stop'' button causes the onging propagation to be stopped as quickly as
+possible while still doing proper cleanup. The application keeps running and a
+rescan can be performed or a different profile selected. Closing the window in
+the middle of update propagation process will exit the application immediately
+without doing proper cleanup; it is therefore not recommended unless the
+``Stop'' button does not react quickly enough.
+\end{tkui}
+
+\begin{textui}
+When not synchronizing continuously, the text interface terminates when
+synchronization is finished normally or due to a fatal error occuring.
+
+In the text interface, to interrupt synchronization before it is finished,
+press ``Ctrl-C'' (or send signal \verb|SIGINT| or \verb|SIGTERM|). This will
+interrupt update propagation as quickly as possible but still complete proper
+cleanup. If the process does not stop even after pressing ``Ctrl-C'' then keep
+doing it repeatedly.  This will bypass cleanup procedures and terminates the
+process forcibly (similar to \verb|SIGKILL|).  Doing so may leave the archives
+or replicas in an inconsistent state or locked.
+\end{textui}
+
 \SUBSECTION{Exit Code}{exit}
 
 When running in the textual mode, Unison returns an exit status, which

man/unison.1.in

@@ -282,6 +282,24 @@ beginning with #; both are ignored.
 .Pp
 When Unison starts, it first reads the profile and then the command line, so
 command-line options will override settings from the profile.
+.Sh TERMINATION
+When not synchronizing continuously, the text interface terminates when
+synchronization is finished normally or due to a fatal error occuring.
+.Pp
+In the text interface, to interrupt synchronization before it is finished,
+press
+.Sy Ctrl-C
+(or send signal
+.Sy SIGINT
+or
+.Sy SIGTERM ) .
+This will interrupt update propagation as quickly as possible but still
+complete proper cleanup. If the process does not stop even after pressing
+.Sy Ctrl-C
+then keep doing it repeatedly. This will bypass cleanup procedures and
+terminates the process forcibly (similar to
+.Sy SIGKILL ) .
+Doing so may leave the archives or replicas in an inconsistent state or locked.
 .Sh ENVIRONMENT
 .Bl -tag
 .It Ev UNISON

src/.depend

@@ -1348,6 +1348,7 @@ uigtk3.cmo : \
     common.cmi \
     clroot.cmi \
     case.cmi \
+    abort.cmi \
     uigtk3.cmi
 uigtk3.cmx : \
     uutil.cmx \
@@ -1373,6 +1374,7 @@ uigtk3.cmx : \
     common.cmx \
     clroot.cmx \
     case.cmx \
+    abort.cmx \
     uigtk3.cmi
 uigtk3.cmi : \
     uicommon.cmi
@@ -1449,6 +1451,7 @@ uitext.cmo : \
     globals.cmi \
     fswatchold.cmi \
     common.cmi \
+    abort.cmi \
     uitext.cmi
 uitext.cmx : \
     uutil.cmx \
@@ -1471,6 +1474,7 @@ uitext.cmx : \
     globals.cmx \
     fswatchold.cmx \
     common.cmx \
+    abort.cmx \
     uitext.cmi
 uitext.cmi : \
     uicommon.cmi

src/abort.ml

@@ -60,12 +60,20 @@ let all () = abortAll := true
 
 (****)
 
+let isAll () = !abortAll
+
+let checkAll () =
+  if !abortAll then raise (Util.Transient "Aborted by user request")
+
 let check id =
   debug (fun() -> Util.msg "Checking line %s\n" (Uutil.File.toString id));
-  if !abortAll || errorCount id >= Prefs.read maxerrors then begin
+  checkAll ();
+  if errorCount id >= Prefs.read maxerrors then begin
     debug (fun() ->
       Util.msg "Abort failure for line %s\n" (Uutil.File.toString id));
     raise (Util.Transient "Aborted")
   end
 
-let testException e = (e = Util.Transient "Aborted")
+let testException e =
+  (e = Util.Transient "Aborted") ||
+  (e = Util.Transient "Aborted by user request")

src/abort.mli

@@ -7,6 +7,10 @@ val reset : unit -> unit
 val file : Uutil.File.t -> unit
 val all : unit -> unit
 
+(* Check whether stop of all transfers has been requested. *)
+val isAll : unit -> bool
+val checkAll : unit -> unit (* Raises a transient exception *)
+
 (* Check whether an item is being aborted.  A transient exception is
    raised if this is the case. *)
 val check : Uutil.File.t -> unit

src/copy.ml

@@ -433,6 +433,7 @@ let copyContents fspathFrom pathFrom fspathTo pathTo fileKind fileLength ido =
               (fun l ->
                  use_id (fun id ->
 (* (Util.msg "Copied file %s (%d bytes)\n" (Path.toString pathFrom) l); *)
+                   if fileKind <> `RESS then Abort.checkAll ();
                    Uutil.showProgress id (Uutil.Filesize.ofInt l) "l"));
             closeFileIn inFd;
             closeFileOut outFd;
@@ -592,6 +593,7 @@ let compress conn
               (fun () ->
                  showPrefixProgress id fileKind;
                  let showProgress count =
+                   if fileKind <> `RESS then Abort.checkAll ();
                    Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
                  let compr =
                    match biOpt with
@@ -701,6 +703,7 @@ let transferFileContents
   let outfd = ref None in
   let infd = ref None in
   let showProgress count =
+    if fileKind <> `RESS then Abort.checkAll ();
     Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
 
   let destFileSize =

src/files.ml

@@ -733,10 +733,8 @@ let copy
       (fun e ->
          match e with
            Util.Transient _ ->
-             if not (Abort.testException e) then begin
-               Abort.file id;
-               errors := e :: !errors
-             end;
+             if not (Abort.testException e) then Abort.file id;
+             errors := e :: !errors;
              Lwt.return (Update.NoArchive, [pFrom])
          | _ ->
              Lwt.fail e)

src/remote.ml

@@ -1851,8 +1851,52 @@ 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 pid = Util.blockSignals [Sys.sigint] (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/strings.ml

@@ -2728,6 +2728,36 @@ let docs =
       \032      Setting the dumbtty preference will force Unison to leave the\n\
       \032      terminal alone and process input a line at a time.\n\
       \n\
+      Interrupting a Synchronization\n\
+      \n\
+      \032  It is possible to interrupt an ongoing synchronization process before\n\
+      \032  it completes. Different user interfaces offer different ways of doing\n\
+      \032  it.\n\
+      \n\
+      \032  Graphical Interface:\n\
+      \032    * In the graphical user interface the synchronization process can be\n\
+      \032      interrupted before it is finished by pressing the \226\128\156Stop\226\128\157 button or\n\
+      \032      by closing the window. The \226\128\156Stop\226\128\157 button causes the onging\n\
+      \032      propagation to be stopped as quickly as possible while still doing\n\
+      \032      proper cleanup. The application keeps running and a rescan can be\n\
+      \032      performed or a different profile selected. Closing the window in\n\
+      \032      the middle of update propagation process will exit the application\n\
+      \032      immediately without doing proper cleanup; it is therefore not\n\
+      \032      recommended unless the \226\128\156Stop\226\128\157 button does not react quickly enough.\n\
+      \n\
+      \032  Textual Interface:\n\
+      \032    * When not synchronizing continuously, the text interface terminates\n\
+      \032      when synchronization is finished normally or due to a fatal error\n\
+      \032      occuring.\n\
+      \032      In the text interface, to interrupt synchronization before it is\n\
+      \032      finished, press \226\128\156Ctrl-C\226\128\157 (or send signal SIGINT or SIGTERM). This\n\
+      \032      will interrupt update propagation as quickly as possible but still\n\
+      \032      complete proper cleanup. If the process does not stop even after\n\
+      \032      pressing \226\128\156Ctrl-C\226\128\157 then keep doing it repeatedly. This will bypass\n\
+      \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\
+      \n\
       Exit Code\n\
       \n\
       \032  When running in the textual mode, Unison returns an exit status, which\n\

src/transport.ml

@@ -55,6 +55,7 @@ let maxThreads () =
 
 let run dispenseTask =
   let runConcurrent limit dispenseTask =
+    let dispenseTask () = if Abort.isAll () then None else dispenseTask () in
     let avail = ref limit in
     let rec runTask thr =
       Lwt.try_bind thr
@@ -156,9 +157,9 @@ let doAction
                  fromRoot fromPath uiFrom propsFrom
                  toRoot toPath uiTo propsTo
                  notDefault id))
-    (fun e -> Trace.log
+    (fun e -> Trace.logonly
         (Printf.sprintf
-           "Failed: %s\n" (Util.printException e));
+           "Failed [%s]: %s\n" (Path.toString toPath) (Util.printException e));
       return ())
 
 let propagate root1 root2 reconItem id showMergeFn =

src/ubase/util.ml

@@ -272,6 +272,19 @@ let process_status_to_string = function
   | Unix.WSIGNALED i -> Printf.sprintf "Killed by signal %d" i
   | Unix.WSTOPPED i  -> Printf.sprintf "Stopped by signal %d" i
 
+
+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
+
 (*****************************************************************************)
 (*                         OS TYPE                                           *)
 (*****************************************************************************)

src/ubase/util.mli

@@ -33,6 +33,11 @@ val printException : exn -> string
 
 val process_status_to_string : Unix.process_status -> string
 
+(* [blockSignals sigs f] blocks signals [sigs] (if supported by OS),
+   executes [f ()] and restores the original signal mask before returning
+   the result of executing [f ()] (value or exception). *)
+val blockSignals : int list -> (unit -> 'a) -> 'a
+
 (* ---------------------------------------------------------------------- *)
 (* Strings *)