path: root/src/files.ml

(* Unison file synchronizer: src/files.ml *)
(* $Id$ *)
(* Copyright 1999-2006 (see COPYING for details) *)

open Common
open Lwt
open Fileinfo
  
let debug = Trace.debug "files"
let debugverbose = Trace.debug "files+"
    
(* ------------------------------------------------------------ *)
    
let commitLogName = Util.fileInHomeDir "DANGER.README"
    
let writeCommitLog source target tempname =
  let sourcename = Fspath.toString source in
  let targetname = Fspath.toString target in
  debug (fun() -> Util.msg "Writing commit log: renaming %s to %s via %s\n"
    sourcename targetname tempname);
  Util.convertUnixErrorsToFatal
    "writing commit log"
    (fun () ->
       let c =
         open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_excl]
           0o600 commitLogName in
       Printf.fprintf c "Warning: the last run of %s terminated abnormally "
         Uutil.myName;
       Printf.fprintf c "while moving\n   %s\nto\n   %s\nvia\n   %s\n\n"
         sourcename targetname tempname;
       Printf.fprintf c "Please check the state of these files immediately\n";
       Printf.fprintf c "(and delete this notice when you've done so).\n";
       close_out c)

let clearCommitLog () =
  debug (fun() -> (Util.msg "Deleting commit log\n"));
  Util.convertUnixErrorsToFatal
    "clearing commit log"
      (fun () -> Unix.unlink commitLogName)
    
let processCommitLog () =
  if Sys.file_exists commitLogName then begin
    raise(Util.Fatal(
          Printf.sprintf
            "Warning: the previous run of %s terminated in a dangerous state.
            Please consult the file %s, delete it, and try again."
                Uutil.myName
                commitLogName))
  end else
    Lwt.return ()
      
let processCommitLogOnHost =
  Remote.registerHostCmd "processCommitLog" processCommitLog
    
let processCommitLogs() =
  Lwt_unix.run
    (Globals.allHostsIter (fun h -> processCommitLogOnHost h ()))
    
(* ------------------------------------------------------------ *)
    
