[Unison-hackers] [unison-svn] r360 - trunk/src
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Fri Jun 19 11:44:18 EDT 2009
Author: vouillon
Date: 2009-06-19 11:44:15 -0400 (Fri, 19 Jun 2009)
New Revision: 360
Modified:
trunk/src/RECENTNEWS
trunk/src/abort.ml
trunk/src/abort.mli
trunk/src/copy.ml
trunk/src/files.ml
trunk/src/mkProjectInfo.ml
trunk/src/transport.ml
trunk/src/uigtk2.ml
trunk/src/update.ml
trunk/src/update.mli
Log:
* 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.
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/RECENTNEWS 2009-06-19 15:44:15 UTC (rev 360)
@@ -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
Modified: trunk/src/abort.ml
===================================================================
--- trunk/src/abort.ml 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/abort.ml 2009-06-19 15:44:15 UTC (rev 360)
@@ -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 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
Modified: trunk/src/abort.mli
===================================================================
--- trunk/src/abort.mli 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/abort.mli 2009-06-19 15:44:15 UTC (rev 360)
@@ -13,8 +13,3 @@
(* 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
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/copy.ml 2009-06-19 15:44:15 UTC (rev 360)
@@ -127,23 +127,31 @@
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 @@
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 @@
(****)
-(* 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 @@
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 @@
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 @@
(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 @@
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 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 @@
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 @@
(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 @@
"%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 @@
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 @@
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 @@
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)
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/files.ml 2009-06-19 15:44:15 UTC (rev 360)
@@ -69,74 +69,78 @@
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 =
+
+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
- "setProp"
- (fun (fspath, (workingDir, path, kind, newDesc)) ->
- Fileinfo.set workingDir path kind newDesc;
- Lwt.return ())
-
-let setPropRemote2 =
- 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 @@
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 @@
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 @@
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 @@
| _ -> 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 @@
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 @@
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 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 @@
(* 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 @@
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 @@
(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 @@
(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 _ ->
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/mkProjectInfo.ml 2009-06-19 15:44:15 UTC (rev 360)
@@ -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 @@
+
Modified: trunk/src/transport.ml
===================================================================
--- trunk/src/transport.ml 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/transport.ml 2009-06-19 15:44:15 UTC (rev 360)
@@ -75,16 +75,6 @@
(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 @@
("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 @@
("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));
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/uigtk2.ml 2009-06-19 15:44:15 UTC (rev 360)
@@ -1625,7 +1625,8 @@
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
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/update.ml 2009-06-19 15:44:15 UTC (rev 360)
@@ -470,9 +470,6 @@
(* 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,80 +636,7 @@
>>= (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 @@
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 @@
(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 @@
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,34 +1706,15 @@
| 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 (_, subArch) = getPathInArchive archive Path.empty path in
+ updateArchiveRec ui (stripArchive path subArch)
-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)
-
(* This function is called for files changed only in identical ways.
It only updates the archives and perhaps makes backups. *)
let markEqualLocal fspath paths =
@@ -1820,13 +1725,12 @@
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 @@
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 @@
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 archive = getArchive root in
+ let archive =
+ updatePathInArchive archive fspath Path.empty path
+ (fun arch _ -> doUpdateProps arch propOpt ui) in
+ setArchiveLocal root archive
-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)
-
(*************************************************************************)
(* 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 @@
" (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)
Modified: trunk/src/update.mli
===================================================================
--- trunk/src/update.mli 2009-06-19 14:13:03 UTC (rev 359)
+++ trunk/src/update.mli 2009-06-19 15:44:15 UTC (rev 360)
@@ -29,27 +29,17 @@
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
More information about the Unison-hackers
mailing list