* 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.

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.

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

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

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

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

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

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,18 +424,22 @@ 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
       "copy %s %s ---> %s %s \n"
       (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. *)