let deleteLocal (fspath, ( workingDirOpt, path)) =
  (* when the workingDirectory is set, we are dealing with a temporary file *)
  (* so we don't call the stasher in this case.                             *)
  ( match workingDirOpt with
    Some p -> 
      debug (fun () -> Util.msg  "DeleteLocal [%s] (%s, %s)\n" (Fspath.toString fspath) (Fspath.toString p) (Path.toString path));
      Os.delete p path
  | None ->
      debug (fun () -> Util.msg "DeleteLocal [%s] (None, %s)\n" (Fspath.toString fspath) (Path.toString path));
      Stasher.removeAndBackupAsAppropriate fspath path fspath path
	);
  Lwt.return ()
    
let performDelete = Remote.registerRootCmd "delete" deleteLocal
    
(* FIX: maybe we should rename the destination before making any check ? *)
let delete rootFrom pathFrom rootTo pathTo ui =
  Update.transaction (fun id ->
    Update.replaceArchive rootFrom pathFrom None Update.NoArchive id true
      >>= (fun _ ->
    (* Unison do the next line cause we want to keep a backup of the file.
       FIX: We only need this when we are making backups *)
	Update.updateArchive rootTo pathTo ui id >>= (fun _ ->
	  Update.replaceArchive
	    rootTo pathTo None Update.NoArchive id true >>= (fun localPathTo ->
    (* Make sure the target is unchanged *)
    (* (There is an unavoidable race condition here.) *)
	      Update.checkNoUpdates rootTo pathTo ui >>= (fun () ->
		performDelete rootTo (None, localPathTo))))))
    
(* ------------------------------------------------------------ *)
    
let setPropRemote =
  Remote.registerRootCmd
    "setProp"
    (fun (fspath, (workingDir, path, kind, newDesc)) ->
      Fileinfo.set workingDir path kind newDesc;
      Lwt.return ())
    
let setPropRemote2 =
  Remote.registerRootCmd
    "setProp2"
    (fun (fspath, (path, kind, newDesc)) ->
       let (workingDir,realPath) = Fspath.findWorkingDir fspath path in
       Fileinfo.set workingDir realPath kind newDesc;
       Lwt.return ())
    
(* FIX: we should check there has been no update before performing the
   change *)
let setProp fromRoot fromPath toRoot toPath newDesc oldDesc uiFrom uiTo =
  debug (fun() ->
    Util.msg
      "setProp %s %s %s\n   %s %s %s\n"
      (root2string fromRoot) (Path.toString fromPath)
      (Props.toString newDesc)
      (root2string toRoot) (Path.toString toPath)
      (Props.toString oldDesc));
  Update.transaction (fun id ->
    Update.updateProps fromRoot fromPath None uiFrom id >>= (fun _ ->
    (* [uiTo] provides the modtime while [desc] provides the other
       file properties *)
    Update.updateProps toRoot toPath (Some newDesc) uiTo id >>=
      (fun toLocalPath ->
	setPropRemote2 toRoot (toLocalPath, `Update oldDesc, newDesc))))
    
(* ------------------------------------------------------------ *)
    
let mkdirRemote =
  Remote.registerRootCmd
    "mkdir"
    (fun (fspath,(workingDir,path)) ->
      Os.createDir workingDir path Props.dirDefault;
      Lwt.return (Fileinfo.get false workingDir path).Fileinfo.desc)
    
let mkdir onRoot workingDir path = mkdirRemote onRoot (workingDir,path)
    
(* ------------------------------------------------------------ *)
    
let renameLocal (root, (fspath, pathFrom, pathTo)) =
  debug (fun () -> Util.msg "Renaming %s to %s in %s; root is %s\n" 
      (Path.toString pathFrom) 
      (Path.toString pathTo) 
      (Fspath.toString fspath) 
      (Fspath.toString root));
  let localTargetPath =
    Fspath.fullLocalPath (Fspath.toString root) fspath pathTo in
  let source = Fspath.concat fspath pathFrom in
  let target = Fspath.concat fspath pathTo in
  Util.convertUnixErrorsToTransient
    (Printf.sprintf "renaming %s to %s"
       (Fspath.toString source) (Fspath.toString target))
    (fun () ->
      debugverbose (fun() ->
        Util.msg "calling Fileinfo.get from renameLocal\n");
      let filetypeFrom =
        (Fileinfo.get false source Path.empty).Fileinfo.typ in
      debugverbose (fun() ->
        Util.msg "back from Fileinfo.get from renameLocal\n");
      if filetypeFrom = `ABSENT then raise (Util.Transient (Printf.sprintf
           "Error while renaming %s to %s -- source file has disappeared!"
	   (Fspath.toString source) (Fspath.toString target)));
      let filetypeTo =
        (Fileinfo.get false target Path.empty).Fileinfo.typ in
      let source' = Fspath.toString source in (* only for debugmsg, delete? *)
      let target' = Fspath.toString target in (* only for debugmsg, delete? *)
      
       (* Windows and Unix operate differently if the target path of a
          rename already exists: in Windows an exception is raised, in
          Unix the file is clobbered.  In both Windows and Unix, if
          the target is an existing **directory**, an exception will
          be raised.  We want to avoid doing the move first, if possible,
          because this opens a "window of danger" during which the contents of
          the path is nothing. *)
      let moveFirst =
        match (filetypeFrom, filetypeTo) with
        | (_, `ABSENT)            -> false
        | ((`FILE | `SYMLINK),
           (`FILE | `SYMLINK))    -> Util.osType <> `Unix
        | _                       -> true (* Safe default *)
      in
      if moveFirst then begin
        let tmpPath = Os.tempPath fspath pathTo in
        let temp = Fspath.concat fspath tmpPath in
        let temp' = Fspath.toString temp in
        writeCommitLog source target temp';

        debug (fun() -> Util.msg "moving %s to %s\n" target' temp');
        match Os.renameIfAllowed target Path.empty temp Path.empty with
          None ->  
            (* If the renaming fails, we will be left with
               DANGER.README file which will make any other
               (similar) renaming fail in a cryptic way.  So, it
               seems better to abort early. *)
            Util.convertUnixErrorsToFatal "renaming with commit log"
              (fun () ->
                debug (fun() -> Util.msg "rename %s to %s\n" source' target');
                Os.rename "renameLocal" source Path.empty target Path.empty;
                Stasher.removeAndBackupAsAppropriate temp Path.empty root localTargetPath;
                clearCommitLog())
        | Some e ->
            (* We are not able to move the file.  We clear the commit
               log as nothing happened, then fail. *)
            clearCommitLog();
            Util.convertUnixErrorsToTransient "renaming" (fun () -> raise e)
      end else begin
        debug (fun() -> Util.msg "rename: moveFirst=false\n");
        Stasher.removeAndBackupAsAppropriate root localTargetPath root localTargetPath;
        Os.rename "renameLocal(2)" source Path.empty target Path.empty;
      end;
      Lwt.return ())
    
let renameOnHost = Remote.registerRootCmd "rename" renameLocal
    
(* FIX: maybe we should rename the destination before making any check ? *)
(* FIX: When this code was originally written, we assumed that the
   checkNoUpdates would happen immediately before the renameOnHost, so that
   the window of danger where other processes could invalidate the thing we
   just checked was very small.  But now that transport is multi-threaded,
   this window of danger could get very long because other transfers are
   saturating the link.  It would be better, I think, to introduce a real
   2PC protocol here, so that both sides would (locally and almost-atomically)
   check that their assumptions had not been violated and then switch the
   temp file into place, but remain able to roll back if something fails
   either locally or on the other side. *)
let rename root pathInArchive workingDir pathOld pathNew ui =
  debug (fun() ->
    Util.msg "rename(root=%s, pathOld=%s, pathNew=%s)\n"
      (root2string root)
      (Path.toString pathOld) (Path.toString pathNew));
  (* Make sure the target is unchanged, then do the rename.
     (Note that there is an unavoidable race condition here...) *)
  Update.checkNoUpdates root pathInArchive ui >>= (fun () ->
    renameOnHost root (workingDir, pathOld, pathNew))

(* ------------------------------------------------------------ *)

let checkContentsChangeLocal
      currfspath path archDesc archDig archStamp archRess =
  let info = Fileinfo.get true currfspath path in
  match archStamp with
    Fileinfo.InodeStamp inode
    when info.Fileinfo.inode = inode
        && Props.same_time info.Fileinfo.desc archDesc ->
	  if Props.length archDesc <> Props.length info.Fileinfo.desc then
	    raise (Util.Transient (Printf.sprintf
              "The file %s\nhas been modified during synchronization: transfer aborted.%s"
              (Fspath.concatToString currfspath path)
              (if Util.osType = `Win32 && (Prefs.read Update.fastcheck)="yes" then
                ("If this happens repeatedly, try running once with the "
                 ^ "fastcheck option set to 'no'")
              else "")))
  | _ ->
      (* Note that we fall back to the paranoid check (using a fingerprint)
         even if a CtimeStamp was provided, since we do not trust them
         completely. *)
      let info = Fileinfo.get true currfspath path in
      let (info, newDig) = Os.safeFingerprint currfspath path info None in
      if archDig <> newDig then
        raise (Util.Transient (Printf.sprintf
          "The file %s\nhas been modified during synchronization: transfer aborted"
          (Fspath.concatToString currfspath path)))

let checkContentsChangeOnHost =
  Remote.registerRootCmd
    "checkContentsChange"
    (fun (currfspath, (path, archDesc, archDig, archStamp, archRess)) ->
      checkContentsChangeLocal
        currfspath path archDesc archDig archStamp archRess;
      Lwt.return ())
    
let checkContentsChange root path archDesc archDig archStamp archRess =
  checkContentsChangeOnHost root (path, archDesc, archDig, archStamp, archRess)

(* ------------------------------------------------------------ *)

(* Calculate the target working directory and paths for the copy.
      workingDir  is an fspath naming the directory on the target
                  host where the copied file will actually live.
                  (In the case where pathTo names a symbolic link, this
                  will be the parent directory of the file that the
                  symlink points to, not the symlink itself.  Note that
                  this fspath may be outside of the replica, or even
                  on a different volume.)
      realPathTo  is the name of the target file relative to workingDir.
                  (If pathTo names a symlink, this will be the name of
                  the file pointed to by the symlink, not the name of the
                  link itself.)
      tempPathTo  is a temporary file name in the workingDir.  The file (or
                  directory structure) will first be copied here, then
                  "almost atomically" moved onto realPathTo. *)

let setupTargetPathsLocal (fspath, path) =
  let localPath = Update.translatePathLocal fspath path in
  let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in
  let tempPath = Os.tempPath workingDir realPath in
  Lwt.return (workingDir, realPath, tempPath, localPath)

let setupTargetPaths =
  Remote.registerRootCmd "setupTargetPaths" setupTargetPathsLocal

(* ------------------------------------------------------------ *)

let makeSymlink =
  Remote.registerRootCmd
    "makeSymlink"
    (fun (fspath, (workingDir, path, l)) ->
       Os.symlink workingDir path l;
       Lwt.return ())

let copyReg = Lwt_util.make_region 50

let copy
      update
      rootFrom pathFrom   (* copy from here... *)
      uiFrom              (* (and then check that this updateItem still
                             describes the current state of the src replica) *)
      rootTo pathTo       (* ...to here *)
      uiTo                (* (but, before committing the copy, check that
                             this updateItem still describes the current
                             state of the target replica) *)
      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
     >>= (fun (workingDir, realPathTo, tempPathTo, _) ->
  (* Inner loop for recursive copy... *)
  let rec copyRec pFrom      (* Path to copy from *)
                  pTo        (* (Temp) path to copy to *)
                  realPTo    (* Path where this file will ultimately be placed
                                (needed by rsync, which uses the old contents
                                of this file to optimize transfer) *)
                  f =        (* Source archive subtree for this path *)
    debug (fun() ->
      Util.msg "copyRec %s --> %s  (really to %s)\n"
        (Path.toString pFrom) (Path.toString pTo)
        (Path.toString realPTo));
    match f with
      Update.ArchiveFile (desc, dig, stamp, ress) ->
        Lwt_util.run_in_region copyReg 1 (fun () ->
          Abort.check id;
          Copy.file
            rootFrom pFrom rootTo workingDir pTo realPTo
            update desc dig ress id
            >>= (fun () ->
          checkContentsChange rootFrom pFrom desc dig stamp ress))
    | Update.ArchiveSymlink l ->
        Lwt_util.run_in_region copyReg 1 (fun () ->
          debug (fun() -> Util.msg "Making symlink %s/%s -> %s\n"
                            (root2string rootTo) (Path.toString pTo) l);
          Abort.check id;
          makeSymlink rootTo (workingDir, pTo, l))
    | Update.ArchiveDir (desc, children) ->
        Lwt_util.run_in_region copyReg 1 (fun () ->
          debug (fun() -> Util.msg "Creating directory %s/%s\n"
            (root2string rootTo) (Path.toString pTo));
          mkdir rootTo workingDir pTo) >>= (fun initialDesc ->
        Abort.check id;
        let runningThreads = ref [] in
        Lwt.catch
          (fun () ->
             Update.NameMap.iter
               (fun name child ->
                  let thread =
                    copyRec (Path.child pFrom name)
                            (Path.child pTo name)
                            (Path.child realPTo name)
                            child
                  in
                  runningThreads := thread :: !runningThreads)
               children;
             Lwt_util.join !runningThreads)
          (fun e ->
             (* If one thread fails (in a non-fatal way), we wait for
                all other threads to terminate before continuing *)
             if not (Abort.testException e) then Abort.file id;
             match e with
               Util.Transient _ ->
                 let e = ref e in
                 Lwt_util.iter
                   (fun act ->
                      Lwt.catch
                         (fun () -> act)
                         (fun e' ->
                            match e' with
                              Util.Transient _ ->
                                if Abort.testException !e then e := e';
                                Lwt.return ()
                            | _                ->
                                Lwt.fail e'))
                   !runningThreads >>= (fun () ->
                 Lwt.fail !e)
             | _ ->
                 Lwt.fail e) >>= (fun () ->
        Lwt_util.run_in_region copyReg 1 (fun () ->
          (* We use the actual file permissions so as to preserve
             inherited bits *)
          Abort.check id;
          setPropRemote rootTo
            (workingDir, pTo, `Set initialDesc, desc))))
    | Update.NoArchive ->
        assert false
  in
  Remote.Thread.unwindProtect
    (fun () ->
       Update.transaction (fun id ->
         (* Update the archive on the source replica (but don't commit
            the changes yet) and return the part of the new archive
            corresponding to this path *)
         Update.updateArchive rootFrom pathFrom uiFrom id
           >>= (fun (localPathFrom, archFrom) ->
         let make_backup =
           (* Perform (asynchronously) a backup of the destination files *)
           Update.updateArchive rootTo pathTo uiTo id
         in
         copyRec localPathFrom tempPathTo realPathTo archFrom >>= (fun () ->
         make_backup >>= (fun _ ->
         Update.replaceArchive
           rootTo pathTo (Some (workingDir, tempPathTo))
           archFrom id true >>= (fun _ ->
         rename rootTo pathTo workingDir tempPathTo realPathTo uiTo ))))))
    (fun _ ->
       performDelete rootTo (Some workingDir, tempPathTo)))

(* A PARTIALLY COMPLETE HACKED VERSION THAT COPIES DIRECTORIES IN PLACE -- Jan 14, 2006

(This is left here in case Jerome gets a chance to finish it...)

let copy
      update
      rootFrom pathFrom   (* copy from here... *)
      uiFrom              (* (and then check that this updateItem still
                             describes the current state of the src replica) *)
      rootTo pathTo       (* ...to here *)
      uiTo                (* (but, before committing the copy, check that
                             this updateItem still describes the current
                             state of the target replica) *)
      id =                (* for progress display *)
  debug (fun() ->
    Util.msg
      "copy %s %s ---> %s %s \n"
      (root2string rootFrom) (Path.toString pathFrom)
      (root2string rootTo) (Path.toString pathTo));
  (* Inner loop for recursive copy... *)
  let rec copyRec pFrom      (* Path to copy from *)
                  pTo        (* (Temp) path to copy to *)
                  f =        (* Source archive subtree for this path *)
    debug (fun() ->
      Util.msg "copyRec %s --> %s\n"
        (Path.toString pFrom) (Path.toString pTo));
    (* Calculate target paths *)
    setupTargetPaths rootTo pTo
       >>= (fun (workingDir, realPathTo, tempPathTo, _) ->
    match f with
      Update.ArchiveFile (desc, dig, stamp, ress) ->
        Lwt_util.run_in_region copyReg 1 (fun () ->
          Abort.check id;
          Copy.file
            rootFrom pFrom rootTo workingDir tempPathTo realPathTo
            update desc dig ress id
            >>= (fun () ->
          checkContentsChange rootFrom pFrom desc dig stamp ress))
    | Update.ArchiveSymlink l ->
        Lwt_util.run_in_region copyReg 1 (fun () ->
          debug (fun() -> Util.msg "Making symlink %s/%s -> %s\n"
                            (root2string rootTo) (Path.toString pTo) l);
          Abort.check id;
          makeSymlink rootTo (workingDir, tempPathTo, l))
    | Update.ArchiveDir (desc, children) ->
        Lwt_util.run_in_region copyReg 1 (fun () ->
          debug (fun() -> Util.msg "Creating directory %s/%s\n"
            (root2string rootTo) (Path.toString pTo));
          mkdir rootTo workingDir realPathTo) >>= (fun initialDesc ->
        Abort.check id;
        let runningThreads = ref [] in
        Lwt.catch
          (fun () ->
             Update.NameMap.iter
               (fun name child ->
                  let thread =
                    copyRec (Path.child pFrom name)
                            (Path.child pTo name)
                            child
                  in
                  runningThreads := thread :: !runningThreads)
               children;
             Lwt_util.join !runningThreads)
          (fun e ->
             (* If one thread fails (in a non-fatal way), we wait for
                all other threads to terminate before continuing *)
             if not (Abort.testException e) then Abort.file id;
             match e with
               Util.Transient _ ->
                 let e = ref e in
                 Lwt_util.iter
                   (fun act ->
                      Lwt.catch
                         (fun () -> act)
                         (fun e' ->
                            match e' with
                              Util.Transient _ ->
                                if Abort.testException !e then e := e';
                                Lwt.return ()
                            | _                ->
                                Lwt.fail e'))
                   !runningThreads >>= (fun () ->
                 Lwt.fail !e)
             | _ ->
                 Lwt.fail e) >>= (fun () ->
        Lwt_util.run_in_region copyReg 1 (fun () ->
          (* We use the actual file permissions so as to preserve
             inherited bits *)
          Abort.check id;
          setPropRemote rootTo
            (workingDir, realPathTo, `Set initialDesc, desc))))
    | Update.NoArchive ->
        assert false)
  in
  Update.transaction (fun id ->
    (* Update the archive on the source replica (but don't commit
       the changes yet) and return the part of the new archive
       corresponding to this path *)
    Update.updateArchive rootFrom pathFrom uiFrom id
      >>= (fun (localPathFrom, archFrom) ->
    (* Perform (asynchronously) a backup of the destination files *)
    Update.updateArchive rootTo pathTo uiTo id >>= (fun _ ->
(*
  Remote.Thread.unwindProtect
      (fun () ->
*)
           copyRec localPathFrom pathTo archFrom >>= (fun () ->
(*
           rename rootTo pathTo workingDir tempPathTo realPathTo uiTo ))
      (fun _ ->
         performDelete rootTo (Some workingDir, tempPathTo)) >>= (fun () ->
*)
    Update.replaceArchive
      rootTo pathTo (Some (workingDir, tempPathTo))
      archFrom id true))))

*)   
   

(* ------------------------------------------------------------ *)

(*
let readChannelTillEof c =
  let rec loop lines =
    try let l = input_line c in
        loop (l::lines)
    with End_of_file -> lines in
  String.concat "\n" (Safelist.rev (loop []))
*)

let readChannelTillEof_lwt c =
  let rec loop lines =
    let lo =
      try
        Some(Lwt_unix.run (Lwt_unix.input_line c))
      with End_of_file -> None
    in
    match lo with
      Some l -> loop (l :: lines)
    | None   -> lines
  in
  String.concat "\n" (Safelist.rev (loop []))

let (>>=) = Lwt.bind

let readChannelsTillEof l =
  let rec suckitdry lines c =
    Lwt.catch
      (fun() -> Lwt_unix.input_line c >>= (fun l -> return (Some l)))
      (fun e -> match e with End_of_file -> return None | _ -> raise e)
    >>= (fun lo ->
           match lo with
             None -> return lines
           | Some l -> suckitdry (l :: lines) c) in
  Lwt_util.map
    (fun c ->
       suckitdry [] c
       >>= (fun res -> return (String.concat "\n" (Safelist.rev res))))
    l

let diffCmd =
  Prefs.createString "diff" "diff -u"
    "*command for showing differences between files"
    ("This preference can be used to control the name and command-line "
     ^ "arguments of the system "
     ^ "utility used to generate displays of file differences.  The default "
     ^ "is `\\verb|diff -u|'.  If the value of this preference contains the substrings "
     ^ "CURRENT1 and CURRENT2, these will be replaced by the names of the files to be "
     ^ "diffed.  If not, the two filenames will be appended to the command.  In both "
     ^ "cases, the filenames are suitably quoted.")

(* Using single quotes is simpler under Unix but they are not accepted
   by the Windows shell.  Double quotes without further quoting is
   sufficient with Windows as filenames are not allowed to contain
   double quotes. *)
let quotes s =
  if Util.osType = `Win32 && not Util.isCygwin then
    "\"" ^ s ^ "\""
  else
    "'" ^ Util.replacesubstring s "'" "'\''" ^ "'"

let rec diff root1 path1 ui1 root2 path2 ui2 showDiff id =
  debug (fun () ->
    Util.msg
      "diff %s %s %s %s ...\n"
      (root2string root1) (Path.toString path1)
      (root2string root2) (Path.toString path2));
  let displayDiff fspath1 fspath2 =
    let cmd =
      if Util.findsubstring "CURRENT1" (Prefs.read diffCmd) = None then
          (Prefs.read diffCmd)
        ^ " " ^ (quotes (Fspath.toString fspath1))
        ^ " " ^ (quotes (Fspath.toString fspath2))
      else
        Util.replacesubstrings (Prefs.read diffCmd)
          ["CURRENT1", quotes (Fspath.toString fspath1);
           "CURRENT2", quotes (Fspath.toString fspath2)] in
    let c = Lwt_unix.run (Lwt_unix.open_process_in cmd) in
    showDiff cmd (readChannelTillEof_lwt c);
    ignore (Lwt_unix.run (Lwt_unix.close_process_in c)) in
  let (desc1, fp1, ress1, desc2, fp2, ress2) = Common.fileInfos ui1 ui2 in
  match root1,root2 with
    (Local,fspath1),(Local,fspath2) ->
      Util.convertUnixErrorsToTransient
        "diffing files"
        (fun () ->
           let path1 = Update.translatePathLocal fspath1 path1 in
           let path2 = Update.translatePathLocal fspath2 path2 in
           displayDiff
             (Fspath.concat fspath1 path1) (Fspath.concat fspath2 path2))
  | (Local,fspath1),(Remote host2,fspath2) ->
      Util.convertUnixErrorsToTransient
        "diffing files"
        (fun () ->
           let path1 = Update.translatePathLocal fspath1 path1 in
           let (workingDir, realPath) = Fspath.findWorkingDir fspath1 path1 in
           let tmppath =
             Path.addSuffixToFinalName realPath "#unisondiff-" in
           Os.delete workingDir tmppath;
           Lwt_unix.run
             (Update.translatePath root2 path2 >>= (fun path2 ->
              Copy.file root2 path2 root1 workingDir tmppath realPath
                `Copy (Props.setLength Props.fileSafe (Props.length desc2))
                 fp2 ress2 id));
           displayDiff
	     (Fspath.concat workingDir realPath)
             (Fspath.concat workingDir tmppath);
           Os.delete workingDir tmppath)
  | (Remote host1,fspath1),(Local,fspath2) ->
      Util.convertUnixErrorsToTransient
        "diffing files"
        (fun () ->
           let path2 = Update.translatePathLocal fspath2 path2 in
           let (workingDir, realPath) = Fspath.findWorkingDir fspath2 path2 in
           let tmppath =
             Path.addSuffixToFinalName realPath "#unisondiff-" in
           Lwt_unix.run
             (Update.translatePath root1 path1 >>= (fun path1 ->
              (* Note that we don't need the resource fork *)
              Copy.file root1 path1 root2 workingDir tmppath realPath
                `Copy (Props.setLength Props.fileSafe (Props.length desc1))
                 fp1 ress1 id));
           displayDiff
             (Fspath.concat workingDir tmppath)
	     (Fspath.concat workingDir realPath);
           Os.delete workingDir tmppath)
  | (Remote host1,fspath1),(Remote host2,fspath2) ->
      assert false


(**********************************************************************)

(* Taken from ocamltk/jpf/fileselect.ml *)
let get_files_in_directory dir =
  let dirh = Fspath.opendir (Fspath.canonize (Some dir)) in
  let files = ref [] in
  begin try
    while true do files := Unix.readdir dirh :: !files done
  with End_of_file ->
    Unix.closedir dirh
  end;
  Sort.list (<) !files

let ls dir pattern =
  Util.convertUnixErrorsToTransient
    "listing files"
    (fun () ->
       let files = get_files_in_directory dir in
       let re = Rx.glob pattern in
       let rec filter l =
         match l with
           [] ->
             []
         | hd :: tl ->
             if Rx.match_string re hd then hd :: filter tl else filter tl
       in
       filter files)


(***********************************************************************
                  CALL OUT TO EXTERNAL MERGE PROGRAM
************************************************************************)

let formatMergeCmd p f1 f2 backup out1 out2 outarch =
  if not (Globals.shouldMerge p) then
    raise (Util.Transient ("'merge' preference not set for "^(Path.toString p)));
  let raw =
    try Globals.mergeCmdForPath p
    with Not_found ->
      raise (Util.Transient ("'merge' preference does not provide a command "
                             ^ "template for " ^ (Path.toString p)))
  in
  let cooked = raw in
  let cooked = Util.replacesubstring cooked "CURRENT1" f1 in
  let cooked = Util.replacesubstring cooked "CURRENT2" f2 in
  let cooked =
    match backup with
      None -> begin
	let cooked = Util.replacesubstring cooked "CURRENTARCHOPT" "" in
	match Util.findsubstring "CURRENTARCH" cooked with
	  None -> cooked
	| Some _ -> raise (Util.Transient ("No archive found whereas the "^
					   "'merge' command template expects one"))
      end
    | Some(s) ->
	let cooked = Util.replacesubstring cooked "CURRENTARCHOPT" s in
	let cooked = Util.replacesubstring cooked "CURRENTARCH"    s in
        cooked in
  let cooked = Util.replacesubstring cooked "NEW1"     out1 in
  let cooked = Util.replacesubstring cooked "NEW2"     out2 in
  let cooked = Util.replacesubstring cooked "NEWARCH"  outarch in
  let cooked = Util.replacesubstring cooked "NEW" out1 in
  let cooked = Util.replacesubstring cooked "PATH" (Path.toString p) in
  cooked
    
let copyBack fspathFrom pathFrom rootTo pathTo propsTo uiTo id =
  setupTargetPaths rootTo pathTo
    >>= (fun (workingDirForCopy, realPathTo, tempPathTo, localPathTo) ->
  let info = Fileinfo.get false fspathFrom pathFrom in
  let fp = Os.fingerprint fspathFrom pathFrom info in
  let stamp = Osx.stamp info.Fileinfo.osX in
  let newprops = Props.setLength propsTo (Props.length info.Fileinfo.desc) in
  Copy.file
    (Local, fspathFrom) pathFrom rootTo workingDirForCopy tempPathTo realPathTo
    `Copy newprops fp stamp id >>= (fun () ->
      rename rootTo pathTo workingDirForCopy tempPathTo realPathTo
        uiTo ))
    
let keeptempfilesaftermerge =   
  Prefs.createBool
    "keeptempfilesaftermerge" false "*" ""

let makeSureMergeTempfilesAreIgnored () =
  Globals.addRegexpToIgnore "Name .unisonmerge*"

let merge root1 root2 path id ui1 ui2 showMergeFn =
  debug (fun () -> Util.msg "merge path %s between roots %s and %s\n"
      (Path.toString path) (root2string root1) (root2string root2));

  let (localPath1, (workingDirForMerge, basep), fspath1) =
    match root1 with
      (Local,fspath1) ->
        let localPath1 = Update.translatePathLocal fspath1 path in
        (localPath1, Fspath.findWorkingDir fspath1 localPath1, fspath1)
    | _ -> assert false (* roots are sorted: first root is always local *)
           (* FIX: I (JV) believe this assumption is wrong: roots are not sorted... *)
           (* Sigh.  Fixing this will require some restructuring of the following... *) in
  
  (* We're going to be doing a lot of copying, so let's define a shorthand
     that fixes most of the arguments to Copy.localfile *)
  let copy l =
    Safelist.iter
      (fun (src,trg) ->
        debug (fun () -> Util.msg "Copying %s to %s\n" (Path.toString src) (Path.toString trg));
        Os.delete workingDirForMerge trg;
        let info = Fileinfo.get false workingDirForMerge src in
        Copy.localFile
          workingDirForMerge src
          workingDirForMerge trg trg
          `Copy info.Fileinfo.desc
          (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) (Some id))
      l in
  
  (* These names should be automatically ignored!  And probably we should use
     names that will be recognized as temp by ordinary Unix programs -- e.g.,
     beginning with dot.  Perhaps the update detection sweep should remove them
     automatically.  *)
  let working1 = Path.addPrefixToFinalName basep ".unisonmerge1-" in
  let working2 = Path.addPrefixToFinalName basep ".unisonmerge2-" in
  let workingarch = Path.addPrefixToFinalName basep ".unisonmergearch-" in
  let new1 = Path.addPrefixToFinalName basep ".unisonmergenew1-" in
  let new2 = Path.addPrefixToFinalName basep ".unisonmergenew2-" in
  let newarch = Path.addPrefixToFinalName basep ".unisonmergenewarch-" in
  
  let (desc1, fp1, ress1, desc2, fp2, ress2) = Common.fileInfos ui1 ui2 in
  
  Util.convertUnixErrorsToTransient "merging files" (fun () ->
    (* Install finalizer (see below) in case we unwind the stack *)
    Util.finalize (fun () ->
      
    (* Make local copies of the two replicas *)
      Os.delete workingDirForMerge working1;
      Os.delete workingDirForMerge working2;
      Os.delete workingDirForMerge workingarch;
      Lwt_unix.run
	(Copy.file
           root1 localPath1 root1 workingDirForMerge working1 basep
           `Copy desc1 fp1 ress1 id);
      Lwt_unix.run
	(Update.translatePath root2 path >>= (fun path ->
	  Copy.file
	    root2 path root1 workingDirForMerge working2 basep
	    `Copy desc2 fp2 ress2 id));
      
      (* retrieve the archive for this file, if any *)
      let arch =
	match ui1, ui2 with
	| Updates (_, Previous (_,_,dig,_)), Updates (_, Previous (_,_,dig2,_)) ->
	    if dig = dig2 then
	      Stasher.getRecentVersion fspath1 localPath1 dig 
	    else
	      assert false
	| NoUpdates, Updates(_, Previous (_,_,dig,_))
	| Updates(_, Previous (_,_,dig,_)), NoUpdates -> 
	    Stasher.getRecentVersion fspath1 localPath1 dig
	| Updates (_, New), Updates(_, New) 
	| Updates (_, New), NoUpdates
	| NoUpdates, Updates (_, New) ->
	    debug (fun () -> Util.msg "File is new, no current version will be searched");
	    None
	| _ -> assert false

      in
      
      (* make a local copy of the archive file (in case the merge program  
         overwrites it and the program crashes before the call to the Stasher) *)
      let _ = 
	match arch with 
	  Some fspath ->
	    let info = Fileinfo.get false fspath Path.empty in
	    Copy.localFile 
	      fspath Path.empty 
	      workingDirForMerge workingarch workingarch
	      `Copy 
	      info.Fileinfo.desc
	      (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo)
	      None ;
	| None ->
	    () in
	    
      (* run the merge command *)
      Os.delete workingDirForMerge new1;
      Os.delete workingDirForMerge new2;
      Os.delete workingDirForMerge newarch;
      let info1 = Fileinfo.get false workingDirForMerge working1 in
      (* FIX: Why split out the parts of the pair?  Why is it not abstract anyway??? *)
      let dig1 = Os.fingerprint workingDirForMerge working1 info1 in
      let info2 = Fileinfo.get false workingDirForMerge working2 in
      let dig2 = Os.fingerprint workingDirForMerge working2 info2 in
      let cmd = formatMergeCmd
          path
          (Fspath.concatToString workingDirForMerge working1)
          (Fspath.concatToString workingDirForMerge working2)
          (match arch with 
	    None -> None 
	  | Some f -> Some(Fspath.toString f))
          (Fspath.concatToString workingDirForMerge new1)
          (Fspath.concatToString workingDirForMerge new2)
          (Fspath.concatToString workingDirForMerge newarch) in
      Trace.log (Printf.sprintf "%s\n" cmd);
      
      let returnValue, mergeResultLog = 
        Lwt_unix.run (
          Lwt_unix.open_process_full cmd (Unix.environment ()) 
          >>= (fun (out, ipt, err) ->
          readChannelsTillEof [out;err]
          >>= (function [mergeLogOut;mergeLogErr] ->
          Lwt_unix.close_process_full (out, ipt, err)
          >>= (fun returnValue ->
          return (returnValue, (
              cmd
            ^ "\n\n" ^
              (if mergeLogOut = "" || mergeLogErr = ""
                 then mergeLogOut ^ mergeLogErr
               else mergeLogOut ^ "\n\n" ^ ("Error Output:"^mergeLogErr))
            ^"\n\n" 
            ^ (if returnValue = Unix.WEXITED 0
               then ""
               else Util.process_status_to_string returnValue))))
            (* Stop typechechecker from complaining about non-exhaustive pattern above *)
            | _ -> assert false))) in
      
      if not
          (showMergeFn
	     (returnValue = Unix.WEXITED 0)
             (Printf.sprintf "Results of merging %s" (Path.toString path))
             mergeResultLog) then
        raise (Util.Transient ("Merge command failed or cancelled by the user"));
      
      (* Check which files got created by the merge command and do something appropriate
         with them *)
      let new1exists = Sys.file_exists (Fspath.concatToString workingDirForMerge new1) in
      let new2exists = Sys.file_exists (Fspath.concatToString workingDirForMerge new2) in
      let newarchexists = Sys.file_exists (Fspath.concatToString workingDirForMerge newarch) in
      
      if new1exists && new2exists then begin
        if newarchexists then 
	  debug (fun () -> Util.msg "Three outputs detected \n")
	else
	  debug (fun () -> Util.msg "Two outputs detected \n");
        let info1 = Fileinfo.get false workingDirForMerge new1 in
        let info2 = Fileinfo.get false workingDirForMerge new2 in
        let dig1' = Os.fingerprint workingDirForMerge new1 info1 in
        let dig2' = Os.fingerprint workingDirForMerge new2 info2 in
        if dig1'=dig2' then begin
          debug (fun () -> Util.msg "Two outputs equal => update the archive\n");
          copy [(new1,working1); (new2,working2); (new1,workingarch)];
	end else
	  if returnValue = Unix.WEXITED 0 then begin
            debug (fun () -> (Util.msg "Two outputs not equal but merge command returned 0, so we will\n";
			      Util.msg "overwrite the other replica and the archive with the first output\n"));
	    copy [(new1,working1); (new1,working2); (new1,workingarch)];
	  end else begin
	    raise (Util.Transient "Merge command exited with non-zero status and left the two files unequal")
          end 
      end
	  
      else if new1exists && (not new2exists) && (not newarchexists) 
	  && returnValue = Unix.WEXITED 0 then begin
            debug (fun () -> Util.msg "One output detected \n");
            copy [(new1,working1); (new1,working2); (new1,workingarch)];
	  end
	  
      else if (not new1exists) && new2exists && (not newarchexists) then begin
        assert false
      end
	  
      else if (not new1exists) && (not new2exists) && (not newarchexists) then begin
        debug (fun () -> Util.msg "No outputs detected \n");
        let working1_still_exists = Sys.file_exists (Fspath.concatToString workingDirForMerge working1) in
        let working2_still_exists = Sys.file_exists (Fspath.concatToString workingDirForMerge working2) in
	
        if working1_still_exists && working2_still_exists then begin
          debug (fun () -> Util.msg "No output from merge cmd and both original files are still present\n");
          let info1' = Fileinfo.get false workingDirForMerge working1 in
          let dig1' = Os.fingerprint workingDirForMerge working1 info1' in
          let info2' = Fileinfo.get false workingDirForMerge working2 in
          let dig2' = Os.fingerprint workingDirForMerge working2 info2' in
          if dig1 = dig1' && dig2 = dig2' then
            raise (Util.Transient "Merge program didn't change either temp file");
          if dig1' = dig2' then begin
            debug (fun () -> Util.msg "Merge program made files equal\n");
            copy [(working1,workingarch)];
          end else if dig2 = dig2' then begin
            debug (fun () -> Util.msg "Merge program changed just first input\n");
            copy [(working1,working2);(working1,workingarch)]
          end else if dig1 = dig1' then begin
            debug (fun () -> Util.msg "Merge program changed just second input\n");
            copy [(working2,working1);(working2,workingarch)]
          end else
	    if returnValue <> Unix.WEXITED 0 then
	      raise (Util.Transient ("Error: the merge function changed both of "
                                     ^ "its inputs but did not make them equal"))
	    else begin
	      debug (fun () -> (Util.msg "Merge program changed both of its inputs in";
				Util.msg "different ways, but returned zero.\n"));
              copy [(working2,working1);(working2,workingarch)];
	    end
        end
	    
        else if working1_still_exists && (not working2_still_exists) 
	    && returnValue = Unix.WEXITED 0 then begin
              debug (fun () -> Util.msg "No outputs and second replica has been deleted \n");
              copy [(working1,working2); (working1,workingarch)];
            end
	    
        else if (not working1_still_exists) && working2_still_exists 
	    && returnValue = Unix.WEXITED 0 then begin
              debug (fun () -> Util.msg "No outputs and first replica has been deleted \n");
              copy [(working2,working1); (working2,workingarch)];
            end
	    
        else
	  if returnValue = Unix.WEXITED 0 then
            raise (Util.Transient ("Error: the merge program deleted both of its "
                                   ^ "inputs and generated no output!"))
	  else
	    raise (Util.Transient ("Error: the merge program failed but did not leave"
				   ^ " both files equal"))
      end;
      
      Lwt_unix.run
	(debug (fun () -> Util.msg "Committing results of merge\n");
         copyBack workingDirForMerge working1 root1 path desc1 ui1 id >>= (fun () ->
         copyBack workingDirForMerge working2 root2 path desc2 ui2 id >>= (fun () ->
         let arch_fspath = Fspath.concat workingDirForMerge workingarch in
         if (Sys.file_exists (Fspath.toString arch_fspath)) then begin
           debug (fun () -> Util.msg "Updating unison archives to reflect results of merge\n");
           let infoarch = Fileinfo.get false workingDirForMerge workingarch in
           let dig = Os.fingerprint arch_fspath Path.empty infoarch in
           debug (fun () -> Util.msg "New digest is %s\n" (Os.fullfingerprint_to_string dig));
           let new_archive_entry =
             Update.ArchiveFile
               (Props.get (Fspath.stat arch_fspath) infoarch.osX, dig,
                Fileinfo.stamp (Fileinfo.get true arch_fspath Path.empty),
                Osx.stamp infoarch.osX) in
           Update.transaction
             (fun transid ->
                Update.replaceArchive root1 path
                 (Some(workingDirForMerge, workingarch))
                 new_archive_entry transid false >>= (fun _ ->
                Update.replaceArchive root2 path
                  (Some(workingDirForMerge, workingarch))
                  new_archive_entry transid false >>= (fun _ ->
                Lwt.return ())))
         end else 
           (Lwt.return ()) )))))
    (fun _ ->
      Util.ignoreTransientErrors
	(fun () ->
           if not (Prefs.read keeptempfilesaftermerge) then begin
             Os.delete workingDirForMerge working1;
             Os.delete workingDirForMerge working2;
             Os.delete workingDirForMerge workingarch;
             Os.delete workingDirForMerge new1;
             Os.delete workingDirForMerge new2;
             Os.delete workingDirForMerge newarch
           end))