* Bumped version number: incompatible protocol changes

* Partial transfer of directories.  If an error occurs while
  transferring a directory, the part transferred so far is copied into
  place (and the archives are updated accordingly).
  The "maxerrors" preference controls how many transfer error Unison
  will accept before stopping the transfer of a directory (by default,
  only one).  This makes it possible to transfer most of a directory
  even if there are some errors.  Currently, only the first error is
  reported by the GUIs.
* Save a copy of a failed transfer only when the source file is
  unchanged.
* Function Trace.log is not called anymore from Copy.tryCopyMovedFile
  as Trace.log performs a callback to the client inside a Lwt_unix.run
  event loop, which introduces spurious synchronization between
  threads.  Instead, the function returns a message which is sent back
  to the client.
* Code reorganization in files.ml/update.ml to minimize the number of
  network roundtrips.

10 files changed, 401 insertions, 466 deletions

diff --git a/src/RECENTNEWS b/src/RECENTNEWS
index 3988e64..cb2f090 100644
--- a/src/RECENTNEWS
+++ b/src/RECENTNEWS
@@ -1,3 +1,26 @@
+CHANGES FROM VERSION 2.36.-27
+
+* Bumped version number: incompatible protocol changes
+
+* Partial transfer of directories.  If an error occurs while
+  transferring a directory, the part transferred so far is copied into
+  place (and the archives are updated accordingly).
+  The "maxerrors" preference controls how many transfer error Unison
+  will accept before stopping the transfer of a directory (by default,
+  only one).  This makes it possible to transfer most of a directory
+  even if there are some errors.  Currently, only the first error is
+  reported by the GUIs.
+* Save a copy of a failed transfer only when the source file is
+  unchanged.
+* Function Trace.log is not called anymore from Copy.tryCopyMovedFile
+  as Trace.log performs a callback to the client inside a Lwt_unix.run
+  event loop, which introduces spurious synchronization between
+  threads.  Instead, the function returns a message which is sent back
+  to the client.
+* Code reorganization in files.ml/update.ml to minimize the number of
+  network roundtrips.
+
+-------------------------------
 CHANGES FROM VERSION 2.35.-17
 
 * Various small changes
diff --git a/src/abort.ml b/src/abort.ml
index 65b8e4e..738b50b 100644
--- a/src/abort.ml
+++ b/src/abort.ml
@@ -15,21 +15,45 @@
     along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)
 
-
 let debug = Trace.debug "abort"
 
-let files = ref ([] : Uutil.File.t list)
+(****)
+
+let maxerrors =
+  Prefs.createInt "maxerrors" 1
+    "!maximum number of errors before a directory transfer is aborted"
+    "This preference controls after how many errors Unison aborts a \
+     directory transfer.  Setting it to a large number allows Unison \
+     to transfer most of a directory even when some files fail to be \
+     copied.  The default is 1.  If the preference is set to high, \
+     Unison may take a long time to abort in case of repeated \
+     failures (for instance, when the disk is full)."
+
+(****)
+
+let files = Hashtbl.create 17
 let abortAll = ref false
 
+let errorCountCell id =
+  try
+    Hashtbl.find files id
+  with Not_found ->
+    let c = ref 0 in
+    Hashtbl.add files id c;
+    c
+
+let errorCount id = !(errorCountCell id)
+let bumpErrorCount id = incr (errorCountCell id)
+
 (****)
 
-let reset () = files := []; abortAll := false
+let reset () = Hashtbl.clear files; abortAll := false
 
 (****)
 
 let file id =
   debug (fun() -> Util.msg "Aborting line %s\n" (Uutil.File.toString id));
-  files := id :: !files
+  bumpErrorCount id
 
 let all () = abortAll := true
 
@@ -37,33 +61,10 @@ let all () = abortAll := true
 
 let check id =
   debug (fun() -> Util.msg "Checking line %s\n" (Uutil.File.toString id));
