summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/RECENTNEWS53
-rw-r--r--src/common.ml5
-rw-r--r--src/common.mli5
-rw-r--r--src/copy.ml95
-rw-r--r--src/fileinfo.ml48
-rw-r--r--src/fileinfo.mli4
-rw-r--r--src/files.ml45
-rw-r--r--src/files.mli2
-rw-r--r--src/globals.ml6
-rw-r--r--src/mkProjectInfo.ml7
-rw-r--r--src/path.ml4
-rw-r--r--src/path.mli4
-rw-r--r--src/props.ml8
-rw-r--r--src/recon.ml80
-rw-r--r--src/recon.mli3
-rw-r--r--src/remote.ml35
-rw-r--r--src/remote.mli6
-rw-r--r--src/transfer.ml198
-rw-r--r--src/transfer.mli9
-rw-r--r--src/transport.ml7
-rw-r--r--src/ubase/prefs.ml65
-rw-r--r--src/ubase/prefs.mli6
-rw-r--r--src/uicommon.ml11
-rw-r--r--src/uigtk2.ml222
-rw-r--r--src/uimacbridge.ml14
-rw-r--r--src/uitext.ml7
-rw-r--r--src/update.ml139
-rw-r--r--src/update.mli3
28 files changed, 718 insertions, 373 deletions
diff --git a/src/RECENTNEWS b/src/RECENTNEWS
index 12abdcf..376323e 100644
--- a/src/RECENTNEWS
+++ b/src/RECENTNEWS
@@ -1,3 +1,56 @@
+CHANGES FROM VERSION 2.37.1
+
+* Bumped version number: incompatible protocol changes
+
+* Create parent directories (with correct permissions) during
+ transport for paths which point to non-existent locations in the
+ destination replica.
+* Keep track of which file contents are being transferred, and delay
+ the transfer of a file when another file with the same contents is
+ currently being transferred. This way, the second transfer can be
+ skipped and replaced by a local copy.
+* Changes to the implementation of the rsync algorithm:
+ - use longer blocks for large files (the size of a block is the
+ square root of the size of the file for large files);
+ - transmit less checksum information per block (we still have less
+ than one chance in a hundred million of transferring a file
+ incorrectly, and Unison will catch any transfer error when
+ fingerprinting the whole file)
+ - avoid transfer overhead (which was 4 bytes per block)
+ For a 1G file, the first optimization saves a factor 50 on the
+ amount of data transferred from the target to the source (blocks
+ are 32768 bytes rather than just 700 bytes). The two other
+ optimizations save another factor of 2 (from 24 bytes per block
+ down to 10).
+
+* New "links" preference. When set to false, Unison will report an
+ error on symlinks during update detection. (This is the default
+ when one host is running Windows but not Cygwin.) This is better
+ than failing during propagation.
+* Added a preference "halfduplex" to force half-duplex communication
+ with the server. This may be useful on unreliable links (as a more
+ efficient alternative to "maxthreads = 1").
+* Renamed preference "pretendwin" to "ignoreinodenumbers" (an alias is
+ kept for backwards compatibility).
+* GTK UI: display estimated remaining time and transfer rate on the
+ progress bar
+* GTK UI: some polishing; in particular:
+ - stop statistics window updates when idle (save power on laptops)
+ - some ok and cancel buttons were in the wrong order
+
+* Added some support for making it easier to extend Unison without
+ breaking backwards compatibility.
+ - Possibility to mark a preference as local. Such a preference is
+ propagated if possible but will not result in an error if it is
+ not found server-side. This make it possible to add new
+ functionalities client-side without breaking compatibility.
+ - Added a function [Remove.commandAvailable] which tests whether a
+ command is available on a given root.
+* Removed hack in findUpdates that would update the archive in a
+ visible way for the sake of path translation: it is no longer
+ needed.
+
+-------------------------------
CHANGES FROM VERSION 2.36.-27
* Performance improvement in Xferhint module.
diff --git a/src/common.ml b/src/common.ml
index 4f79e8e..2efdae5 100644
--- a/src/common.ml
+++ b/src/common.ml
@@ -112,9 +112,10 @@ type status =
type replicaContent =
{ typ : Fileinfo.typ;
status : status;
- desc : Props.t;
+ desc : Props.t; (* Properties (for the UI) *)
ui : updateItem;
- size : int * Uutil.Filesize.t }
+ size : int * Uutil.Filesize.t; (* Number of items and size *)
+ props : Props.t list } (* Parent properties *)
type direction =
Conflict
diff --git a/src/common.mli b/src/common.mli
index 9cef032..52e0ee5 100644
--- a/src/common.mli
+++ b/src/common.mli
@@ -90,9 +90,10 @@ type status =
type replicaContent =
{ typ : Fileinfo.typ;
status : status;
- desc : Props.t;
+ desc : Props.t; (* Properties (for the UI) *)
ui : updateItem;
- size : int * Uutil.Filesize.t }
+ size : int * Uutil.Filesize.t; (* Number of items and size *)
+ props : Props.t list } (* Parent properties *)
type direction =
Conflict
diff --git a/src/copy.ml b/src/copy.ml
index ed41e2b..a9c9a9d 100644
--- a/src/copy.ml
+++ b/src/copy.ml
@@ -409,9 +409,9 @@ let destinationFd fspath path kind len outfd id =
fd
let rsyncReg = Lwt_util.make_region (40 * 1024)
-let rsyncThrottle useRsync sz f =
+let rsyncThrottle useRsync srcFileSize destFileSize f =
if not useRsync then f () else
- let l = Transfer.Rsync.memoryFootprint sz in
+ let l = Transfer.Rsync.memoryFootprint srcFileSize destFileSize in
Lwt_util.run_in_region rsyncReg l f
let transferFileContents
@@ -440,15 +440,17 @@ let transferFileContents
&&
Transfer.Rsync.aboveRsyncThreshold srcFileSize
in
- rsyncThrottle useRsync destFileSize (fun () ->
+ rsyncThrottle useRsync srcFileSize destFileSize (fun () ->
let (bi, decompr) =
if useRsync then
Util.convertUnixErrorsToTransient
"preprocessing file"
(fun () ->
let ifd = openFileIn fspathTo realPathTo fileKind in
- let bi =
- protect (fun () -> Transfer.Rsync.rsyncPreprocess ifd)
+ let (bi, blockSize) =
+ protect
+ (fun () -> Transfer.Rsync.rsyncPreprocess
+ ifd srcFileSize destFileSize)
(fun () -> close_in_noerr ifd)
in
infd := Some ifd;
@@ -459,7 +461,7 @@ let transferFileContents
destinationFd
fspathTo pathTo fileKind srcFileSize outfd id in
let eof =
- Transfer.Rsync.rsyncDecompress ifd fd showProgress ti
+ Transfer.Rsync.rsyncDecompress blockSize ifd fd showProgress ti
in
if eof then begin close_out fd; outfd := None end))
else
@@ -523,6 +525,48 @@ let reallyTransferFile
(****)
+let filesBeingTransferred = Hashtbl.create 17
+
+let wakeupNextTransfer fp =
+ match
+ try
+ Some (Queue.take (Hashtbl.find filesBeingTransferred fp))
+ with Queue.Empty ->
+ None
+ with
+ None ->
+ Hashtbl.remove filesBeingTransferred fp
+ | Some next ->
+ Lwt.wakeup next ()
+
+let executeTransfer fp f =
+ Lwt.try_bind f
+ (fun res -> wakeupNextTransfer fp; Lwt.return res)
+ (fun e -> wakeupNextTransfer fp; Lwt.fail e)
+
+(* Keep track of which file contents are being transferred, and delay
+ the transfer of a file with the same contents as another file being
+ currently transferred. This way, the second transfer can be
+ skipped and replaced by a local copy. *)
+let rec registerFileTransfer pathTo fp f =
+ if not (Prefs.read Xferhint.xferbycopying) then f () else
+ match
+ try Some (Hashtbl.find filesBeingTransferred fp) with Not_found -> None
+ with
+ None ->
+ let q = Queue.create () in
+ Hashtbl.add filesBeingTransferred fp q;
+ executeTransfer fp f
+ | Some q ->
+ debug (fun () -> Util.msg "delaying tranfer of file %s\n"
+ (Path.toString pathTo));
+ let res = Lwt.wait () in
+ Queue.push res q;
+ res >>= fun () ->
+ executeTransfer fp f
+
+(****)
+
let copyprog =
Prefs.createString "copyprog" "rsync --inplace --compress"
"!external program for copying large files"
@@ -631,7 +675,6 @@ let finishExternalTransferLocal connFrom
Xferhint.insertEntry fspathTo pathTo fp;
Lwt.return res
-
let finishExternalTransferOnRoot =
Remote.registerRootCmdWithConnection
"finishExternalTransfer" finishExternalTransferLocal
@@ -676,6 +719,8 @@ let transferFileUsingExternalCopyprog
(snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo,
update, desc, fp, ress, id)
+(****)
+
let transferFileLocal connFrom
(fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
update, desc, fp, ress, id) =
@@ -695,23 +740,25 @@ let transferFileLocal connFrom
Xferhint.insertEntry fspathTo pathTo fp;
Lwt.return (`DONE (Success info, Some msg))
end else
- match
- tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id
- with
- Some (info, msg) ->
- (* Transfer was performed by copying *)
- Xferhint.insertEntry fspathTo pathTo fp;
- Lwt.return (`DONE (Success info, Some msg))
- | None ->
- if shouldUseExternalCopyprog update desc then
- Lwt.return (`EXTERNAL (prepareExternalTransfer fspathTo pathTo))
- else begin
- reallyTransferFile
- connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
- update desc fp ress id >>= fun status ->
- Xferhint.insertEntry fspathTo pathTo fp;
- Lwt.return (`DONE (status, None))
- end
+ registerFileTransfer pathTo fp
+ (fun () ->
+ match
+ tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id
+ with
+ Some (info, msg) ->
+ (* Transfer was performed by copying *)
+ Xferhint.insertEntry fspathTo pathTo fp;
+ Lwt.return (`DONE (Success info, Some msg))
+ | None ->
+ if shouldUseExternalCopyprog update desc then
+ Lwt.return (`EXTERNAL (prepareExternalTransfer fspathTo pathTo))
+ else begin
+ reallyTransferFile
+ connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
+ update desc fp ress id >>= fun status ->
+ Xferhint.insertEntry fspathTo pathTo fp;
+ Lwt.return (`DONE (status, None))
+ end)
let transferFileOnRoot =
Remote.registerRootCmdWithConnection "transferFile" transferFileLocal
diff --git a/src/fileinfo.ml b/src/fileinfo.ml
index f8f9685..779632c 100644
--- a/src/fileinfo.ml
+++ b/src/fileinfo.ml
@@ -18,6 +18,28 @@
let debugV = Util.debug "fileinfo+"
+let allowSymlinks =
+ Prefs.createString "links" "default"
+ "allow the synchronization of symbolic links (true/false/default)"
+ ("When set to {\\tt true}, this flag causes Unison to synchronize \
+ symbolic links. When the flag is set to {\\tt false}, symbolic \
+ links will result in an error during update detection. \
+ Ordinarily, when the flag is set to {\\tt default}, symbolic \
+ links are synchronized except when one of the hosts is running \
+ Windows. In rare circumstances it is useful to set the flag \
+ manually (e.g. when running Unison on a Unix system with a FAT \
+ [Windows] volume mounted).")
+
+let symlinksAllowed =
+ Prefs.createBool "links-aux" true
+ "*Pseudo-preference for internal use only" ""
+
+let init b =
+ Prefs.set symlinksAllowed
+ (Prefs.read allowSymlinks = "yes" ||
+ Prefs.read allowSymlinks = "true" ||
+ (Prefs.read allowSymlinks = "default" && not b))
+
type typ = [ `ABSENT | `FILE | `DIRECTORY | `SYMLINK ]
let type2string = function
@@ -58,7 +80,14 @@ let get fromRoot fspath path =
match stats.Unix.LargeFile.st_kind with
Unix.S_REG -> `FILE
| Unix.S_DIR -> `DIRECTORY
- | Unix.S_LNK -> `SYMLINK
+ | Unix.S_LNK ->
+ if not fromRoot || Prefs.read symlinksAllowed then
+ `SYMLINK
+ else
+ raise
+ (Util.Transient
+ (Format.sprintf "path %s is a symbolic link"
+ (Fspath.toPrintString (Fspath.concat fspath path))))
| _ ->
raise (Util.Transient
("path " ^
@@ -121,15 +150,16 @@ type stamp =
probably not use any stamp under Windows. *)
let pretendLocalOSIsWin32 =
- Prefs.createBool "pretendwin" false
+ Prefs.createBool "ignoreinodenumbers" false
"!Use creation times for detecting updates"
- ("When set to true, this preference makes Unison use Windows-style "
- ^ "fast update detection (using file creation times as "
- ^ "``pseudo-inode-numbers''), even when running on a Unix system. This "
- ^ "switch should be used with care, as it is less safe than the standard "
- ^ "update detection method, but it can be useful for synchronizing VFAT "
- ^ "filesystems (which do not support inode numbers) mounted on Unix "
- ^ "systems. The {\\tt fastcheck} option should also be set to true.")
+ ("When set to true, this preference makes Unison not take advantage \
+ of inode numbers during fast update detection even when running \
+ on a Unix system. This switch should be used with care, as it \
+ is less safe than the standard update detection method, but it \
+ can be useful for synchronizing VFAT filesystems (which do not \
+ support inode numbers) mounted on Unix systems. \
+ The {\\tt fastcheck} option should also be set to true.")
+let _ = Prefs.alias pretendLocalOSIsWin32 "pretendwin"
let stamp info =
(* Was "CtimeStamp info.ctime", but this is bogus: Windows
diff --git a/src/fileinfo.mli b/src/fileinfo.mli
index 1f72cd4..bf359df 100644
--- a/src/fileinfo.mli
+++ b/src/fileinfo.mli
@@ -23,3 +23,7 @@ val ressStamp : t -> Osx.ressStamp
(* Check whether a file is unchanged *)
val unchanged : Fspath.t -> Path.local -> t -> (t * bool * bool)
+
+(****)
+
+val init : bool -> unit
diff --git a/src/files.ml b/src/files.ml
index ee27b4e..a034400 100644
--- a/src/files.ml
+++ b/src/files.ml
@@ -319,6 +319,36 @@ let setupTargetPathsLocal (fspath, path) =
let setupTargetPaths =
Remote.registerRootCmd "setupTargetPaths" setupTargetPathsLocal
+let rec createDirectories fspath localPath props =
+ match props with
+ [] ->
+ ()
+ | desc :: rem ->
+ match Path.deconstructRev localPath with
+ None ->
+ assert false
+ | Some (_, parentPath) ->
+ createDirectories fspath parentPath rem;
+ try
+ let absolutePath = Fspath.concat fspath parentPath in
+ Fs.mkdir absolutePath (Props.perms desc)
+ (* The directory may have already been created
+ if there are several paths with the same prefix *)
+ with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
+
+let setupTargetPathsAndCreateParentDirectoryLocal (fspath, (path, props)) =
+ let localPath = Update.translatePathLocal fspath path in
+ Util.convertUnixErrorsToTransient
+ "creating parent directories"
+ (fun () -> createDirectories fspath localPath props);
+ let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in
+ let tempPath = Os.tempPath ~fresh:false workingDir realPath in
+ Lwt.return (workingDir, realPath, tempPath, localPath)
+
+let setupTargetPathsAndCreateParentDirectory =
+ Remote.registerRootCmd "setupTargetPathsAndCreateParentDirectory"
+ setupTargetPathsAndCreateParentDirectoryLocal
+
(* ------------------------------------------------------------ *)
let updateSourceArchiveLocal (fspathFrom, (localPathFrom, uiFrom, errPaths)) =
@@ -376,6 +406,15 @@ let deleteSpuriousChildrenLocal (_, (fspathTo, pathTo, archChildren)) =
let deleteSpuriousChildren =
Remote.registerRootCmd "deleteSpuriousChildren" deleteSpuriousChildrenLocal
+let rec normalizePropsRec propsFrom propsTo =
+ match propsFrom, propsTo with
+ d :: r, d' :: r' -> normalizePropsRec r r'
+ | _, [] -> propsFrom
+ | [], _ :: _ -> assert false
+
+let normalizeProps propsFrom propsTo =
+ normalizePropsRec (Safelist.rev propsFrom) (Safelist.rev propsTo)
+
(* ------------------------------------------------------------ *)
let copyReg = Lwt_util.make_region 50
@@ -385,10 +424,13 @@ let copy
rootFrom pathFrom (* copy from here... *)
uiFrom (* (and then check that this updateItem still
describes the current state of the src replica) *)
+ propsFrom (* the properties of the parent directories, in
+ case we need to propagate them *)
rootTo pathTo (* ...to here *)
uiTo (* (but, before committing the copy, check that
this updateItem still describes the current
state of the target replica) *)
+ propsTo (* the properties of the parent directories *)
id = (* for progress display *)
debug (fun() ->
Util.msg
@@ -396,7 +438,8 @@ let copy
(root2string rootFrom) (Path.toString pathFrom)
(root2string rootTo) (Path.toString pathTo));
(* Calculate target paths *)
- setupTargetPaths rootTo pathTo
+ setupTargetPathsAndCreateParentDirectory rootTo
+ (pathTo, normalizeProps propsFrom propsTo)
>>= fun (workingDir, realPathTo, tempPathTo, localPathTo) ->
(* When in Unicode case-insensitive mode, we want to create files
with NFC normal-form filenames. *)
diff --git a/src/files.mli b/src/files.mli
index e3ba168..f43ee49 100644
--- a/src/files.mli
+++ b/src/files.mli
@@ -26,9 +26,11 @@ val copy :
-> Common.root (* from what root *)
-> Path.t (* from what path *)
-> Common.updateItem (* source updates *)
+ -> Props.t list (* properties of parent directories *)
-> Common.root (* to what root *)
-> Path.t (* to what path *)
-> Common.updateItem (* dest. updates *)
+ -> Props.t list (* properties of parent directories *)
-> Uutil.File.t (* id for showing progress of transfer *)
-> unit Lwt.t
diff --git a/src/globals.ml b/src/globals.ml
index 6a26118..ff87958 100644
--- a/src/globals.ml
+++ b/src/globals.ml
@@ -162,7 +162,7 @@ let paths =
(* FIX: this does weird things in case-insensitive mode... *)
let globPath lr p =
- let p = Path.magic p in
+ let p = Path.forceLocal p in
debug (fun() ->
Util.msg "Checking path '%s' for expansions\n"
(Path.toDebugString p) );
@@ -175,10 +175,10 @@ let globPath lr p =
(Path.toString p)
"but first root (after canonizing) is non-local"))
| Some lrfspath ->
- Safelist.map (fun c -> Path.magic' (Path.child parent c))
+ Safelist.map (fun c -> Path.makeGlobal (Path.child parent c))
(Os.childrenOf lrfspath parent)
end
- | _ -> [Path.magic' p]
+ | _ -> [Path.makeGlobal p]
let expandWildcardPaths() =
let lr =
diff --git a/src/mkProjectInfo.ml b/src/mkProjectInfo.ml
index 6cd5ebd..6fee922 100644
--- a/src/mkProjectInfo.ml
+++ b/src/mkProjectInfo.ml
@@ -5,8 +5,8 @@
let projectName = "unison"
let majorVersion = 2
-let minorVersion = 36
-let pointVersionOrigin = 359 (* Revision that corresponds to point version 0 *)
+let minorVersion = 37
+let pointVersionOrigin = 377 (* Revision that corresponds to point version 0 *)
(* Documentation:
This is a program to construct a version of the form Major.Minor.Point,
@@ -65,7 +65,7 @@ let extract_str re str =
Str.matched_group 1 str;;
let extract_int re str = int_of_string (extract_str re str);;
-let revisionString = "$Rev: 332$";;
+let revisionString = "$Rev: 378$";;
let pointVersion = if String.length revisionString > 5
then Scanf.sscanf revisionString "$Rev: %d " (fun x -> x) - pointVersionOrigin
else (* Determining the pointVersionOrigin in bzr is kind of tricky:
@@ -96,3 +96,4 @@ Printf.printf "NAME=%s\n" projectName;;
+
diff --git a/src/path.ml b/src/path.ml
index 2a803c5..374c4d4 100644
--- a/src/path.ml
+++ b/src/path.ml
@@ -207,5 +207,5 @@ let followLink path =
(Util.osType = `Unix || Util.isCygwin)
&& Pred.test followPred (toString path)
-let magic p = p
-let magic' p = p
+let forceLocal p = p
+let makeGlobal p = p
diff --git a/src/path.mli b/src/path.mli
index 631b817..9a25e60 100644
--- a/src/path.mli
+++ b/src/path.mli
@@ -36,5 +36,5 @@ val hash : local -> int
val followLink : local -> bool
val followPred : Pred.t
-val magic : t -> local
-val magic' : local -> t
+val forceLocal : t -> local
+val makeGlobal : local -> t
diff --git a/src/props.ml b/src/props.ml
index 9bdfbda..b91afdb 100644
--- a/src/props.ml
+++ b/src/props.ml
@@ -146,7 +146,9 @@ let toString =
else
off
in
- bit 0o1000 "" "" "t" ^
+ bit 0o4000 "" "-" "S" ^
+ bit 0o2000 "" "-" "s" ^
+ bit 0o1000 "?" "" "t" ^
bit 0o0400 "?" "-" "r" ^
bit 0o0200 "?" "-" "w" ^
bit 0o0100 "?" "-" "x" ^
@@ -169,7 +171,9 @@ let syncedPartsToString =
else
off
in
- bit 0o1000 "" "" "t" ^
+ bit 0o4000 "" "-" "S" ^
+ bit 0o2000 "" "-" "s" ^
+ bit 0o1000 "?" "" "t" ^
bit 0o0400 "?" "-" "r" ^
bit 0o0200 "?" "-" "w" ^
bit 0o0100 "?" "-" "x" ^
diff --git a/src/recon.ml b/src/recon.ml
index 40281f5..f1f0391 100644
--- a/src/recon.ml
+++ b/src/recon.ml
@@ -247,44 +247,44 @@ let propagateErrors allowPartial (rplc: Common.replicas): Common.replicas =
type singleUpdate = Rep1Updated | Rep2Updated
-let update2replicaContent path (conflict: bool) ui ucNew oldType:
+let update2replicaContent path (conflict: bool) ui props ucNew oldType:
Common.replicaContent =
let size = Update.updateSize path ui in
match ucNew with
Absent ->
{typ = `ABSENT; status = `Deleted; desc = Props.dummy;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| File (desc, ContentsSame) ->
{typ = `FILE; status = `PropsChanged; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| File (desc, _) when oldType <> `FILE ->
{typ = `FILE; status = `Created; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| File (desc, ContentsUpdated _) ->
{typ = `FILE; status = `Modified; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Symlink l when oldType <> `SYMLINK ->
{typ = `SYMLINK; status = `Created; desc = Props.dummy;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Symlink l ->
{typ = `SYMLINK; status = `Modified; desc = Props.dummy;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Dir (desc, _, _, _) when oldType <> `DIRECTORY ->
{typ = `DIRECTORY; status = `Created; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Dir (desc, _, PropsUpdated, _) ->
{typ = `DIRECTORY; status = `PropsChanged; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Dir (desc, _, PropsSame, _) when conflict ->
(* Special case: the directory contents has been modified and the *)
(* directory is in conflict. (We don't want to display a conflict *)
(* between an unchanged directory and a file, for instance: this would *)
(* be rather puzzling to the user) *)
{typ = `DIRECTORY; status = `Modified; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Dir (desc, _, PropsSame, _) ->
{typ = `DIRECTORY; status = `Unchanged; desc =desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
let oldType (prev: Common.prevState): Fileinfo.typ =
match prev with
@@ -297,25 +297,26 @@ let oldDesc (prev: Common.prevState): Props.t =
| New -> Props.dummy
(* [describeUpdate ui] returns the replica contents for both the case of *)
-(* updating and the case of non-updatingd *)
-let describeUpdate path ui
+(* updating and the case of non-updating *)
+let describeUpdate path props' ui props
: Common.replicaContent * Common.replicaContent =
match ui with
Updates (ucNewStatus, prev) ->
let typ = oldType prev in
- (update2replicaContent path false ui ucNewStatus typ,
+ (update2replicaContent path false ui props ucNewStatus typ,
{typ = typ; status = `Unchanged; desc = oldDesc prev;
- ui = NoUpdates; size = Update.updateSize path NoUpdates})
+ ui = NoUpdates; size = Update.updateSize path NoUpdates;
+ props = props'})
| _ -> assert false
(* Computes the reconItems when only one side has been updated. (We split *)
(* this out into a separate function to avoid duplicating all the symmetric *)
(* cases.) *)
-let rec reconcileNoConflict allowPartial path ui whatIsUpdated
+let rec reconcileNoConflict allowPartial path props' ui props whatIsUpdated
(result: (Name.t * Name.t, Common.replicas) Tree.u)
: (Name.t * Name.t, Common.replicas) Tree.u =
let different() =
- let rcUpdated, rcNotUpdated = describeUpdate path ui in
+ let rcUpdated, rcNotUpdated = describeUpdate path props' ui props in
match whatIsUpdated with
Rep2Updated ->
Different {rc1 = rcNotUpdated; rc2 = rcUpdated;
@@ -340,7 +341,8 @@ let rec reconcileNoConflict allowPartial path ui whatIsUpdated
(fun result (theName, uiChild) ->
Tree.leave
(reconcileNoConflict allowPartial (Path.child path theName)
- uiChild whatIsUpdated (Tree.enter result (theName, theName))))
+ [] uiChild [] whatIsUpdated
+ (Tree.enter result (theName, theName))))
r children
| Updates _ ->
Tree.add result (propagateErrors allowPartial (different ()))
@@ -393,21 +395,26 @@ let add_equal (counter, archiveUpdated) equal v =
(* Tree.u *)
(* unequals: (Name.t * Name.t, Common.replicas) Tree.u *)
(* -- *)
-let rec reconcile allowPartial path ui1 ui2 counter (equals:(_*_,_)Tree.u) unequals =
+let rec reconcile
+ allowPartial path ui1 props1 ui2 props2 counter equals unequals =
let different uc1 uc2 oldType equals unequals =
(equals,
Tree.add unequals
(propagateErrors allowPartial
- (Different {rc1 = update2replicaContent path true ui1 uc1 oldType;
- rc2 = update2replicaContent path true ui2 uc2 oldType;
+ (Different {rc1 = update2replicaContent
+ path true ui1 props1 uc1 oldType;
+ rc2 = update2replicaContent
+ path true ui2 props2 uc2 oldType;
direction = Conflict; default_direction = Conflict;
errors1 = []; errors2 = []}))) in
let toBeMerged uc1 uc2 oldType equals unequals =
(equals,
Tree.add unequals
(propagateErrors allowPartial
- (Different {rc1 = update2replicaContent path true ui1 uc1 oldType;
- rc2 = update2replicaContent path true ui2 uc2 oldType;
+ (Different {rc1 = update2replicaContent
+ path true ui1 props1 uc1 oldType;
+ rc2 = update2replicaContent
+ path true ui2 props2 uc2 oldType;
direction = Merge; default_direction = Merge;
errors1 = []; errors2 = []}))) in
match (ui1, ui2) with
@@ -416,9 +423,13 @@ let rec reconcile allowPartial path ui1 ui2 counter (equals:(_*_,_)Tree.u) unequ
| (_, Error s) ->
(equals, Tree.add unequals (Problem s))
| (NoUpdates, _) ->
- (equals, reconcileNoConflict allowPartial path ui2 Rep2Updated unequals)
+ (equals,
+ reconcileNoConflict
+ allowPartial path props1 ui2 props2 Rep2Updated unequals)
| (_, NoUpdates) ->
- (equals, reconcileNoConflict allowPartial path ui1 Rep1Updated unequals)
+ (equals,
+ reconcileNoConflict
+ allowPartial path props2 ui1 props1 Rep1Updated unequals)
| (Updates (Absent, _), Updates (Absent, _)) ->
(add_equal counter equals (Absent, Absent), unequals)
| (Updates (Dir (desc1, children1, propsChanged1, _) as uc1, prevState1),
@@ -439,8 +450,8 @@ let rec reconcile allowPartial path ui1 ui2 counter (equals:(_*_,_)Tree.u) unequ
(equals,
Tree.add unequals
(Different
- {rc1 = update2replicaContent path false ui1 uc1 `DIRECTORY;
- rc2 = update2replicaContent path false ui2 uc2 `DIRECTORY;
+ {rc1 = update2replicaContent path false ui1 [] uc1 `DIRECTORY;
+ rc2 = update2replicaContent path false ui2 [] uc2 `DIRECTORY;
direction = action; default_direction = action;
errors1 = []; errors2 = []}))
in
@@ -448,7 +459,8 @@ let rec reconcile allowPartial path ui1 ui2 counter (equals:(_*_,_)Tree.u) unequ
Safelist.fold_left
(fun (equals, unequals) (name1,ui1,name2,ui2) ->
let (eq, uneq) =
- reconcile allowPartial (Path.child path name1) ui1 ui2 counter
+ reconcile
+ allowPartial (Path.child path name1) ui1 [] ui2 [] counter
(Tree.enter equals (name1, name2))
(Tree.enter unequals (name1, name2))
in
@@ -521,16 +533,22 @@ let dangerousPath u1 u2 =
(* file that is updated in the same way on both roots *)
let reconcileList allowPartial
(pathUpdatesList:
- (Path.t * Common.updateItem * Path.t * Common.updateItem) list)
+ ((Path.local * Common.updateItem * Props.t list) *
+ (Path.local * Common.updateItem * Props.t list)) list)
: Common.reconItem list * bool * Path.t list =
let counter = ref 0 in
let archiveUpdated = ref false in
let (equals, unequals, dangerous) =
Safelist.fold_left
- (fun (equals, unequals, dangerous) (path1,ui1,path2,ui2) ->
+ (fun (equals, unequals, dangerous)
+ ((path1,ui1,props1),(path2,ui2,props2)) ->
+ (* We make the paths global as we may concatenate them with
+ names from the other replica *)
+ let path1 = Path.makeGlobal path1 in
+ let path2 = Path.makeGlobal path2 in
let (equals, unequals) =
reconcile allowPartial
- path1 ui1 ui2 (counter, archiveUpdated)
+ path1 ui1 props1 ui2 props2 (counter, archiveUpdated)
(enterPath path1 path2 equals)
(enterPath path1 path2 unequals)
in
diff --git a/src/recon.mli b/src/recon.mli
index a924965..e8f3325 100644
--- a/src/recon.mli
+++ b/src/recon.mli
@@ -4,7 +4,8 @@
val reconcileAll :
?allowPartial:bool (* whether we allow partial synchronization
of directories (default to false) *)
- -> (Path.t * Common.updateItem * Path.t * Common.updateItem) list
+ -> ((Path.local * Common.updateItem * Props.t list) *
+ (Path.local * Common.updateItem * Props.t list)) list
(* one updateItem per replica, per path *)
-> Common.reconItem list (* List of updates that need propagated *)
* bool (* Any file updated equally on all roots*)
diff --git a/src/remote.ml b/src/remote.ml
index bbcbe53..8aa43a3 100644
--- a/src/remote.ml
+++ b/src/remote.ml
@@ -270,7 +270,6 @@ let allowWrites q =
to the requests to be processed *)
Lwt.ignore_result (Lwt_unix.yield () >>= fun () -> popOutputQueues q)
-
let disableFlowControl q =
q.flowControl <- false;
if not q.canWrite then allowWrites q
@@ -315,6 +314,7 @@ let maybeFlush receiver pendingFlush q buf =
flushBuffer buf
end else
flushBuffer buf) >>= fun () ->
+ assert (not (q.flowControl && q.canWrite));
(* Restart the reader thread if needed *)
match !receiver with
None -> Lwt.return ()
@@ -894,6 +894,10 @@ let registerStreamCmd
(fun e -> ping conn id >>= fun () -> Lwt.fail e)
end
+let commandAvailable =
+ registerRootCmd "commandAvailable"
+ (fun (_, cmdName) -> Lwt.return (Util.StringMap.mem cmdName !serverCmds))
+
(****************************************************************************
BUILDING CONNECTIONS TO THE SERVER
****************************************************************************)
@@ -933,6 +937,16 @@ let rec checkHeader conn buffer pos len =
Both hosts must use non-blocking I/O (otherwise a dead-lock is
possible with ssh).
*)
+let halfduplex =
+ Prefs.createBool "halfduplex" false
+ "!force half-duplex communication with the server"
+ "When this flag is set to {\\tt true}, Unison network communication \
+ is forced to be half duplex (the client and the server never \
+ simultaneously emit data). If you experience unstabilities with \
+ your network link, this may help. The communication is always \
+ half-duplex when synchronizing with a Windows machine due to a \
+ limitation of Unison current implementation that could result \
+ in a deadlock."
let negociateFlowControlLocal conn () =
if not needFlowControl then disableFlowControl conn.outputQueue;
@@ -942,14 +956,14 @@ let negociateFlowControlRemote =
registerServerCmd "negociateFlowControl" negociateFlowControlLocal
let negociateFlowControl conn =
- if not needFlowControl then
- negociateFlowControlRemote conn () >>= (fun needed ->
- if not needed then
- negociateFlowControlLocal conn () >>= (fun _ -> Lwt.return ())
- else
- Lwt.return ())
- else
- Lwt.return ()
+ (* Flow control negociation can be done asynchronously. *)
+ if not (needFlowControl || Prefs.read halfduplex) then
+ Lwt.ignore_result
+ (negociateFlowControlRemote conn () >>= fun needed ->
+ if not needed then
+ negociateFlowControlLocal conn ()
+ else
+ Lwt.return true)
(****)
@@ -960,8 +974,7 @@ let initConnection in_ch out_ch =
checkHeader
conn (Bytearray.create 1) 0 (String.length connectionHeader) >>= (fun () ->
Lwt.ignore_result (receive conn);
- (* Flow control negociation can be done asynchronously. *)
- Lwt.ignore_result (negociateFlowControl conn);
+ negociateFlowControl conn;
Lwt.return conn)
let inetAddr host =
diff --git a/src/remote.mli b/src/remote.mli
index 7b1ea9b..d2e3ac2 100644
--- a/src/remote.mli
+++ b/src/remote.mli
@@ -32,6 +32,12 @@ val registerRootCmd :
-> 'a (* additional arguments *)
-> 'b Lwt.t) (* -> (suspended) result *)
+(* Test whether a command exits on some root *)
+val commandAvailable :
+ Common.root -> (* root *)
+ string -> (* command name *)
+ bool Lwt.t
+
(* Enter "server mode", reading and processing commands from a remote
client process until killed *)
val beAServer : unit -> unit
diff --git a/src/transfer.ml b/src/transfer.ml
index 3f2bddb..7821eda 100644
--- a/src/transfer.ml
+++ b/src/transfer.ml
@@ -94,8 +94,7 @@ type token =
| EOF
(* Size of a block *)
-let blockSize = 700
-let blockSize64 = Int64.of_int blockSize
+let minBlockSize = 700
let maxQueueSize = 65500
let maxQueueSizeFS = Uutil.Filesize.ofInt maxQueueSize
@@ -105,15 +104,8 @@ type tokenQueue =
(* some informations about the
previous token *)
mutable pos : int; (* head of the queue *)
- mutable prog : int } (* the size of the data they represent *)
-
-(* Size of the data a token represents for the destination host,
- to keep track of the propagation progress *)
-let tokenProg t =
- match t with
- STRING (s, pos, len) -> String.length s
- | BLOCK n -> blockSize
- | EOF -> 0
+ mutable prog : int; (* the size of the data they represent *)
+ mutable bSize : int } (* block size *)
let encodeInt3 s pos i =
assert (i >= 0 && i < 256 * 256 * 256);
@@ -199,7 +191,7 @@ let pushBlock q id transmit pos =
encodeInt3 q.data (q.pos + 1) pos;
encodeInt1 q.data (q.pos + 4) 1;
q.pos <- q.pos + 5;
- q.prog <- q.prog + blockSize;
+ q.prog <- q.prog + q.bSize;
q.previous <- `Block (pos + 1);
return ())
@@ -209,7 +201,7 @@ let growBlock q id transmit pos =
assert (decodeInt3 q.data (q.pos - 4) + count = pos);
assert (count < 255);
encodeInt1 q.data (q.pos - 1) (count + 1);
- q.prog <- q.prog + blockSize;
+ q.prog <- q.prog + q.bSize;
q.previous <- if count = 254 then `None else `Block (pos + 1);
return ()
@@ -229,7 +221,7 @@ let queueToken q id transmit token =
| BLOCK pos, _ ->
pushBlock q id transmit pos
-let makeQueue length =
+let makeQueue length blockSize =
{ data =
(* We need to make sure here that the size of the queue is not
larger than 65538
@@ -237,7 +229,8 @@ let makeQueue length =
Bytearray.create
(if length > maxQueueSizeFS then maxQueueSize else
Uutil.Filesize.toInt length + 10);
- pos = 0; previous = `None; prog = 0 }
+ pos = 0; previous = `None; prog = 0;
+ bSize = blockSize }
(*************************************************************************)
(* GENERIC TRANSMISSION *)
@@ -252,7 +245,7 @@ let send infd length showProgress transmit =
let bufSz = 8192 in
let bufSzFS = Uutil.Filesize.ofInt 8192 in
let buf = String.create bufSz in
- let q = makeQueue length in
+ let q = makeQueue length 0 in
let rec sendSlice length =
let count =
reallyRead infd buf 0
@@ -303,75 +296,116 @@ struct
(* It is impossible to use rsync when the file size is smaller than
the size of a block *)
- let blockSizeFs = Uutil.Filesize.ofInt blockSize
- let aboveRsyncThreshold sz = sz >= blockSizeFs
+ let minBlockSizeFs = Uutil.Filesize.ofInt minBlockSize
+ let aboveRsyncThreshold sz = sz > minBlockSizeFs
(* The type of the info that will be sent to the source host *)
- type rsync_block_info = (Checksum.t * Digest.t) list
-
+ type rsync_block_info =
+ { blockSize : int;
+ blockCount : int;
+ checksumSize : int;
+ weakChecksum :
+ (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t;
+ strongChecksum : Bytearray.t }
(*** PREPROCESS ***)
- (* Preprocess buffer size *)
- let preproBufSize = 8192
+ (* Worst case probability of a failure *)
+ let logProba = -27. (* One time in 100 millions *)
+ (* Strength of the weak checksum
+ (how many bit of the weak checksum we can rely on) *)
+ let weakLen = 27.
+ (* This is what rsync uses:
+ let logProba = -10.
+ let weakLen = 31.
+ This would save almost 3 bytes per block, but one need to be able
+ to recover from an rsync error.
+ *)
+ (* Block size *)
+ let computeBlockSize l = truncate (max 700. (min (sqrt l) 131072.))
+ (* Size of each strong checksum *)
+ let checksumSize bs sl dl =
+ let bits =
+ -. logProba -. weakLen +. log (sl *. dl /. float bs) /. log 2. in
+ max 2 (min 16 (truncate ((bits +. 7.99) /. 8.)))
+
+ let sizes srcLength dstLength =
+ let blockSize = computeBlockSize (Uutil.Filesize.toFloat dstLength) in
+ let blockCount =
+ let count =
+ Int64.div (Uutil.Filesize.toInt64 dstLength) (Int64.of_int blockSize)
+ in
+ Int64.to_int (min 16777216L count)
+ in
+ let csSize =
+ checksumSize blockSize
+ (Uutil.Filesize.toFloat srcLength)(Uutil.Filesize.toFloat dstLength)
+ in
+ (blockSize, blockCount, csSize)
(* Incrementally build arg by executing f on successive blocks (of size
'blockSize') of the input stream (pointed by 'infd').
The procedure uses a buffer of size 'bufferSize' to load the input,
and eventually handles the buffer update. *)
- let blockIter infd f arg maxCount =
+ let blockIter infd f blockSize maxCount =
let bufferSize = 8192 + blockSize in
let buffer = String.create bufferSize in
- let rec iter count arg offset length =
- if count = maxCount then arg else begin
+ let rec iter count offset length =
+ if count = maxCount then
+ count
+ else begin
let newOffset = offset + blockSize in
- if newOffset <= length then
- iter (count + 1) (f buffer offset arg) newOffset length
- else if offset > 0 then begin
+ if newOffset <= length then begin
+ f count buffer offset;
+ iter (count + 1) newOffset length
+ end else if offset > 0 then begin
let chunkSize = length - offset in
String.blit buffer offset buffer 0 chunkSize;
- iter count arg 0 chunkSize
+ iter count 0 chunkSize
end else begin
let l = input infd buffer length (bufferSize - length) in
if l = 0 then
- arg
+ count
else
- iter count arg 0 (length + l)
+ iter count 0 (length + l)
end
end
in
- iter 0 arg 0 0
+ iter 0 0 0
(* Given a block size, get blocks from the old file and compute a
checksum and a fingerprint for each one. *)
- let rsyncPreprocess infd =
+ let rsyncPreprocess infd srcLength dstLength =
debug (fun() -> Util.msg "preprocessing\n");
- debugLog (fun() -> Util.msg "block size = %d bytes\n" blockSize);
+ let (blockSize, blockCount, csSize) = sizes srcLength dstLength in
+ debugLog (fun() ->
+ Util.msg "block size = %d bytes; block count = %d; \
+ strong checksum size = %d\n" blockSize blockCount csSize);
let timer = Trace.startTimer "Preprocessing old file" in
- let addBlock buf offset rev_bi =
- let cs = Checksum.substring buf offset blockSize in
- let fp = Digest.substring buf offset blockSize in
- (cs, fp) :: rev_bi
+ let weakCs =
+ Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout blockCount in
+ let strongCs = Bytearray.create (blockCount * csSize) in
+ let addBlock i buf offset =
+ weakCs.{i} <- Int32.of_int (Checksum.substring buf offset blockSize);
+ Bytearray.blit_from_string
+ (Digest.substring buf offset blockSize) 0 strongCs (i * csSize) csSize
in
(* Make sure we are at the beginning of the file
(important for AppleDouble files *)
LargeFile.seek_in infd 0L;
(* Limit the number of block so that there is no overflow in
encodeInt3 *)
- let rev_bi = blockIter infd addBlock [] (256*256*256) in
- let bi = Safelist.rev rev_bi in
- debugLog (fun() -> Util.msg "%d blocks\n" (Safelist.length bi));
+ let count = blockIter infd addBlock blockSize (256*256*256) in
+ debugLog (fun() -> Util.msg "%d blocks\n" count);
Trace.showTimer timer;
- bi
+ ({ blockSize = blockSize; blockCount = count; checksumSize = csSize;
+ weakChecksum = weakCs; strongChecksum = strongCs },
+ blockSize)
(* Expected size of the [rsync_block_info] datastructure (in KiB). *)
- (* The calculation here are for a 64 bit architecture. *)
- (* When serialized, the datastructure takes currently 24 bytes per block. *)
- (* In theory, 12 byte per block should be enough! *)
- let memoryFootprint sz =
- Int64.to_int
- (min (Int64.div (Uutil.Filesize.toInt64 sz) 716800L) 16384L)
- * 72
+ let memoryFootprint srcLength dstLength =
+ let (blockSize, blockCount, csSize) = sizes srcLength dstLength in
+ blockCount * (csSize + 4)
(*** DECOMPRESSION ***)
@@ -380,7 +414,7 @@ struct
(* For each transfer instruction, either output a string or copy one or
several blocks from the old file. *)
- let rsyncDecompress infd outfd showProgress (data, pos, len) =
+ let rsyncDecompress blockSize infd outfd showProgress (data, pos, len) =
let decomprBuf = String.create decomprBufSize in
let progress = ref 0 in
let rec copy length =
@@ -393,7 +427,7 @@ struct
reallyWrite outfd decomprBuf 0 length
in
let copyBlocks n k =
- LargeFile.seek_in infd (Int64.mul n blockSize64);
+ LargeFile.seek_in infd (Int64.mul n (Int64.of_int blockSize));
let length = k * blockSize in
copy length;
progress := !progress + length
@@ -435,42 +469,33 @@ struct
(* Maximum number of entries in the hash table.
MUST be a power of 2 !
Typical values are around an average 2 * fileSize / blockSize. *)
- let hashTableMaxLength = 64 * 1024
+ let hashTableMaxLength = 2048 * 1024
+
+ let rec upperPowerOfTwo n n2 =
+ if (n2 >= n) || (n2 = hashTableMaxLength) then
+ n2
+ else
+ upperPowerOfTwo n (2 * n2)
let hash checksum = checksum
(* Compute the hash table length as a function of the number of blocks *)
let hashTableLength signatures =
- let rec upperPowerOfTwo n n2 =
- if (n2 >= n) || (n2 = hashTableMaxLength) then
- n2
- else
- upperPowerOfTwo n (2 * n2)
- in
- 2 * (upperPowerOfTwo (Safelist.length signatures) 32)
+ 2 * (upperPowerOfTwo signatures.blockCount 32)
(* Hash the block signatures into the hash table *)
let hashSig hashTableLength signatures =
let hashTable = Array.make hashTableLength [] in
- let rec addList k l =
- match l with
- [] ->
- ()
- | (cs, fp) :: r ->
- (* Negative 31-bits integers are sign-extended when
- unmarshalled on a 64-bit architecture, so we
- truncate them back to 31 bits. *)
- let cs = cs land 0x7fffffff in
- let h = (hash cs) land (hashTableLength - 1) in
- hashTable.(h) <- (k, cs, fp)::(hashTable.(h));
- addList (k + 1) r
- in
- addList 0 signatures;
+ for k = 0 to signatures.blockCount - 1 do
+ let cs = Int32.to_int signatures.weakChecksum.{k} land 0x7fffffff in
+ let h = (hash cs) land (hashTableLength - 1) in
+ hashTable.(h) <- (k, cs) :: hashTable.(h)
+ done;
hashTable
(* Given a key, retrieve the corresponding entry in the table *)
let findEntry hashTable hashTableLength checksum :
- (int * Checksum.t * Digest.t) list =
+ (int * Checksum.t) list =
hashTable.((hash checksum) land (hashTableLength - 1))
(* Log the values of the parameters associated with the hash table *)
@@ -527,12 +552,14 @@ struct
(* Compression buffer size *)
(* MUST be >= 2 * blockSize *)
- let comprBufSize = 8192
- let comprBufSizeFS = Uutil.Filesize.ofInt 8192
+ let minComprBufSize = 8192
(* Compress the file using the algorithm described in the header *)
let rsyncCompress sigs infd srcLength showProgress transmit =
debug (fun() -> Util.msg "compressing\n");
+ let blockSize = sigs.blockSize in
+ let comprBufSize = (2 * blockSize + 8191) land (-8192) in
+ let comprBufSizeFS = Uutil.Filesize.ofInt comprBufSize in
debugLog (fun() -> Util.msg
"compression buffer size = %d bytes\n" comprBufSize);
debugLog (fun() -> Util.msg "block size = %d bytes\n" blockSize);
@@ -564,7 +591,7 @@ struct
*)
(* Enable token buffering *)
- let tokenQueue = makeQueue srcLength in
+ let tokenQueue = makeQueue srcLength blockSize in
let flushTokenQueue () =
flushQueue tokenQueue showProgress transmit true in
let transmit token = queueToken tokenQueue showProgress transmit token in
@@ -574,6 +601,17 @@ struct
let blockTable = hashSig !hashTableLength sigs in
logHash blockTable !hashTableLength;
+ let rec fingerprintMatchRec checksums pos fp i =
+ let i = i - 1 in
+ i < 0 ||
+ (String.unsafe_get fp i = checksums.{pos + i} &&
+ fingerprintMatchRec checksums pos fp i)
+ in
+ let fingerprintMatch k fp =
+ fingerprintMatchRec sigs.strongChecksum (k * sigs.checksumSize)
+ fp sigs.checksumSize
+ in
+
(* Create the compression buffer *)
let comprBuf = String.create comprBufSize in
@@ -661,12 +699,12 @@ struct
match entry, fingerprint with
| [], _ ->
-1
- | (k, cs, fp) :: tl, None
+ | (k, cs) :: tl, None
when cs = checksum ->
let fingerprint = Digest.substring comprBuf offset blockSize in
findBlock offset checksum entry (Some fingerprint)
- | (k, cs, fp) :: tl, Some fingerprint
- when (cs = checksum) && (fp = fingerprint) ->
+ | (k, cs) :: tl, Some fingerprint
+ when cs = checksum && fingerprintMatch k fingerprint ->
k
| _ :: tl, _ ->
findBlock offset checksum tl fingerprint
diff --git a/src/transfer.mli b/src/transfer.mli
index 493594b..d58df07 100644
--- a/src/transfer.mli
+++ b/src/transfer.mli
@@ -78,16 +78,19 @@ module Rsync :
type rsync_block_info
(* Expected size of the [rsync_block_info] datastructure (in KiB). *)
- val memoryFootprint : Uutil.Filesize.t -> int
+ val memoryFootprint : Uutil.Filesize.t -> Uutil.Filesize.t -> int
(* Compute block informations from the old file *)
val rsyncPreprocess :
in_channel (* old file descriptor *)
- -> rsync_block_info
+ -> Uutil.Filesize.t (* source file length *)
+ -> Uutil.Filesize.t (* destination file length *)
+ -> rsync_block_info * int
(* Interpret a transfer instruction *)
val rsyncDecompress :
- in_channel (* old file descriptor *)
+ int (* block size *)
+ -> in_channel (* old file descriptor *)
-> out_channel (* output file descriptor *)
-> (int -> unit) (* progress report *)
-> transfer_instruction (* transfer instruction received *)
diff --git a/src/transport.ml b/src/transport.ml
index 71ab65e..55ea3cc 100644
--- a/src/transport.ml
+++ b/src/transport.ml
@@ -120,8 +120,8 @@ let doAction fromRoot fromPath fromContents toRoot toPath toContents id =
("Updating file " ^ Path.toString toPath)
(fun () ->
Files.copy (`Update (fileSize uiFrom uiTo))
- fromRoot fromPath uiFrom toRoot toPath uiTo id)
- | {ui = uiFrom}, {ui = uiTo} ->
+ fromRoot fromPath uiFrom [] toRoot toPath uiTo [] id)
+ | {ui = uiFrom; props = propsFrom}, {ui = uiTo; props = propsTo} ->
logLwtNumbered
("Copying " ^ Path.toString toPath ^ "\n from " ^
root2string fromRoot ^ "\n to " ^
@@ -129,7 +129,8 @@ let doAction fromRoot fromPath fromContents toRoot toPath toContents id =
("Copying " ^ Path.toString toPath)
(fun () ->
Files.copy `Copy
- fromRoot fromPath uiFrom toRoot toPath uiTo id))
+ fromRoot fromPath uiFrom propsFrom
+ toRoot toPath uiTo propsTo id))
(fun e -> Trace.log
(Printf.sprintf
"Failed: %s\n" (Util.printException e));
diff --git a/src/ubase/prefs.ml b/src/ubase/prefs.ml
index dfec3e9..e451af5 100644
--- a/src/ubase/prefs.ml
+++ b/src/ubase/prefs.ml
@@ -56,30 +56,33 @@ let resetToDefaults () = Safelist.iter (fun f -> f()) !resetters
(* created, a dumper (marshaler) and a loader (parser) are added to the list *)
(* kept here... *)
-type dumpedPrefs = (string * string) list
+type dumpedPrefs = (string * bool * string) list
-let dumpers = ref ([] : (string * (unit->string)) list)
+let dumpers = ref ([] : (string * bool * (unit->string)) list)
let loaders = ref (Util.StringMap.empty : (string->unit) Util.StringMap.t)
-let adddumper name f =
- dumpers := (name,f) :: !dumpers
+let adddumper name optional f =
+ dumpers := (name,optional,f) :: !dumpers
let addloader name f =
loaders := Util.StringMap.add name f !loaders
-let dump () = Safelist.map (fun (name,f) -> (name, f())) !dumpers
-
+let dump () = Safelist.map (fun (name, opt, f) -> (name, opt, f())) !dumpers
+
let load d =
- begin
- Safelist.iter
- (fun (name, dumpedval) ->
- let loaderfn =
- try Util.StringMap.find name !loaders
- with Not_found -> raise (Util.Fatal
- ("Preference "^name^" not found: inconsistent Unison versions??"))
- in loaderfn dumpedval)
- d
- end
+ Safelist.iter
+ (fun (name, opt, dumpedval) ->
+ match
+ try Some (Util.StringMap.find name !loaders) with Not_found -> None
+ with
+ Some loaderfn ->
+ loaderfn dumpedval
+ | None ->
+ if not opt then
+ raise (Util.Fatal
+ ("Preference "^name^" not found: \
+ inconsistent Unison versions??")))
+ d
(* For debugging *)
let dumpPrefsToStderr() =
@@ -117,42 +120,42 @@ let registerPref name pspec doc fulldoc =
raise (Util.Fatal ("Preference " ^ name ^ " registered twice"));
prefs := Util.StringMap.add name (doc, pspec, fulldoc) !prefs
-let createPrefInternal name default doc fulldoc printer parsefn =
+let createPrefInternal name local default doc fulldoc printer parsefn =
let newCell = rawPref (default, [name]) in
registerPref name (parsefn newCell) doc fulldoc;
- adddumper name (fun () -> Marshal.to_string !newCell []);
+ adddumper name local (fun () -> Marshal.to_string !newCell []);
addprinter name (fun () -> printer (fst !newCell));
addresetter (fun () -> newCell := (default, [name]));
addloader name (fun s -> newCell := Marshal.from_string s 0);
newCell
-let create name default doc fulldoc intern printer =
- createPrefInternal name default doc fulldoc printer
+let create name ?(local=false) default doc fulldoc intern printer =
+ createPrefInternal name local default doc fulldoc printer
(fun cell -> Uarg.String (fun s -> set cell (intern (fst !cell) s)))
-let createBool name default doc fulldoc =
+let createBool name ?(local=false) default doc fulldoc =
let doc = if default then doc ^ " (default true)" else doc in
- createPrefInternal name default doc fulldoc
+ createPrefInternal name local default doc fulldoc
(fun v -> [if v then "true" else "false"])
(fun cell -> Uarg.Bool (fun b -> set cell b))
-let createInt name default doc fulldoc =
- createPrefInternal name default doc fulldoc
- (fun v -> [string_of_int v])
+let createInt name ?(local=false) default doc fulldoc =
+ createPrefInternal name local default doc fulldoc
+ (fun v -> [string_of_int v])
(fun cell -> Uarg.Int (fun i -> set cell i))
-let createString name default doc fulldoc =
- createPrefInternal name default doc fulldoc
+let createString name ?(local=false) default doc fulldoc =
+ createPrefInternal name local default doc fulldoc
(fun v -> [v])
(fun cell -> Uarg.String (fun s -> set cell s))
-let createFspath name default doc fulldoc =
- createPrefInternal name default doc fulldoc
+let createFspath name ?(local=false) default doc fulldoc =
+ createPrefInternal name local default doc fulldoc
(fun v -> [System.fspathToString v])
(fun cell -> Uarg.String (fun s -> set cell (System.fspathFromString s)))
-let createStringList name doc fulldoc =
- createPrefInternal name [] doc fulldoc
+let createStringList name ?(local=false) doc fulldoc =
+ createPrefInternal name local [] doc fulldoc
(fun v -> v)
(fun cell -> Uarg.String (fun s -> set cell (s::(fst !cell))))
diff --git a/src/ubase/prefs.mli b/src/ubase/prefs.mli
index 435e468..b0d97a9 100644
--- a/src/ubase/prefs.mli
+++ b/src/ubase/prefs.mli
@@ -13,6 +13,7 @@ val name : 'a t -> string list
(* accumulates a list of values. *)
val createBool :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> bool (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
@@ -20,6 +21,7 @@ val createBool :
val createInt :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> int (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
@@ -27,6 +29,7 @@ val createInt :
val createString :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> string (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
@@ -34,6 +37,7 @@ val createString :
val createFspath :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> System.fspath (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
@@ -41,6 +45,7 @@ val createFspath :
val createStringList :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
-> string list t (* -> new preference value *)
@@ -51,6 +56,7 @@ exception IllegalValue of string
(* IllegalValue if it is passed a string it cannot deal with. *)
val create :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> 'a (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
diff --git a/src/uicommon.ml b/src/uicommon.ml
index 5167a14..18d1760 100644
--- a/src/uicommon.ml
+++ b/src/uicommon.ml
@@ -441,7 +441,7 @@ let debug = Trace.debug "startup"
let architecture =
Remote.registerRootCmd
"architecture"
- (fun (_,()) -> return (Util.osType = `Win32, Osx.isMacOSX))
+ (fun (_,()) -> return (Util.osType = `Win32, Osx.isMacOSX, Util.isCygwin))
(* During startup the client determines the case sensitivity of each root.
If any root is case insensitive, all roots must know this -- it's
@@ -452,16 +452,19 @@ let architecture =
let checkCaseSensitivity () =
Globals.allRootsMap (fun r -> architecture r ()) >>= (fun archs ->
let someHostIsRunningWindows =
- Safelist.exists (fun (isWin, _) -> isWin) archs in
+ Safelist.exists (fun (isWin, _, _) -> isWin) archs in
let allHostsAreRunningWindows =
- Safelist.for_all (fun (isWin, _) -> isWin) archs in
+ Safelist.for_all (fun (isWin, _, _) -> isWin) archs in
+ let someHostIsRunningBareWindows =
+ Safelist.exists (fun (isWin, _, isCyg) -> isWin && not isCyg) archs in
let someHostRunningOsX =
- Safelist.exists (fun (_, isOSX) -> isOSX) archs in
+ Safelist.exists (fun (_, isOSX, _) -> isOSX) archs in
let someHostIsCaseInsensitive =
someHostIsRunningWindows || someHostRunningOsX in
Case.init someHostIsCaseInsensitive;
Props.init someHostIsRunningWindows;
Osx.init someHostRunningOsX;
+ Fileinfo.init someHostIsRunningBareWindows;
Prefs.set Globals.someHostIsRunningWindows someHostIsRunningWindows;
Prefs.set Globals.allHostsAreRunningWindows allHostsAreRunningWindows;
return ())
diff --git a/src/uigtk2.ml b/src/uigtk2.ml
index ffd8b66..9fc63e2 100644
--- a/src/uigtk2.ml
+++ b/src/uigtk2.ml
@@ -259,7 +259,7 @@ class scrolled_text
GBin.scrolled_window ?packing ~show:false
~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
in
- let text = GText.view ?editable ?wrap_mode:(Some `WORD) ~packing:sw#add () in
+ let text = GText.view ?editable ~wrap_mode:`WORD ~packing:sw#add () in
object
inherit GObj.widget_full sw#as_widget
method text = text
@@ -382,7 +382,19 @@ class stats width height =
val values = Array.make width 0.
val mutable active = false
- method activate a = active <- a
+ method redraw () =
+ scale := min_scale;
+ while !maxim > !scale do
+ scale := !scale *. 1.5
+ done;
+ pixmap#set_foreground `WHITE;
+ pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
+ pixmap#set_foreground `BLACK;
+ for i = 0 to width - 1 do
+ self#rect i values.(max 0 (i - 1)) values.(i)
+ done
+
+ method activate a = active <- a; if a then self#redraw ()
method scale h = truncate ((float height) *. h /. !scale)
@@ -416,18 +428,9 @@ class stats width height =
if active then begin
let need_resize =
!maxim > !scale || (!maxim > min_scale && !maxim < !scale /. 1.5) in
- if need_resize then begin
- scale := min_scale;
- while !maxim > !scale do
- scale := !scale *. 1.5
- done;
- pixmap#set_foreground `WHITE;
- pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
- pixmap#set_foreground `BLACK;
- for i = 0 to width - 1 do
- self#rect i values.(max 0 (i - 1)) values.(i)
- done
- end else begin
+ if need_resize then
+ self#redraw ()
+ else begin
pixmap#put_pixmap ~x:0 ~y:0 ~xsrc:1 (pixmap#pixmap);
pixmap#set_foreground `WHITE;
pixmap#rectangle
@@ -440,6 +443,25 @@ class stats width height =
let clientWritten = ref 0.
let serverWritten = ref 0.
+let emitRate2 = ref 0.
+let receiveRate2 = ref 0.
+
+let rate2str v =
+ if v > 9.9e3 then begin
+ if v > 9.9e6 then
+ Format.sprintf "%1.0f MiB/s" (v /. 1e6)
+ else if v > 999e3 then
+ Format.sprintf "%1.1f MiB/s" (v /. 1e6)
+ else
+ Format.sprintf "%1.0f KiB/s" (v /. 1e3)
+ end else begin
+ if v > 990. then
+ Format.sprintf "%1.1f KiB/s" (v /. 1e3)
+ else if v > 99. then
+ Format.sprintf "%1.2f KiB/s" (v /. 1e3)
+ else
+ " "
+ end
let statistics () =
let title = "Statistics" in
@@ -487,10 +509,26 @@ let statistics () =
let emittedBytes = ref 0. in
let emitRate = ref 0. in
- let emitRate2 = ref 0. in
let receivedBytes = ref 0. in
let receiveRate = ref 0. in
- let receiveRate2 = ref 0. in
+
+ let stopCounter = ref 0 in
+
+ let updateTable () =
+ let kib2str v = Format.sprintf "%.0f B" v in
+ lst#set_cell ~text:(rate2str !receiveRate2) 0 1;
+ lst#set_cell ~text:(rate2str !emitRate2) 0 2;
+ lst#set_cell ~text:
+ (rate2str (!receiveRate2 +. !emitRate2)) 0 3;
+ lst#set_cell ~text:(kib2str !receivedBytes) 1 1;
+ lst#set_cell ~text:(kib2str !emittedBytes) 1 2;
+ lst#set_cell ~text:
+ (kib2str (!receivedBytes +. !emittedBytes)) 1 3;
+ lst#set_cell ~text:(kib2str !clientWritten) 2 1;
+ lst#set_cell ~text:(kib2str !serverWritten) 2 2;
+ lst#set_cell ~text:
+ (kib2str (!clientWritten +. !serverWritten)) 2 3
+ in
let timeout _ =
emitRate :=
a *. !emitRate +.
@@ -508,41 +546,25 @@ let statistics () =
reception#push !receiveRate;
emittedBytes := !Remote.emittedBytes;
receivedBytes := !Remote.receivedBytes;
- let kib2str v = Format.sprintf "%.0f B" v in
- let rate2str v =
- if v > 9.9e3 then begin
- if v > 9.9e6 then
- Format.sprintf "%4.0f MiB/s" (v /. 1e6)
- else if v > 999e3 then
- Format.sprintf "%4.1f MiB/s" (v /. 1e6)
- else
- Format.sprintf "%4.0f KiB/s" (v /. 1e3)
- end else begin
- if v > 990. then
- Format.sprintf "%4.1f KiB/s" (v /. 1e3)
- else if v > 99. then
- Format.sprintf "%4.2f KiB/s" (v /. 1e3)
- else
- " "
- end
- in
- lst#set_cell ~text:(rate2str !receiveRate2) 0 1;
- lst#set_cell ~text:(rate2str !emitRate2) 0 2;
- lst#set_cell ~text:
- (rate2str (!receiveRate2 +. !emitRate2)) 0 3;
- lst#set_cell ~text:(kib2str !receivedBytes) 1 1;
- lst#set_cell ~text:(kib2str !emittedBytes) 1 2;
- lst#set_cell ~text:
- (kib2str (!receivedBytes +. !emittedBytes)) 1 3;
- lst#set_cell ~text:(kib2str !clientWritten) 2 1;
- lst#set_cell ~text:(kib2str !serverWritten) 2 2;
- lst#set_cell ~text:
- (kib2str (!clientWritten +. !serverWritten)) 2 3;
- true
+ if !stopCounter > 0 then decr stopCounter;
+ if !stopCounter = 0 then begin
+ emitRate2 := 0.; receiveRate2 := 0.;
+ end;
+ updateTable ();
+ !stopCounter <> 0
in
- ignore (GMain.Timeout.add ~ms:(truncate (delay *. 1000.)) ~callback:timeout);
-
- t
+ let startStats () =
+ if !stopCounter = 0 then begin
+ emittedBytes := !Remote.emittedBytes;
+ receivedBytes := !Remote.receivedBytes;
+ stopCounter := -1;
+ ignore (GMain.Timeout.add ~ms:(truncate (delay *. 1000.))
+ ~callback:timeout)
+ end else
+ stopCounter := -1
+ in
+ let stopStats () = stopCounter := 10 in
+ (t, startStats, stopStats)
(****)
@@ -617,13 +639,13 @@ let getFirstRoot() =
let contCommand() =
result := Some(fileE#text);
t#destroy () in
+ let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in
+ ignore (quitButton#connect#clicked
+ ~callback:(fun () -> result := None; t#destroy()));
let contButton = GButton.button ~stock:`OK ~packing:f3#add () in
ignore (contButton#connect#clicked ~callback:contCommand);
ignore (fileE#connect#activate ~callback:contCommand);
contButton#grab_default ();
- let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in
- ignore (quitButton#connect#clicked
- ~callback:(fun () -> result := None; t#destroy()));
t#show ();
ignore (t#connect#destroy ~callback:GMain.Main.quit);
GMain.Main.main ();
@@ -746,14 +768,14 @@ let getSecondRoot () =
okBox ~title:"Error" ~typ:`ERROR
~message:"Something's wrong with the values you entered, try again" in
let f3 = t#action_area in
+ let quitButton =
+ GButton.button ~stock:`QUIT ~packing:f3#add () in
+ ignore (quitButton#connect#clicked ~callback:safeExit);
let contButton =
GButton.button ~stock:`OK ~packing:f3#add () in
ignore (contButton#connect#clicked ~callback:contCommand);
contButton#grab_default ();
ignore (fileE#connect#activate ~callback:contCommand);
- let quitButton =
- GButton.button ~stock:`QUIT ~packing:f3#add () in
- ignore (quitButton#connect#clicked ~callback:safeExit);
t#show ();
ignore (t#connect#destroy ~callback:GMain.Main.quit);
@@ -827,7 +849,7 @@ let provideProfileKey filename k profile info =
("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
^ "Value of 'key' preference must be a single digit (0-9), "
^ "not " ^ k))
- with int_of_string -> raise (Util.Fatal
+ with Failure "int_of_string" -> raise (Util.Fatal
("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
^ "Value of 'key' preference must be a single digit (0-9), "
^ "not " ^ k))
@@ -969,12 +991,12 @@ let getProfile () =
close_out ch;
fillLst profile;
exit () in
- let okButton = GButton.button ~stock:`OK ~packing:f3#add () in
- ignore (okButton#connect#clicked ~callback:okCommand);
- okButton#grab_default ();
let cancelButton =
GButton.button ~stock:`CANCEL ~packing:f3#add () in
ignore (cancelButton#connect#clicked ~callback:exit);
+ let okButton = GButton.button ~stock:`OK ~packing:f3#add () in
+ ignore (okButton#connect#clicked ~callback:okCommand);
+ okButton#grab_default ();
t#show ();
grabFocus t;
@@ -1189,7 +1211,7 @@ let rec createToplevelWindow () =
Statistic window
*******************************************************************)
- let stat_win = statistics () in
+ let (statWin, startStats, stopStats) = statistics () in
(*******************************************************************
Groups of things that are sensitive to interaction at the same time
@@ -1375,11 +1397,12 @@ let rec createToplevelWindow () =
| Some (title, details) -> messageBox ~title (transcode details)
in
+ let detailsWindowSW =
+ GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false)
+ ~shadow_type:`IN ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
+ in
let detailsWindow =
- let sw =
- GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false)
- ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
- GText.view ~editable:false ~wrap_mode:`NONE ~packing:sw#add ()
+ GText.view ~editable:false ~wrap_mode:`NONE ~packing:detailsWindowSW#add ()
in
detailsWindow#misc#modify_font (Lazy.force fontMonospaceMediumPango);
detailsWindow#misc#set_size_chars ~height:3 ~width:112 ();
@@ -1447,18 +1470,20 @@ let rec createToplevelWindow () =
detailsWindow#buffer#set_text ""
| Some row ->
makeRowVisible row;
- let details =
+ let (formated, details) =
match !theState.(row).whatHappened with
- None -> Uicommon.details2string !theState.(row).ri " "
- | Some(Util.Succeeded, _) -> Uicommon.details2string !theState.(row).ri " "
- | Some(Util.Failed(s), None) -> s
- | Some(Util.Failed(s), Some resultLog) -> s in
+ None | Some(Util.Succeeded, _) ->
+ (true, Uicommon.details2string !theState.(row).ri " ")
+ | Some(Util.Failed(s), _) ->
+ (false, s)
+ in
let path = Path.toString !theState.(row).ri.path1 in
let txt = transcodeFilename path ^ "\n" ^ transcode details in
let len = String.length txt in
let txt =
if txt.[len - 1] = '\n' then String.sub txt 0 (len - 1) else txt in
- detailsWindow#buffer#set_text txt
+ detailsWindow#buffer#set_text txt;
+ detailsWindow#set_wrap_mode (if formated then `NONE else `WORD)
end;
(* Display text *)
updateButtons () in
@@ -1471,6 +1496,8 @@ let rec createToplevelWindow () =
let progressBar =
GRange.progress_bar ~packing:(statusHBox#pack ~expand:false) () in
+
+ progressBar#misc#set_size_chars ~height:1 ~width:25 ();
progressBar#set_pulse_step 0.02;
let progressBarPulse = ref false in
@@ -1655,25 +1682,41 @@ lst_store#set ~row ~column:c_path path;
let t0 = ref 0. in
let t1 = ref 0. in
let lastFrac = ref 0. in
+ let oldWritten = ref 0. in
+ let writeRate = ref 0. in
let displayGlobalProgress v =
if v = 0. || abs_float (v -. !lastFrac) > 1. then begin
lastFrac := v;
progressBar#set_fraction (max 0. (min 1. (v /. 100.)))
end;
-(*
- let t = Unix.gettimeofday () in
- if t -. !t1 >= 1. then begin
- t1 := t;
- let remTime =
- if v <= 0. then ""
- else if v >= 100. then "00:00 ETA"
- else
+ if v < 0.001 then
+ progressBar#set_text " "
+ else begin
+ let t = Unix.gettimeofday () in
+ let delta = t -. !t1 in
+ if delta >= 0.5 then begin
+ t1 := t;
+ let remTime =
+ if v >= 100. then "00:00 remaining" else
let t = truncate ((!t1 -. !t0) *. (100. -. v) /. v +. 0.5) in
- Format.sprintf "%02d:%02d ETA" (t / 60) (t mod 60)
- in
- progressBar#set_text remTime
+ Format.sprintf "%02d:%02d remaining" (t / 60) (t mod 60)
+ in
+ let written = !clientWritten +. !serverWritten in
+ let b = 0.64 ** delta in
+ writeRate :=
+ b *. !writeRate +.
+ (1. -. b) *. (written -. !oldWritten) /. delta;
+ oldWritten := written;
+ let rate = !writeRate (*!emitRate2 +. !receiveRate2*) in
+ let txt =
+ if rate > 99. then
+ Format.sprintf "%s (%s)" remTime (rate2str rate)
+ else
+ remTime
+ in
+ progressBar#set_text txt
+ end
end
-*)
in
let showGlobalProgress b =
@@ -1690,6 +1733,7 @@ lst_store#set ~row ~column:c_path path;
totalBytesToTransfer := b;
totalBytesTransferred := Uutil.Filesize.zero;
t0 := Unix.gettimeofday (); t1 := !t0;
+ writeRate := 0.; oldWritten := !clientWritten +. !serverWritten;
displayGlobalProgress 0.
in
@@ -1784,6 +1828,7 @@ lst_store#set ~row ~column:c_path path;
let detectUpdatesAndReconcile () =
grDisactivateAll ();
+ startStats ();
mainWindow#clear();
detailsWindow#buffer#set_text "";
@@ -1824,6 +1869,7 @@ lst_store#set ~row ~column:c_path path;
current := None;
displayMain();
progressBarPulse := false; sync_action := None; displayGlobalProgress 0.;
+ stopStats ();
grSet grGo (Array.length !theState > 0);
grSet grRescan true;
if Prefs.read Globals.confirmBigDeletes then begin
@@ -1995,6 +2041,7 @@ lst_store#set ~row ~column:c_path path;
end else
actions
in
+ startStats ();
Lwt_unix.run
(let actions = loop 0 [] (fun ri -> not (Common.isDeletion ri)) in
Lwt_util.join actions);
@@ -2004,6 +2051,7 @@ lst_store#set ~row ~column:c_path path;
Transport.logFinish ();
Trace.showTimer t;
commitUpdates ();
+ stopStats ();
let failures =
let count =
@@ -2088,7 +2136,7 @@ lst_store#set ~row ~column:c_path path;
let reloadProfile () =
match !Prefs.profileName with
None -> ()
- | Some(n) -> loadProfile n in
+ | Some(n) -> grDisactivateAll (); loadProfile n in
let detectCmdName = "Rescan" in
let detectCmd () =
@@ -2177,10 +2225,12 @@ lst_store#set ~row ~column:c_path path;
item.bytesTransferred <- Uutil.Filesize.zero;
item.bytesToTransfer <- len;
initGlobalProgress len;
+ startStats ();
Uicommon.showDiffs item.ri
(fun title text ->
messageBox ~title:(transcode title) (transcode text))
Trace.status (Uutil.File.ofLine i);
+ stopStats ();
displayGlobalProgress 0.;
fastRedisplay i)
| None ->
@@ -2453,7 +2503,7 @@ lst_store#set ~row ~column:c_path path;
ignore (fileMenu#add_separator ());
ignore (fileMenu#add_item
- ~callback:(fun _ -> stat_win#show ()) "Statistics");
+ ~callback:(fun _ -> statWin#show ()) "Statistics");
ignore (fileMenu#add_separator ());
ignore (fileMenu#add_image_item
@@ -2539,9 +2589,11 @@ let start _ =
createToplevelWindow();
(* Display the ui *)
+(*JV: not useful, as Unison does not handle any signal
ignore (GMain.Timeout.add 500 (fun _ -> true));
(* Hack: this allows signals such as SIGINT to be
handled even when Gtk is waiting for events *)
+*)
GMain.Main.main ()
with
Util.Transient(s) | Util.Fatal(s) -> fatalError s
diff --git a/src/uimacbridge.ml b/src/uimacbridge.ml
index fe5fa63..7ba051e 100644
--- a/src/uimacbridge.ml
+++ b/src/uimacbridge.ml
@@ -261,11 +261,11 @@ Callback.register "unisonInit2" unisonInit2;;
let unisonRiToDetails ri =
match ri.whatHappened with
- Some (Util.Failed s) -> (Path.toString ri.ri.path) ^ "\n" ^ s
- | _ -> (Path.toString ri.ri.path) ^ "\n" ^ (Uicommon.details2string ri.ri " ");;
+ Some (Util.Failed s) -> (Path.toString ri.ri.path1) ^ "\n" ^ s
+ | _ -> (Path.toString ri.ri.path1) ^ "\n" ^ (Uicommon.details2string ri.ri " ");;
Callback.register "unisonRiToDetails" unisonRiToDetails;;
-let unisonRiToPath ri = Path.toString ri.ri.path;;
+let unisonRiToPath ri = Path.toString ri.ri.path1;;
Callback.register "unisonRiToPath" unisonRiToPath;;
let rcToString rc =
@@ -410,11 +410,11 @@ let unisonSynchronize () =
Callback.register "unisonSynchronize" unisonSynchronize;;
let unisonIgnorePath si =
- Uicommon.addIgnorePattern (Uicommon.ignorePath si.ri.path);;
+ Uicommon.addIgnorePattern (Uicommon.ignorePath si.ri.path1);;
let unisonIgnoreExt si =
- Uicommon.addIgnorePattern (Uicommon.ignoreExt si.ri.path);;
+ Uicommon.addIgnorePattern (Uicommon.ignoreExt si.ri.path1);;
let unisonIgnoreName si =
- Uicommon.addIgnorePattern (Uicommon.ignoreName si.ri.path);;
+ Uicommon.addIgnorePattern (Uicommon.ignoreName si.ri.path1);;
Callback.register "unisonIgnorePath" unisonIgnorePath;;
Callback.register "unisonIgnoreExt" unisonIgnoreExt;;
Callback.register "unisonIgnoreName" unisonIgnoreName;;
@@ -428,7 +428,7 @@ let unisonUpdateForIgnore i =
let num = ref(-1) in
let newI = ref None in
(* FIX: we should actually test whether any prefix is now ignored *)
- let keep s = not (Globals.shouldIgnore s.ri.path) in
+ let keep s = not (Globals.shouldIgnore s.ri.path1) in
for j = 0 to (Array.length !theState - 1) do
let s = !theState.(j) in
if keep s then begin
diff --git a/src/uitext.ml b/src/uitext.ml
index 19c2f15..3cd74de 100644
--- a/src/uitext.ml
+++ b/src/uitext.ml
@@ -798,14 +798,17 @@ let rec synchronizeUntilDone () =
synchronizeUntilDone ()
end
-let start _ =
+let start interface =
+ if interface <> Uicommon.Text then
+ Util.msg "This Unison binary only provides the text GUI...\n";
begin try
(* Just to make sure something is there... *)
setWarnPrinterForInitialization();
Uicommon.uiInit
(fun s -> Util.msg "%s\n%s\n" Uicommon.shortUsageMsg s; exit 1)
(fun s -> Util.msg "%s" Uicommon.shortUsageMsg; exit 1)
- (fun () -> if not (Prefs.read silent)
+ (fun () -> if Prefs.read silent then Prefs.set Trace.terse true;
+ if not (Prefs.read silent)
then Util.msg "%s\n" (Uicommon.contactingServerMsg()))
(fun () -> Some "default")
(fun () -> Util.msg "%s" Uicommon.shortUsageMsg; exit 1)
diff --git a/src/update.ml b/src/update.ml
index 901edb8..40e967a 100644
--- a/src/update.ml
+++ b/src/update.ml
@@ -1400,15 +1400,15 @@ let rec buildUpdateChildren
archive
| `BadEnc ->
let uiChild =
- Error ("The file name is not encoded in Unicode ("
- ^ Path.toString path' ^ ")")
+ Error ("The file name is not encoded in Unicode. (File '"
+ ^ Path.toString path' ^ "')")
in
updates := (nm, uiChild) :: !updates;
archive
| `BadName ->
let uiChild =
- Error ("The name of this Unix file is not allowed in Windows ("
- ^ Path.toString path' ^ ")")
+ Error ("The name of this Unix file is not allowed under Windows. \
+ (File '" ^ Path.toString path' ^ "')")
in
updates := (nm, uiChild) :: !updates;
archive
@@ -1541,7 +1541,10 @@ and buildUpdateRec archive currfspath path fastCheckInfos =
(* Compute the updates for [path] against archive. Also returns an
archive, which is the old archive with time stamps updated
appropriately (i.e., for those files whose contents remain
- unchanged). *)
+ unchanged). The filenames are also updated to match the filesystem
+ contents. The directory permissions along the path are also
+ collected, in case we need to build the directory hierarchy
+ on one side. *)
let rec buildUpdate archive fspath fullpath here path dirStamp =
match Path.deconstruct path with
None ->
@@ -1557,9 +1560,10 @@ let rec buildUpdate archive fspath fullpath here path dirStamp =
None -> archive
| Some arch -> arch
end,
- ui)
+ ui, here, [])
| Some(name, path') ->
- if not (isDir fspath here) then
+ let info = Fileinfo.get true fspath here in
+ if info.Fileinfo.typ <> `DIRECTORY && info.Fileinfo.typ <> `ABSENT then
let error =
if Path.isEmpty here then
Printf.sprintf
@@ -1572,65 +1576,66 @@ let rec buildUpdate archive fspath fullpath here path dirStamp =
the replicas"
(Path.toString fullpath) (Path.toString here)
in
- (* FIX: We have to fail here (and in other error cases below)
- rather than report an error for this path, which would be
- more user friendly. Indeed, the archive is otherwise
- modified in inconsistent way when the failure occurs only
- on one replica (see at the end of this function).
- A better solution should be not to put the archives in a
- different state, but this is a lot more work. *)
- raise (Util.Transient error)
-(* (archive, Error error) *)
+ (archive, Error error, translatePathLocal fspath fullpath, [])
else
- let children = getChildren fspath here in
let (name', status) =
- try
- Safelist.find (fun (name', _) -> Name.eq name name') children
- with Not_found ->
+ if info.Fileinfo.typ = `ABSENT then
(name, checkFilename name)
+ else
+ let children = getChildren fspath here in
+ try
+ Safelist.find (fun (name', _) -> Name.eq name name') children
+ with Not_found ->
+ (name, checkFilename name)
in
match status with
- | `BadEnc ->
+ | `BadEnc ->
raise (Util.Transient
- ("The path " ^ Path.toString fullpath ^
- " is not encoded in Unicode"))
- | `BadName ->
+ (Format.sprintf
+ "The filename %s in path %s is not encoded in Unicode"
+ (Name.toString name) (Path.toString fullpath)))
+ | `BadName ->
raise (Util.Transient
- ("The path " ^ Path.toString fullpath ^
- " is not allowed in Windows"))
+ (Format.sprintf
+ "The filename %s in path %s is not allowed under Windows"
+ (Name.toString name) (Path.toString fullpath)))
| `Dup ->
raise (Util.Transient
- ("The path " ^ Path.toString fullpath ^
- " is ambiguous (i.e., the name of this path or one of its "
- ^ "ancestors is the same, modulo capitalization, as another "
- ^ "path in a case-sensitive filesystem, and you are "
- ^ "synchronizing this filesystem with a case-insensitive "
- ^ "filesystem. "))
+ (Format.sprintf
+ "The path %s is ambiguous at filename %s (i.e., the name \
+ of this path is the same, modulo capitalization, as \
+ another path in a case-sensitive filesystem, and you are \
+ synchronizing this filesystem with a case-insensitive \
+ filesystem."
+ (Path.toString fullpath) (Name.toString name)))
| `Ok ->
- let (desc, child, otherChildren) =
- match archive with
- ArchiveDir (desc, children) ->
- begin try
- let child = NameMap.find name children in
- (desc, child, NameMap.remove name children)
- with Not_found ->
- (desc, NoArchive, children)
- end
- | _ ->
- (Props.dummy, NoArchive, NameMap.empty)
- in
- let (arch, updates) =
- buildUpdate
- child fspath fullpath (Path.child here name') path' dirStamp
- in
- (* We need to put a directory in the archive here for path
- translation. This is fine because we check that there
- really is a directory on both replica.
- Note that we may also put NoArchive deep inside an
- archive...
- *)
- (ArchiveDir (desc, NameMap.add name' arch otherChildren),
- updates)
+ match archive with
+ ArchiveDir (desc, children) ->
+ let archChild =
+ try NameMap.find name children with Not_found -> NoArchive in
+ let otherChildren = NameMap.remove name children in
+ let (arch, updates, localPath, props) =
+ buildUpdate
+ archChild fspath fullpath (Path.child here name') path'
+ dirStamp
+ in
+ let children =
+ if arch = NoArchive then otherChildren else
+ NameMap.add name' arch otherChildren
+ in
+ (ArchiveDir (desc, children), updates, localPath,
+ if info.Fileinfo.typ = `ABSENT then [] else
+ info.Fileinfo.desc :: props)
+ | _ ->
+ let (arch, updates, localPath, props) =
+ buildUpdate
+ NoArchive fspath fullpath (Path.child here name') path'
+ dirStamp
+ in
+ assert (arch = NoArchive);
+ (archive, updates, localPath,
+ if info.Fileinfo.typ = `ABSENT then [] else
+ info.Fileinfo.desc :: props)
(* All the predicates that may change the set of files scanned during
update detection *)
@@ -1675,7 +1680,8 @@ Format.eprintf "==> %b@." (oldPreds = newPreds);
(* for the given path, find the archive and compute the list of update
items; as a side effect, update the local archive w.r.t. time-stamps for
unchanged files *)
-let findLocal fspath pathList: Common.updateItem list =
+let findLocal fspath pathList:
+ (Path.local * Common.updateItem * Props.t list) list =
debug (fun() -> Util.msg "findLocal %s\n" (Fspath.toDebugString fspath));
addHashToTempNames fspath;
(* Maybe we should remember the device number where the root lives at
@@ -1694,12 +1700,12 @@ let t1 = Unix.gettimeofday () in
Safelist.fold_right
(fun path (arch, upd) ->
if Globals.shouldIgnore path then
- (arch, NoUpdates :: upd)
+ (arch, (translatePathLocal fspath path, NoUpdates, []) :: upd)
else
- let (arch', ui) =
+ let (arch', ui, localPath, props) =
buildUpdate arch fspath path Path.empty path dirStamp
in
- arch', ui :: upd)
+ arch', (localPath, ui, props) :: upd)
pathList (archive, [])
in
(*
@@ -1732,8 +1738,7 @@ let findUpdatesOnPaths pathList =
let t = Trace.startTimer "Collecting changes" in
Globals.allRootsMapWithWaitingAction (fun r ->
debug (fun() -> Util.msg "findOnRoot %s\n" (root2string r));
- findOnRoot r pathList >>= fun updates ->
- Lwt.return (List.combine pathList updates))
+ findOnRoot r pathList)
(fun (host, _) ->
begin match host with
Remote _ -> Uutil.showUpdateStatus "";
@@ -1746,8 +1751,8 @@ let findUpdatesOnPaths pathList =
Safelist.map
(fun r ->
match r with
- [(p1, u1); (p2, u2)] -> (p1,u1,p2,u2)
- | _ -> assert false)
+ [i1; i2] -> (i1, i2)
+ | _ -> assert false)
(Safelist.transpose updates)
in
Trace.status "";
@@ -2230,3 +2235,9 @@ let rec iterFiles fspath path arch f =
f fspath path fp
| _ ->
()
+
+(* Hook for filesystem auto-detection (not implemented yet) *)
+let inspectFilesystem =
+ Remote.registerRootCmd
+ "inspectFilesystem"
+ (fun _ -> Lwt.return Proplist.empty)
diff --git a/src/update.mli b/src/update.mli
index b8293e6..95ff9c2 100644
--- a/src/update.mli
+++ b/src/update.mli
@@ -20,7 +20,8 @@ val getRootsName : unit -> string
(* Structures describing dirty files/dirs (1 per path given in the -path preference) *)
val findUpdates :
- unit -> (Path.t * Common.updateItem * Path.t * Common.updateItem) list
+ unit -> ((Path.local * Common.updateItem * Props.t list) *
+ (Path.local * Common.updateItem * Props.t list)) list
(* Take a tree of equal update contents and update the archive accordingly. *)
val markEqual :
generated by cgit v1.1 at 2025-05-21 01:29:25 +0000