-  if !abortAll || Safelist.mem id !files then begin
+  if !abortAll || 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 (>>=) = Lwt.bind
-
-let mergeErrors id e runningThreads =
-  if not (testException e) then file id;
-  match e with
-    Util.Transient _ ->
-      let e = ref e in
-      Lwt_util.iter
-        (fun act ->
-           Lwt.catch
-              (fun () -> act >>= fun _ -> Lwt.return ())
-              (fun e' ->
-                 match e' with
-                   Util.Transient _ ->
-                     if testException !e then e := e';
-                     Lwt.return ()
-                 | _                ->
-                     Lwt.fail e'))
-        runningThreads >>= fun () ->
-      Lwt.fail !e
-  | _ ->
-      Lwt.fail e
diff --git a/src/abort.mli b/src/abort.mli
index b2c334a..626f443 100644
--- a/src/abort.mli
+++ b/src/abort.mli
@@ -13,8 +13,3 @@ val check : Uutil.File.t -> unit
 
 (* Test whether the exeption is an abort exception. *)
 val testException : exn -> bool
-
-(* When one thread has failed (in a non-fatal way), this function will
-   abort the current transfer and wait for all other threads in the
-   list to terminate before continuing *)
-val mergeErrors : Uutil.File.t -> exn -> 'a Lwt.t list -> 'b Lwt.t
diff --git a/src/copy.ml b/src/copy.ml
index d183083..ddd9c30 100644
--- a/src/copy.ml
+++ b/src/copy.ml
@@ -127,23 +127,31 @@ let paranoidCheck fspathTo pathTo realPathTo desc fp ress =
   let info = Fileinfo.get false fspathTo pathTo in
   let fp' = Os.fingerprint fspathTo pathTo info in
   if fp' <> fp then begin
-    let savepath =
-      Os.tempPath ~fresh:true fspathTo
-        (match Path.deconstructRev realPathTo with
-           Some (nm, _) -> Path.addSuffixToFinalName
-                             (Path.child Path.empty nm) "-bad"
-         | None         -> Path.fromString "bad")
-    in
-    Os.rename "save temp" fspathTo pathTo fspathTo savepath;
-    Lwt.return (Failure (Printf.sprintf
-      "The file %s was incorrectly transferred  (fingerprint mismatch in %s) \
-       -- temp file saved as %s"
-      (Path.toString pathTo)
-      (Os.reasonForFingerprintMismatch fp fp')
-      (Fspath.toDebugString (Fspath.concat fspathTo savepath))))
+    Lwt.return (Failure (Os.reasonForFingerprintMismatch fp fp'))
   end else
     Lwt.return (Success info)
 
+let saveTempFileLocal (fspathTo, (pathTo, realPathTo, reason)) =
+  let savepath =
+    Os.tempPath ~fresh:true fspathTo
+      (match Path.deconstructRev realPathTo with
+         Some (nm, _) -> Path.addSuffixToFinalName
+                           (Path.child Path.empty nm) "-bad"
+       | None         -> Path.fromString "bad")
+  in
+  Os.rename "save temp" fspathTo pathTo fspathTo savepath;
+  Lwt.fail
+    (Util.Transient
+       (Printf.sprintf
+        "The file %s was incorrectly transferred  (fingerprint mismatch in %s) \
+         -- temp file saved as %s"
+        (Path.toString pathTo)
+        reason
+        (Fspath.toDebugString (Fspath.concat fspathTo savepath))))
+
+let saveTempFileOnRoot =
+  Remote.registerRootCmd "saveTempFile" saveTempFileLocal
+
 (****)
 
 let removeOldTempFile fspathTo pathTo =
@@ -202,7 +210,6 @@ let copyContents fspathFrom pathFrom fspathTo pathTo fileKind fileLength ido =
             Uutil.readWriteBounded inFd outFd fileLength
               (fun l ->
                  use_id (fun id ->
-                   Abort.check id;
                    Uutil.showProgress id (Uutil.Filesize.ofInt l) "l"));
             close_in inFd;
             close_out outFd)
@@ -228,22 +235,6 @@ let localFile
 
 (****)
 
-(* BCP '06: This is a hack to work around a bug on the Windows platform
-   that causes lightweight threads on the server to hang.  I conjecture that
-   the problem has to do with the RPC mechanism, which was used here to
-   make a call *back* from the server to the client inside Trace.log so that
-   the log message would be appended to the log file on the client. *)
-(* BCP '08: Jerome thinks that printing these messages using Util.msg
-   may be causing the dreaded "assertion failure in remote.ml," which
-   happens only on windows and seems correlated with the xferbycopying
-   switch.  The conjecture is that some windows ssh servers may combine
-   the stdout and stderr streams, which would result in these messages
-   getting interleaved with Unison's RPC protocol stream. *)
-let loggit s =
-  if Prefs.read Globals.someHostIsRunningWindows
-    then () (* Util.msg "%s" *)
-    else Trace.log s
-
 let tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id =
   if not (Prefs.read Xferhint.xferbycopying) then None else
   Util.convertUnixErrorsToTransient "tryCopyMovedFile" (fun() ->
@@ -253,10 +244,6 @@ let tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id =
       None ->
         None
     | Some (candidateFspath, candidatePath) ->
-        loggit (Printf.sprintf
-          "Shortcut: copying %s from local file %s\n"
-          (Path.toString realPathTo)
-          (Path.toString candidatePath));
         debug (fun () ->
           Util.msg
             "tryCopyMovedFile: found match at %s,%s. Try local copying\n"
@@ -272,33 +259,36 @@ let tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id =
             if isTransferred then begin
               debug (fun () -> Util.msg "tryCopyMoveFile: success.\n");
               Xferhint.insertEntry (fspathTo, pathTo) fp;
-              Some info
+              let msg =
+                Printf.sprintf
+                 "Shortcut: copied %s from local file %s\n"
+                 (Path.toString realPathTo)
+                 (Path.toString candidatePath)
+              in
+              Some (info, msg)
             end else begin
               debug (fun () ->
-                Util.msg "tryCopyMoveFile: candidate file modified!");
+                Util.msg "tryCopyMoveFile: candidate file %s modified!\n"
+                  (Path.toString candidatePath));
               Xferhint.deleteEntry (candidateFspath, candidatePath);
               Os.delete fspathTo pathTo;
-              loggit (Printf.sprintf
-                "Shortcut didn't work because %s was modified\n"
-                (Path.toString candidatePath));
               None
             end
           end else begin
-            loggit (Printf.sprintf
-              "Shortcut didn't work because %s disappeared!\n"
-              (Path.toString candidatePath));
+            debug (fun () ->
+              Util.msg "tryCopyMoveFile: candidate file %s disappeared!\n"
+                (Path.toString candidatePath));
             Xferhint.deleteEntry (candidateFspath, candidatePath);
             None
           end
         with
           Util.Transient s ->
             debug (fun () ->
-              Util.msg "tryCopyMovedFile: local copy didn't work [%s]" s);
+              Util.msg
+                "tryCopyMovedFile: local copy from %s didn't work [%s]"
+                (Path.toString candidatePath) s);
             Xferhint.deleteEntry (candidateFspath, candidatePath);
             Os.delete fspathTo pathTo;
-            loggit (Printf.sprintf
-              "Local copy of %s failed\n"
-              (Path.toString candidatePath));
             None)
 
 (****)
@@ -345,11 +335,13 @@ let compress conn
     (fun () ->
        streamTransferInstruction conn
          (fun processTransferInstructionRemotely ->
+            (* We abort the file transfer on error if it has not
+               already started *)
+            if fileKind = `DATA then Abort.check id;
             let infd = openFileIn fspathFrom pathFrom fileKind in
             lwt_protect
               (fun () ->
                  let showProgress count =
-                   Abort.check id;
                    Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
                  let compr =
                    match biOpt with
@@ -397,9 +389,12 @@ let close_all_no_error infd outfd =
   end
 
 (* Lazy creation of the destination file *)
-let destinationFd fspath path kind len outfd =
+let destinationFd fspath path kind len outfd id =
   match !outfd with
     None    ->
+      (* We abort the file transfer on error if it has not
+         already started *)
+      if kind = `DATA then Abort.check id;
       let fd = openFileOut fspath path kind len in
       outfd := Some fd;
       fd
@@ -414,7 +409,6 @@ let transferFileContents
   let outfd = ref None in
   let infd = ref None in
   let showProgress count =
-    Abort.check id;
     Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
   let (bi, decompr) =
     match update with
@@ -443,7 +437,7 @@ let transferFileContents
               fun ti ->
               let fd =
                 destinationFd
-                  fspathTo pathTo fileKind srcFileSize outfd in
+                  fspathTo pathTo fileKind srcFileSize outfd id in
               let eof =
                 Transfer.Rsync.rsyncDecompress ifd fd showProgress ti
               in
@@ -452,7 +446,8 @@ let transferFileContents
         (None,
          (* Simple generic decompressor *)
          fun ti ->
-         let fd = destinationFd fspathTo pathTo fileKind srcFileSize outfd in
+         let fd =
+           destinationFd fspathTo pathTo fileKind srcFileSize outfd id in
          let eof = Transfer.receive fd showProgress ti in
          if eof then begin close_out fd; outfd := None end)
   in
@@ -670,14 +665,14 @@ let transferFileLocal connFrom
       "%s/%s has already been transferred\n"
       (Fspath.toDebugString fspathTo) (Path.toString pathTo));
     setFileinfo fspathTo pathTo realPathTo update desc;
-    Lwt.return (`DONE (Success info))
+    Lwt.return (`DONE (Success info, None))
   end else
    match
      tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id
    with
-     Some info ->
+     Some (info, msg) ->
        (* Transfer was performed by copying *)
-       Lwt.return (`DONE (Success info))
+       Lwt.return (`DONE (Success info, Some msg))
    | None ->
        if shouldUseExternalCopyprog update desc then
          Lwt.return (`EXTERNAL (prepareExternalTransfer fspathTo pathTo))
@@ -685,7 +680,7 @@ let transferFileLocal connFrom
          reallyTransferFile
            connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
            update desc fp ress id >>= fun status ->
-         Lwt.return (`DONE status)
+         Lwt.return (`DONE (status, None))
        end
 
 let transferFileOnRoot =
@@ -702,15 +697,19 @@ let bufferSize sz =
   8 (* Read buffer *)
 
 let transferFile
-    rootFrom pathFrom rootTo fspathTo pathTo realPathTo
-    update desc fp ress id =
+      rootFrom pathFrom rootTo fspathTo pathTo realPathTo
+      update desc fp ress id =
   let f () =
     Abort.check id;
     transferFileOnRoot rootTo rootFrom
       (snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo,
        update, desc, fp, ress, id) >>= fun status ->
     match status with
-      `DONE status ->
+      `DONE (status, msg) ->
+         begin match msg with
+           Some msg -> Trace.log msg
+         | None     -> ()
+         end;
          Lwt.return status
     | `EXTERNAL useExistingTarget ->
          transferFileUsingExternalCopyprog
@@ -759,4 +758,5 @@ let file rootFrom pathFrom rootTo fspathTo pathTo realPathTo
          We check this before reporting a failure *)
       checkContentsChange rootFrom pathFrom desc fp stamp ress true
         >>= fun () ->
-      Lwt.fail (Util.Transient reason)
+      (* This function always fails! *)
+      saveTempFileOnRoot rootTo (pathTo, realPathTo, reason)
diff --git a/src/files.ml b/src/files.ml
index 4a45f6e..eb603d8 100644
--- a/src/files.ml
+++ b/src/files.ml
@@ -69,74 +69,78 @@ let processCommitLogOnHost =
 let processCommitLogs() =
   Lwt_unix.run
     (Globals.allHostsIter (fun h -> processCommitLogOnHost h ()))
-    
+
 (* ------------------------------------------------------------ *)
-    
-let deleteLocal (fspath, (workingDirOpt, path)) =
-  (* when the workingDirectory is set, we are dealing with a temporary file *)
-  (* so we don't call the stasher in this case.                             *)
-  begin match workingDirOpt with
-    Some p -> 
-      debug (fun () -> Util.msg  "deleteLocal [%s] (%s, %s)\n" (Fspath.toDebugString fspath) (Fspath.toDebugString p) (Path.toString path));
-      Os.delete p path
-  | None ->
-      debug (fun () -> Util.msg "deleteLocal [%s] (None, %s)\n" (Fspath.toDebugString fspath) (Path.toString path));
-      Stasher.backup fspath path `AndRemove
-  end;
+
+let deleteLocal (fspathTo, (pathTo, ui)) =
+  debug (fun () ->
+     Util.msg "deleteLocal [%s] (None, %s)\n"
+       (Fspath.toDebugString fspathTo) (Path.toString pathTo));
+  let localPathTo = Update.translatePathLocal fspathTo pathTo in
+  (* Make sure the target is unchanged first *)
+  (* (There is an unavoidable race condition here.) *)
+  Update.checkNoUpdates fspathTo localPathTo ui;
+  Stasher.backup fspathTo localPathTo `AndRemove;
+  (* Archive update must be done last *)
+  Update.replaceArchiveLocal fspathTo localPathTo Update.NoArchive;
   Lwt.return ()
-    
-let performDelete = Remote.registerRootCmd "delete" deleteLocal
-    
-(* FIX: maybe we should rename the destination before making any check ? *)
+
+let deleteOnRoot = Remote.registerRootCmd "delete" deleteLocal
+
 let delete rootFrom pathFrom rootTo pathTo ui =
-  Update.transaction (fun id ->
-    Update.replaceArchive rootFrom pathFrom Update.NoArchive id
-      >>= (fun _ ->
-    Update.replaceArchive rootTo pathTo Update.NoArchive id
-        >>= (fun localPathTo ->
-    (* Make sure the target is unchanged *)
-    (* (There is an unavoidable race condition here.) *)
-	      Update.checkNoUpdates rootTo pathTo ui >>= (fun () ->
-		performDelete rootTo (None, localPathTo)))))
-    
+  deleteOnRoot rootTo (pathTo, ui) >>= fun _ ->
+  Update.replaceArchive rootFrom pathFrom Update.NoArchive
+
 (* ------------------------------------------------------------ *)
-    
-let setPropRemote =
-  Remote.registerRootCmd
-    "setProp"
-    (fun (fspath, (workingDir, path, kind, newDesc)) ->
-      Fileinfo.set workingDir path kind newDesc;
-      Lwt.return ())
-    
-let setPropRemote2 =
+
+let fileUpdated ui =
+  match ui with
+    Updates (File (_, ContentsUpdated _), _) -> true
+  | _                                        -> false
+
+let setPropLocal (fspath, (path, ui, newDesc, oldDesc)) =
+  (* [ui] provides the modtime while [newDesc] provides the other
+     file properties *)
+  let localPath = Update.translatePathLocal fspath path in
+  let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in
+  Fileinfo.set workingDir realPath (`Update oldDesc) newDesc;
+  if fileUpdated ui then Stasher.stashCurrentVersion fspath localPath None;
+  (* Archive update must be done last *)
+  Update.updateProps fspath localPath (Some newDesc) ui;
+  Lwt.return ()
+
+let setPropOnRoot = Remote.registerRootCmd "setProp" setPropLocal
+
+let updatePropsOnRoot =
   Remote.registerRootCmd
-    "setProp2"
-    (fun (fspath, (path, kind, newDesc)) ->
-       let (workingDir,realPath) = Fspath.findWorkingDir fspath path in
-       Fileinfo.set workingDir realPath kind newDesc;
-       Lwt.return ())
-    
+   "updateProps"
+     (fun (fspath, (path, propOpt, ui)) ->
+        let localPath = Update.translatePathLocal fspath path in
+        (* Archive update must be done first *)
+        Update.updateProps fspath localPath propOpt ui;
+        if fileUpdated ui then
+          Stasher.stashCurrentVersion fspath localPath None;
+        Lwt.return ())
+
+let updateProps root path propOpt ui =
+  updatePropsOnRoot root (path, propOpt, ui)
+
 (* FIX: we should check there has been no update before performing the
    change *)
-let setProp fromRoot fromPath toRoot toPath newDesc oldDesc uiFrom uiTo =
+let setProp rootFrom pathFrom rootTo pathTo newDesc oldDesc uiFrom uiTo =
   debug (fun() ->
     Util.msg
       "setProp %s %s %s\n   %s %s %s\n"
-      (root2string fromRoot) (Path.toString fromPath)
+      (root2string rootFrom) (Path.toString pathFrom)
       (Props.toString newDesc)
-      (root2string toRoot) (Path.toString toPath)
+      (root2string rootTo) (Path.toString pathTo)
       (Props.toString oldDesc));
-  Update.transaction (fun id ->
-    Update.updateProps fromRoot fromPath None uiFrom id >>= (fun _ ->
-    (* [uiTo] provides the modtime while [desc] provides the other
-       file properties *)
-    Update.updateProps toRoot toPath (Some newDesc) uiTo id >>=
-      (fun toLocalPath ->
-	setPropRemote2 toRoot (toLocalPath, `Update oldDesc, newDesc))))
-    
+  setPropOnRoot rootTo (pathTo, uiTo, newDesc, oldDesc) >>= fun _ ->
+  updateProps rootFrom pathFrom None uiFrom
+
 (* ------------------------------------------------------------ *)
 
-let mkdirRemote =
+let mkdirOnRoot =
   Remote.registerRootCmd
     "mkdir"
     (fun (fspath,(workingDir,path)) ->
@@ -155,18 +159,32 @@ let mkdirRemote =
          Lwt.return (false, (Fileinfo.get false workingDir path).Fileinfo.desc)
        end)
 
-let mkdir onRoot workingDir path = mkdirRemote onRoot (workingDir,path)
+let setDirPropOnRoot =
+  Remote.registerRootCmd
+    "setDirProp"
+    (fun (_, (workingDir, path, initialDesc, newDesc)) ->
+      Fileinfo.set workingDir path (`Set initialDesc) newDesc;
+      Lwt.return ())
+
+let makeSymlink =
+  Remote.registerRootCmd
+    "makeSymlink"
+    (fun (fspath, (workingDir, path, l)) ->
+       if Os.exists workingDir path then
+         Os.delete workingDir path;
+       Os.symlink workingDir path l;
+       Lwt.return ())
 
 (* ------------------------------------------------------------ *)
-    
-let renameLocal (root, (localTargetPath, fspath, pathFrom, pathTo)) =
-  debug (fun () -> Util.msg "Renaming %s to %s in %s; root is %s\n" 
-      (Path.toString pathFrom) 
-      (Path.toString pathTo) 
-      (Fspath.toDebugString fspath) 
-      (Fspath.toDebugString root));
-  let source = Fspath.concat fspath pathFrom in
-  let target = Fspath.concat fspath pathTo in
+
+let performRename fspathTo localPathTo workingDir pathFrom pathTo =
+  debug (fun () -> Util.msg "Renaming %s to %s in %s; root is %s\n"
+      (Path.toString pathFrom)
+      (Path.toString pathTo)
+      (Fspath.toDebugString workingDir)
+      (Fspath.toDebugString fspathTo));
+  let source = Fspath.concat workingDir pathFrom in
+  let target = Fspath.concat workingDir pathTo in
   Util.convertUnixErrorsToTransient
     (Printf.sprintf "renaming %s to %s"
        (Fspath.toDebugString source) (Fspath.toDebugString target))
@@ -180,9 +198,8 @@ let renameLocal (root, (localTargetPath, fspath, pathFrom, pathTo)) =
       if filetypeFrom = `ABSENT then raise (Util.Transient (Printf.sprintf
            "Error while renaming %s to %s -- source file has disappeared!"
 	   (Fspath.toPrintString source) (Fspath.toPrintString target)));
-      let filetypeTo =
-        (Fileinfo.get false target Path.empty).Fileinfo.typ in
-      
+      let filetypeTo = (Fileinfo.get false target Path.empty).Fileinfo.typ in
+
        (* Windows and Unix operate differently if the target path of a
           rename already exists: in Windows an exception is raised, in
           Unix the file is clobbered.  In both Windows and Unix, if
@@ -190,7 +207,7 @@ let renameLocal (root, (localTargetPath, fspath, pathFrom, pathTo)) =
           be raised.  We want to avoid doing the move first, if possible,
           because this opens a "window of danger" during which the contents of
           the path is nothing. *)
-      let moveFirst = 
+      let moveFirst =
         match (filetypeFrom, filetypeTo) with
         | (_, `ABSENT)            -> false
         | ((`FILE | `SYMLINK),
@@ -198,13 +215,13 @@ let renameLocal (root, (localTargetPath, fspath, pathFrom, pathTo)) =
         | _                       -> true (* Safe default *) in
       if moveFirst then begin
         debug (fun() -> Util.msg "rename: moveFirst=true\n");
-        let tmpPath = Os.tempPath fspath pathTo in
-        let temp = Fspath.concat fspath tmpPath in
+        let tmpPath = Os.tempPath workingDir pathTo in
+        let temp = Fspath.concat workingDir tmpPath in
         let temp' = Fspath.toDebugString temp in
 
         debug (fun() ->
           Util.msg "moving %s to %s\n" (Fspath.toDebugString target) temp');
-        Stasher.backup root localTargetPath `ByCopying;
+        Stasher.backup fspathTo localPathTo `ByCopying;
         writeCommitLog source target temp';
         Util.finalize (fun() ->
           (* If the first rename fails, the log can be removed: the
@@ -228,22 +245,20 @@ let renameLocal (root, (localTargetPath, fspath, pathFrom, pathTo)) =
         Os.delete temp Path.empty
       end else begin
         debug (fun() -> Util.msg "rename: moveFirst=false\n");
-        Stasher.backup root localTargetPath `ByCopying;
+        Stasher.backup fspathTo localPathTo `ByCopying;
         Os.rename "renameLocal(3)" source Path.empty target Path.empty;
-        debug (fun() -> 
+        debug (fun() ->
 	  if filetypeFrom = `FILE then
             Util.msg
-              "Contents of %s after renaming = %s\n" 
+              "Contents of %s after renaming = %s\n"
               (Fspath.toDebugString target)
     	      (Fingerprint.toString (Fingerprint.file target Path.empty)));
-      end;
-      Lwt.return ())
-    
-let renameOnHost = Remote.registerRootCmd "rename" renameLocal
-    
+      end)
+
 (* FIX: maybe we should rename the destination before making any check ? *)
-(* FIX: When this code was originally written, we assumed that the
-   checkNoUpdates would happen immediately before the renameOnHost, so that
+(* JV (6/09): the window is small again...
+   FIX: When this code was originally written, we assumed that the
+   checkNoUpdates would happen immediately before the rename, so that
    the window of danger where other processes could invalidate the thing we
    just checked was very small.  But now that transport is multi-threaded,
    this window of danger could get very long because other transfers are
@@ -252,15 +267,28 @@ let renameOnHost = Remote.registerRootCmd "rename" renameLocal
    check that their assumptions had not been violated and then switch the
    temp file into place, but remain able to roll back if something fails
    either locally or on the other side. *)
-let rename root pathInArchive localPath workingDir pathOld pathNew ui =
+let renameLocal
+      (fspathTo, (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt)) =
+  (* Make sure the target is unchanged, then do the rename.
+     (Note that there is an unavoidable race condition here...) *)
+  Update.checkNoUpdates fspathTo localPathTo ui;
+  performRename fspathTo localPathTo workingDir pathFrom pathTo;
+  (* Archive update must be done last *)
+  begin match archOpt with
+    Some archTo -> Stasher.stashCurrentVersion fspathTo localPathTo None;
+                   Update.replaceArchiveLocal fspathTo localPathTo archTo
+  | None        -> ()
+  end;
+  Lwt.return ()
+
+let renameOnHost = Remote.registerRootCmd "rename" renameLocal
+
+let rename root pathInArchive localPath workingDir pathOld pathNew ui archOpt =
   debug (fun() ->
     Util.msg "rename(root=%s, pathOld=%s, pathNew=%s)\n"
       (root2string root)
       (Path.toString pathOld) (Path.toString pathNew));
-  (* Make sure the target is unchanged, then do the rename.
-     (Note that there is an unavoidable race condition here...) *)
-  Update.checkNoUpdates root pathInArchive ui >>= (fun () ->
-    renameOnHost root (localPath, workingDir, pathOld, pathNew))
+  renameOnHost root (localPath, workingDir, pathOld, pathNew, ui, archOpt)
 
 (* ------------------------------------------------------------ *)
 
@@ -291,18 +319,29 @@ let setupTargetPaths =
 
 (* ------------------------------------------------------------ *)
 
-let makeSymlink =
-  Remote.registerRootCmd
-    "makeSymlink"
-    (fun (fspath, (workingDir, path, l)) ->
-       if Os.exists workingDir path then
-         Os.delete workingDir path;
-       Os.symlink workingDir path l;
-       Lwt.return ())
+let updateSourceArchiveLocal (fspathFrom, (localPathFrom, uiFrom, errPaths)) =
+  (* Archive update must be done first (before Stasher call) *)
+  let newArch = Update.updateArchive fspathFrom localPathFrom uiFrom in
+  (* We update the archive with what we were expected to copy *)
+  Update.replaceArchiveLocal fspathFrom localPathFrom newArch;
+  (* Then, we remove all pieces of which the copy failed *)
+  List.iter
+    (fun p ->
+       debug (fun () ->
+         Util.msg "Copy under %s/%s was aborted\n"
+           (Fspath.toDebugString fspathFrom) (Path.toString p));
+       Update.replaceArchiveLocal fspathFrom p Update.NoArchive)
+    errPaths;
+  Stasher.stashCurrentVersion fspathFrom localPathFrom None;
+  Lwt.return ()
+
+let updateSourceArchive =
+  Remote.registerRootCmd "updateSourceArchive" updateSourceArchiveLocal
 
 (* ------------------------------------------------------------ *)
 
 let deleteSpuriousChild fspathTo pathTo nm =
+  (* FIX: maybe we should turn them into Unison temporary files? *)
   let path = (Path.child pathTo nm) in
   debug (fun() -> Util.msg "Deleting spurious file %s/%s\n"
                     (Fspath.toDebugString fspathTo) (Path.toString path));
@@ -358,6 +397,9 @@ let copy
   (* Calculate target paths *)
   setupTargetPaths rootTo pathTo
      >>= fun (workingDir, realPathTo, tempPathTo, localPathTo) ->
+  (* Calculate source path *)
+  Update.translatePath rootFrom pathFrom >>= fun localPathFrom ->
+  let errors = ref [] in
   (* Inner loop for recursive copy... *)
   let rec copyRec pFrom      (* Path to copy from *)
                   pTo        (* (Temp) path to copy to *)
@@ -369,87 +411,110 @@ let copy
       Util.msg "copyRec %s --> %s  (really to %s)\n"
         (Path.toString pFrom) (Path.toString pTo)
         (Path.toString realPTo));
-    match f with
-      Update.ArchiveFile (desc, dig, stamp, ress) ->
-        Lwt_util.run_in_region copyReg 1 (fun () ->
-          Abort.check id;
-          let stmp = if Update.useFastChecking () then Some stamp else None in
-          Copy.file
-            rootFrom pFrom rootTo workingDir pTo realPTo
-            update desc dig stmp ress id
-            >>= fun info ->
-          let ress' = Osx.stamp info.Fileinfo.osX in
-          Lwt.return
-            (Update.ArchiveFile (Props.override info.Fileinfo.desc desc,
-                                 dig, Fileinfo.stamp info, ress')))
-    | Update.ArchiveSymlink l ->
-        Lwt_util.run_in_region copyReg 1 (fun () ->
-          debug (fun() -> Util.msg "Making symlink %s/%s -> %s\n"
-                            (root2string rootTo) (Path.toString pTo) l);
-          Abort.check id;
-          makeSymlink rootTo (workingDir, pTo, l) >>= fun () ->
-          Lwt.return f)
-    | Update.ArchiveDir (desc, children) ->
-        Lwt_util.run_in_region copyReg 1 (fun () ->
-          debug (fun() -> Util.msg "Creating directory %s/%s\n"
-            (root2string rootTo) (Path.toString pTo));
-          mkdir rootTo workingDir pTo) >>= fun (alreadyThere, initialDesc) ->
-        Abort.check id;
-        begin if alreadyThere then
-          let childNames =
-            Update.NameMap.fold (fun nm _ l -> nm :: l) children [] in
-          deleteSpuriousChildren rootTo (workingDir, pTo, childNames)
-        else
-          Lwt.return ()
-        end >>= fun () ->
-        Abort.check id;
-        let runningThreads = ref [] in
-        Lwt.catch
-          (fun () ->
-             let ch =
+    Lwt.catch
+      (fun () ->
+         match f with
+           Update.ArchiveFile (desc, dig, stamp, ress) ->
+             Lwt_util.run_in_region copyReg 1 (fun () ->
+               Abort.check id;
+               let stmp =
+                 if Update.useFastChecking () then Some stamp else None in
+               Copy.file
+                 rootFrom pFrom rootTo workingDir pTo realPTo
+                 update desc dig stmp ress id
+                 >>= fun info ->
+               let ress' = Osx.stamp info.Fileinfo.osX in
+               Lwt.return
+                 (Update.ArchiveFile (Props.override info.Fileinfo.desc desc,
+                                      dig, Fileinfo.stamp info, ress'),
+                  []))
+         | Update.ArchiveSymlink l ->
+             Lwt_util.run_in_region copyReg 1 (fun () ->
+               debug (fun() -> Util.msg "Making symlink %s/%s -> %s\n"
+                                 (root2string rootTo) (Path.toString pTo) l);
+               Abort.check id;
+               makeSymlink rootTo (workingDir, pTo, l) >>= fun () ->
+               Lwt.return (f, []))
+         | Update.ArchiveDir (desc, children) ->
+             Lwt_util.run_in_region copyReg 1 (fun () ->
+               debug (fun() -> Util.msg "Creating directory %s/%s\n"
+                 (root2string rootTo) (Path.toString pTo));
+               mkdirOnRoot rootTo (workingDir, pTo))
+                 >>= fun (dirAlreadyExisting, initialDesc) ->
+             Abort.check id;
+             (* We start a thread for each child *)
+             let childThreads =
                Update.NameMap.mapi
                  (fun name child ->
-                    let thread : Update.archive Lwt.t =
-                      copyRec (Path.child pFrom name)
-                              (Path.child pTo name)
-                              (Path.child realPTo name)
-                              child
-                    in
-                    runningThreads := thread :: !runningThreads;
-                    thread)
+                    copyRec (Path.child pFrom name)
+                            (Path.child pTo name)
+                            (Path.child realPTo name)
+                            child)
                  children
              in
+             (* We collect the thread results *)
              Update.NameMap.fold
-               (fun nm arThr chThr ->
-                  arThr >>= fun ar ->
-                  chThr >>= fun ch ->
-                  Lwt.return (Update.NameMap.add nm ar ch))
-               ch
-               (Lwt.return Update.NameMap.empty))
-          (fun e ->
-             (* If one thread fails (in a non-fatal way), we wait for
-                all other threads to terminate before continuing *)
-             Abort.mergeErrors id e !runningThreads)
-           >>= fun newChildren ->
-        Lwt_util.run_in_region copyReg 1 (fun () ->
-          (* We use the actual file permissions so as to preserve
-             inherited bits *)
-          Abort.check id;
-          setPropRemote rootTo
-            (workingDir, pTo, `Set initialDesc, desc)) >>= fun () ->
-        Lwt.return (Update.ArchiveDir (desc, newChildren))
-    | Update.NoArchive ->
-        assert false
+               (fun nm childThr remThr ->
+                  childThr >>= fun (arch, paths) ->
+                  remThr >>= fun (children, pathl, error) ->
+                  let childErr = arch = Update.NoArchive in
+                  let children =
+                    if childErr then children else
+                    Update.NameMap.add nm arch children
+                  in
+                  Lwt.return (children, paths :: pathl, error || childErr))
+               childThreads
+               (Lwt.return (Update.NameMap.empty, [], false))
+               >>= fun (newChildren, pathl, childError) ->
+             begin if dirAlreadyExisting || childError then
+               let childNames =
+                 Update.NameMap.fold (fun nm _ l -> nm :: l) newChildren [] in
+               deleteSpuriousChildren rootTo (workingDir, pTo, childNames)
+             else
+               Lwt.return ()
+             end >>= fun () ->
+             Lwt_util.run_in_region copyReg 1 (fun () ->
+               (* We use the actual file permissions so as to preserve
+                  inherited bits *)
+               setDirPropOnRoot rootTo
+                 (workingDir, pTo, initialDesc, desc)) >>= fun () ->
+             Lwt.return (Update.ArchiveDir (desc, newChildren),
+                         List.flatten pathl)
+         | Update.NoArchive ->
+             assert false)
+      (fun e ->
+         match e with
+           Util.Transient _ ->
+             if not (Abort.testException e) then begin
+               Abort.file id;
+               errors := e :: !errors
+             end;
+             Lwt.return (Update.NoArchive, [pFrom])
+         | _ ->
+             Lwt.fail e)
   in
-  Update.transaction (fun id ->
-  (* Update the archive on the source replica (but don't commit
-     the changes yet) and return the part of the new archive
-     corresponding to this path *)
-  Update.updateArchive rootFrom pathFrom uiFrom id
-    >>= fun (localPathFrom, archFrom) ->
-  copyRec localPathFrom tempPathTo realPathTo archFrom >>= fun archTo ->
-  Update.replaceArchive rootTo pathTo archTo id >>= fun _ ->
-  rename rootTo pathTo localPathTo workingDir tempPathTo realPathTo uiTo)
+  (* Compute locally what we need to propagate *)
+  let rootLocal = List.hd (Globals.rootsInCanonicalOrder ()) in
+  let localArch =
+    Update.updateArchive (snd rootLocal) localPathFrom uiFrom in
+  copyRec localPathFrom tempPathTo realPathTo localArch
+    >>= fun (archTo, errPaths) ->
+  if archTo = Update.NoArchive then
+    (* We were not able to transfer anything *)
+    Lwt.fail (List.hd !errors)
+  else begin
+    (* Rename the files to their final location and then update the
+       archive on the destination replica *)
+    rename rootTo pathTo localPathTo workingDir tempPathTo realPathTo uiTo
+      (Some archTo) >>= fun () ->
+    (* Update the archive on the source replica
+       FIX: we could reuse localArch if rootFrom is the same as rootLocal *)
+    updateSourceArchive rootFrom (localPathFrom, uiFrom, errPaths) >>= fun () ->
+    (* Return the first error, if any *)
+    match Safelist.rev !errors with
+      e :: _ -> Lwt.fail e
+    | []     -> Lwt.return ()
+  end
 
 (* ------------------------------------------------------------ *)
 
@@ -624,7 +689,7 @@ let copyBack fspathFrom pathFrom rootTo pathTo propsTo uiTo id =
     (Local, fspathFrom) pathFrom rootTo workingDirForCopy tempPathTo realPathTo
     `Copy newprops fp None stamp id >>= fun info ->
   rename rootTo pathTo localPathTo workingDirForCopy tempPathTo realPathTo
-    uiTo )
+    uiTo None)
     
 let keeptempfilesaftermerge =   
   Prefs.createBool
@@ -899,13 +964,9 @@ let merge root1 root2 path id ui1 ui2 showMergeFn =
                (Props.get (Fs.stat arch_fspath) infoarch.osX, dig,
                 Fileinfo.stamp (Fileinfo.get true arch_fspath Path.empty),
                 Osx.stamp infoarch.osX) in
-           Update.transaction
-             (fun transid ->
-                Update.replaceArchive root1 path new_archive_entry transid
-                  >>= fun _ ->
-                Update.replaceArchive root2 path new_archive_entry transid
-                  >>= fun _ ->
-                Lwt.return ())
+           Update.replaceArchive root1 path new_archive_entry >>= fun _ ->
+           Update.replaceArchive root2 path new_archive_entry >>= fun _ ->
+           Lwt.return ()
          end else 
            (Lwt.return ()) )))) )
     (fun _ ->
diff --git a/src/mkProjectInfo.ml b/src/mkProjectInfo.ml
index b5e45ec..8e97031 100644
--- a/src/mkProjectInfo.ml
+++ b/src/mkProjectInfo.ml
@@ -5,8 +5,8 @@
 
 let projectName = "unison"
 let majorVersion = 2
-let minorVersion = 35
-let pointVersionOrigin = 349 (* Revision that corresponds to point version 0 *)
+let minorVersion = 36
+let pointVersionOrigin = 359 (* Revision that corresponds to point version 0 *)
 
 (* Documentation:
    This is a program to construct a version of the form Major.Minor.Point,
@@ -165,3 +165,4 @@ Printf.printf "NAME=%s\n" projectName;;
 
 
 
+
diff --git a/src/transport.ml b/src/transport.ml
index d5d160c..970f163 100644
--- a/src/transport.ml
+++ b/src/transport.ml
@@ -75,16 +75,6 @@ let logLwtNumbered (lwtDescription: string) (lwtShortDescription: string)
     (fun _ ->
       Printf.sprintf "[END] %s\n" lwtShortDescription)
 
-let stashCurrentVersionOnRoot: Common.root -> Path.t -> unit Lwt.t = 
-  Remote.registerRootCmd 
-    "stashCurrentVersion" 
-    (fun (fspath, path) -> 
-      Lwt.return (Stasher.stashCurrentVersion fspath (Update.translatePathLocal fspath path) None))
-    
-let stashCurrentVersions fromRoot toRoot path =
-  stashCurrentVersionOnRoot fromRoot path >>= (fun()->
-  stashCurrentVersionOnRoot toRoot path)
-
 let doAction (fromRoot,toRoot) path fromContents toContents id =
   Lwt_util.resize_region actionReg (Prefs.read maxthreads);
   (* When streaming, we can transfer many file simultaneously:
@@ -125,8 +115,7 @@ let doAction (fromRoot,toRoot) path fromContents toContents id =
               ("Updating file " ^ Path.toString path)
               (fun () ->
                 Files.copy (`Update (fileSize uiFrom uiTo))
-                  fromRoot path uiFrom toRoot path uiTo id >>= (fun()->
-                stashCurrentVersions fromRoot toRoot path))
+                  fromRoot path uiFrom toRoot path uiTo id)
         | (_, _, _, uiFrom), (_, _, _, uiTo) ->
             logLwtNumbered
               ("Copying " ^ Path.toString path ^ "\n  from " ^
@@ -135,8 +124,7 @@ let doAction (fromRoot,toRoot) path fromContents toContents id =
               ("Copying " ^ Path.toString path)
               (fun () ->
                  Files.copy `Copy
-                   fromRoot path uiFrom toRoot path uiTo id >>= (fun()->
-               stashCurrentVersions fromRoot toRoot path)))
+                   fromRoot path uiFrom toRoot path uiTo id))
       (fun e -> Trace.log
           (Printf.sprintf
              "Failed: %s\n" (Util.printException e));
diff --git a/src/uigtk2.ml b/src/uigtk2.ml
index b0410be..cc2b35f 100644
--- a/src/uigtk2.ml
+++ b/src/uigtk2.ml
@@ -1625,7 +1625,8 @@ lst_store#set ~row ~column:c_path path;
       mainWindow#set_cell
         ~text:(transcodeFilename path ^
                "       [failed: click on this line for details]") i 4
-    end
+    end;
+    if !current = Some i then updateDetails ();
   in
 
   let totalBytesToTransfer = ref Uutil.Filesize.zero in
diff --git a/src/update.ml b/src/update.ml
index 910d772..c90d0f1 100644
--- a/src/update.ml
+++ b/src/update.ml
@@ -470,9 +470,6 @@ let postCommitArchiveOnRoot: Common.root -> unit -> unit Lwt.t =
 (* archiveCache: map(rootGlobalName, archive) *)
 let archiveCache = Hashtbl.create 7
 
-(*  commitAction: map(rootGlobalName * transactionId, action: unit -> unit) *)
-let commitActions = Hashtbl.create 7
-
 (* Retrieve an archive from the cache *)
 let getArchive (thisRoot: string): archive =
   Hashtbl.find archiveCache thisRoot
@@ -639,79 +636,6 @@ let loadArchives (optimistic: bool) : bool Lwt.t =
      >>= (fun _ -> Lwt.return identicals)
   else Lwt.return identicals)
 
-(* commitActions(thisRoot, id) <- action *)
-let setCommitAction (thisRoot: string) (id: int) (action: unit -> unit): unit =
-  let key = (thisRoot, id) in
-  Hashtbl.replace commitActions key action
-
-(* perform and remove the action associated with (thisRoot, id) *)
-let softCommitLocal (thisRoot: string) (id: int) =
-  debug (fun () ->
-    Util.msg "Committing %d\n" id);
-  let key = (thisRoot, id) in
-  Hashtbl.find commitActions key ();
-  Hashtbl.remove commitActions key
-
-(* invoke softCommitLocal on a given root (which is possibly remote) *)
-let softCommitOnRoot: Common.root -> int -> unit Lwt.t =
-  Remote.registerRootCmd
-    "softCommit"
-    (fun (fspath, id) ->
-       Lwt.return (softCommitLocal (thisRootsGlobalName fspath) id))
-
-(* Commit the archive on all roots. The archive must have been updated on
-   all roots before that.  I.e., carry out the action corresponding to [id]
-   on all the roots *)
-let softCommit (id: int): unit Lwt.t =
-  Util.convertUnixErrorsToFatal "softCommit" (*XXX*)
-    (fun () ->
-       Globals.allRootsIter
-         (fun r -> softCommitOnRoot r id))
-
-(* [rollBackLocal thisRoot id] removes the action associated with (thisRoot,
-   id) *)
-let rollBackLocal thisRoot id =
-  let key = (thisRoot, id) in
-  try Hashtbl.remove commitActions key with Not_found -> ()
-
-let rollBackOnRoot: Common.root -> int -> unit Lwt.t =
-  Remote.registerRootCmd
-    "rollBack"
-    (fun (fspath, id) ->
-       Lwt.return (rollBackLocal (thisRootsGlobalName fspath) id))
-
-(* Rollback the archive on all roots. *)
-(* I.e., remove the action associated with [id] on all roots *)
-let rollBack id =
-  Util.convertUnixErrorsToFatal "rollBack" (*XXX*)
-    (fun () ->
-       Globals.allRootsIter
-         (fun r -> rollBackOnRoot r id))
-
-let ids = ref 0
-let new_id () = incr ids; !ids
-
-type transaction = int
-
-(* [transaction f]: transactional execution
- * [f] should take in a unique id, which it can use to `setCommitAction',
- * and returns a thread.
- * When the thread finishes execution, the committing action associated with
- * [id] is invoked.
- *)
-let transaction (f: int -> unit Lwt.t): unit Lwt.t =
-  let id = new_id () in
-  Lwt.catch
-    (fun () ->
-       f id >>= (fun () ->
-       softCommit id))
-    (fun exn ->
-       match exn with
-         Util.Transient _ ->
-           rollBack id >>= (fun () ->
-           Lwt.fail exn)
-       | _ ->
-           Lwt.fail exn)
 
 (*****************************************************************************)
 (*                               Archive locking                             *)
@@ -922,9 +846,9 @@ let doArchiveCrashRecovery () =
    returns [(ar, result)], then update archive with [ar] at [rest] and
    return [result]. *)
 let rec updatePathInArchive archive fspath
-    (here: Path.local) (rest: Path.t)
-    (action: archive -> Fspath.t -> Path.local -> archive * 'c):
-    archive * 'c
+    (here: Path.local) (rest: 'a Path.path)
+    (action: archive -> Path.local -> archive):
+    archive
     =
   debugverbose
     (fun() ->
@@ -933,7 +857,7 @@ let rec updatePathInArchive archive fspath
         (Path.toString here) (Path.toString rest));
   match Path.deconstruct rest with
     None ->
-      action archive fspath here
+      action archive here
   | Some(name, rest') ->
       let (desc, name', child, otherChildren) =
         match archive with
@@ -949,13 +873,13 @@ let rec updatePathInArchive archive fspath
       match
         updatePathInArchive child fspath (Path.child here name') rest' action
       with
-        NoArchive, res ->
-          if otherChildren = NameMap.empty && desc == Props.dummy then
-            NoArchive, res
+        NoArchive ->
+          if NameMap.is_empty otherChildren && desc == Props.dummy then
+            NoArchive
           else
-            ArchiveDir (desc, otherChildren), res
-      | child, res ->
-          ArchiveDir (desc, NameMap.add name' child otherChildren), res
+            ArchiveDir (desc, otherChildren)
+      | child ->
+          ArchiveDir (desc, NameMap.add name' child otherChildren)
 
 (*************************************************************************)
 (*                  Extract of a part of a archive                       *)
@@ -1782,33 +1706,14 @@ let rec stripArchive path arch =
   | ArchiveSymlink _ | NoArchive ->
       arch
 
-let updateArchiveLocal fspath path ui id =
+let updateArchive fspath path ui =
   debug (fun() ->
-    Util.msg "updateArchiveLocal %s %s\n"
+    Util.msg "updateArchive %s %s\n"
       (Fspath.toDebugString fspath) (Path.toString path));
   let root = thisRootsGlobalName fspath in
   let archive = getArchive root in
-  let (localPath, subArch) = getPathInArchive archive Path.empty path in
-  let newArch = updateArchiveRec ui (stripArchive path subArch) in
-  let commit () =
-    let archive = getArchive root in
-    let archive, () =
-      updatePathInArchive archive fspath Path.empty path
-        (fun _ _ _ -> newArch, ()) in
-    setArchiveLocal root archive in
-  setCommitAction root id commit;
-  debug (fun() ->
-    Util.msg "updateArchiveLocal --> %s\n" (Path.toString localPath));
-  (localPath, newArch)
-
-let updateArchiveOnRoot =
-  Remote.registerRootCmd
-    "updateArchive"
-    (fun (fspath, (path, ui, id)) ->
-       Lwt.return (updateArchiveLocal fspath path ui id))
-
-let updateArchive root path ui id =
-  updateArchiveOnRoot root (path, ui, id)
+  let (_, subArch) = getPathInArchive archive Path.empty path in
+  updateArchiveRec ui (stripArchive path subArch)
 
 (* This function is called for files changed only in identical ways.
    It only updates the archives and perhaps makes backups. *)
@@ -1820,13 +1725,12 @@ let markEqualLocal fspath paths =
        debug (fun() ->
          Util.msg "markEqualLocal %s %s\n"
            (Fspath.toDebugString fspath) (Path.toString path));
-       let arch, (subArch, localPath) =
+       let arch =
          updatePathInArchive !archive fspath Path.empty path
-           (fun archive _ localPath ->
-              let arch = updateArchiveRec (Updates (uc, New)) archive in
-              arch, (arch, localPath))
+           (fun archive localPath ->
+              Stasher.stashCurrentVersion fspath localPath None;
+              updateArchiveRec (Updates (uc, New)) archive)
        in
-       Stasher.stashCurrentVersion fspath localPath None;
        archive := arch);
   setArchiveLocal root !archive
 
@@ -1845,34 +1749,27 @@ let markEqual equals =
           Tree.map (fun n -> n) (fun (uc1,uc2) -> uc2) equals])
   end
 
-let replaceArchiveLocal fspath pathTo arch id =
+let replaceArchiveLocal fspath path newArch =
   debug (fun() -> Util.msg
              "replaceArchiveLocal %s %s\n"
              (Fspath.toDebugString fspath)
-             (Path.toString pathTo)
+             (Path.toString path)
         );
   let root = thisRootsGlobalName fspath in
-  let localPath = translatePathLocal fspath pathTo in
-  let commit () =
-    debug (fun() -> Util.msg "replaceArchiveLocal: committing\n");
-    let archive = getArchive root in
-    let archive, () =
-      updatePathInArchive archive fspath Path.empty pathTo
-        (fun _ _ _ -> arch, ())
-    in
-    setArchiveLocal root archive
-  in
-  setCommitAction root id commit;
-  localPath
+  let archive = getArchive root in
+  let archive =
+    updatePathInArchive archive fspath Path.empty path (fun _ _ -> newArch) in
+  setArchiveLocal root archive
 
 let replaceArchiveOnRoot =
   Remote.registerRootCmd
     "replaceArchive"
-    (fun (fspath, (pathTo, arch, id)) ->
-       Lwt.return (replaceArchiveLocal fspath pathTo arch id))
+    (fun (fspath, (pathTo, arch)) ->
+       replaceArchiveLocal fspath pathTo arch;
+       Lwt.return ())
 
-let replaceArchive root pathTo archive id =
-  replaceArchiveOnRoot root (pathTo, archive, id)
+let replaceArchive root pathTo archive =
+  replaceArchiveOnRoot root (pathTo, archive)
 
 (* Update the archive to reflect
       - the last observed state of the file on disk (ui)
@@ -1912,37 +1809,24 @@ let doUpdateProps arch propOpt ui =
       end
   | None -> newArch
 
-let updatePropsLocal fspath path propOpt ui id =
+let updateProps fspath path propOpt ui =
   debug (fun() ->
-    Util.msg "updatePropsLocal %s %s\n"
+    Util.msg "updateProps %s %s\n"
       (Fspath.toDebugString fspath) (Path.toString path));
   let root = thisRootsGlobalName fspath in
-  let commit () =
-    let archive = getArchive root in
-    let archive, () =
-      updatePathInArchive archive fspath Path.empty path
-        (fun arch _ _ -> doUpdateProps arch propOpt ui, ()) in
-    setArchiveLocal root archive in
-  setCommitAction root id commit;
-  let localPath = translatePathLocal fspath path in
-  localPath
-
-let updatePropsOnRoot =
-  Remote.registerRootCmd
-   "updateProps"
-     (fun (fspath, (path, propOpt, ui, id)) ->
-        Lwt.return (updatePropsLocal fspath path propOpt ui id))
-
-let updateProps root path propOpt ui id =
-   updatePropsOnRoot root (path, propOpt, ui, id)
+  let archive = getArchive root in
+  let archive =
+    updatePathInArchive archive fspath Path.empty path
+      (fun arch _ -> doUpdateProps arch propOpt ui) in
+  setArchiveLocal root archive
 
 (*************************************************************************)
 (*                  Make sure no change has happened                     *)
 (*************************************************************************)
 
-let checkNoUpdatesLocal fspath pathInArchive ui =
+let checkNoUpdates fspath pathInArchive ui =
   debug (fun() ->
-    Util.msg "checkNoUpdatesLocal %s %s\n"
+    Util.msg "checkNoUpdates %s %s\n"
       (Fspath.toDebugString fspath) (Path.toString pathInArchive));
   let archive = getArchive (thisRootsGlobalName fspath) in
   let (localPath, archive) =
@@ -1959,12 +1843,3 @@ let checkNoUpdatesLocal fspath pathInArchive ui =
                 "  (if this happens repeatedly on a file that has not been changed, \n"
               ^ "  try running once with 'fastcheck' set to false)"
               else "")))
-
-let checkNoUpdatesOnRoot =
-  Remote.registerRootCmd
-    "checkNoUpdates"
-    (fun (fspath, (pathInArchive, ui)) ->
-       Lwt.return (checkNoUpdatesLocal fspath pathInArchive ui))
-
-let checkNoUpdates root pathInArchive ui =
-  checkNoUpdatesOnRoot root (pathInArchive, ui)
diff --git a/src/update.mli b/src/update.mli
index 236ba95..b45e9f8 100644
--- a/src/update.mli
+++ b/src/update.mli
@@ -29,27 +29,17 @@ val findUpdates :
 val markEqual :
   (Name.t, Common.updateContent * Common.updateContent) Tree.t -> unit
 
-(* Commit in memory the last archive updates, or rollback if an exception is
-   raised.  A commit function must have been specified on both sides before
-   finishing the transaction. *)
-type transaction
-val transaction : (transaction -> unit Lwt.t) -> unit Lwt.t
-
-(* Update a part of an archive *)
-val updateArchive :
-  Common.root -> Path.t -> Common.updateItem -> transaction ->
-  (Path.local * archive) Lwt.t
+(* Get and update a part of an archive (the archive remains unchanged) *)
+val updateArchive : Fspath.t -> Path.local -> Common.updateItem -> archive
 (* Replace a part of an archive by another archive *)
-val replaceArchive :
-  Common.root -> Path.t -> archive -> transaction -> Path.local Lwt.t
+val replaceArchive : Common.root -> Path.t -> archive -> unit Lwt.t
+val replaceArchiveLocal : Fspath.t -> Path.local -> archive -> unit
 (* Update only some permissions *)
 val updateProps :
-  Common.root -> Path.t -> Props.t option -> Common.updateItem ->
-  transaction -> Path.local Lwt.t
+  Fspath.t -> 'a Path.path -> Props.t option -> Common.updateItem -> unit
 
 (* Check that no updates has taken place in a given place of the filesystem *)
-val checkNoUpdates :
- Common.root -> Path.t -> Common.updateItem -> unit Lwt.t
+val checkNoUpdates : Fspath.t -> Path.local -> Common.updateItem -> unit
 
 (* Save to disk the archive updates *)
 val commitUpdates : unit -> unit