files.ml (57705B)
1 (* Unison file synchronizer: src/files.ml *) 2 (* Copyright 1999-2020, Benjamin C. Pierce 3 4 This program is free software: you can redistribute it and/or modify 5 it under the terms of the GNU General Public License as published by 6 the Free Software Foundation, either version 3 of the License, or 7 (at your option) any later version. 8 9 This program is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 GNU General Public License for more details. 13 14 You should have received a copy of the GNU General Public License 15 along with this program. If not, see <http://www.gnu.org/licenses/>. 16 *) 17 18 19 open Common 20 open Lwt 21 open Fileinfo 22 23 let debug = Trace.debug "files" 24 let debugverbose = Trace.debug "files+" 25 26 (* ------------------------------------------------------------ *) 27 28 let commitLogName = Util.fileInUnisonDir "DANGER.README" 29 30 let writeCommitLog source target tempname = 31 let sourcename = Fspath.toDebugString source in 32 let targetname = Fspath.toDebugString target in 33 debug (fun() -> Util.msg "Writing commit log: renaming %s to %s via %s\n" 34 sourcename targetname tempname); 35 Util.convertUnixErrorsToFatal 36 "writing commit log" 37 (fun () -> 38 let c = 39 System.open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_excl] 40 0o600 commitLogName in 41 Printf.fprintf c "Warning: the last run of %s terminated abnormally " 42 Uutil.myName; 43 Printf.fprintf c "while moving\n %s\nto\n %s\nvia\n %s\n\n" 44 sourcename targetname tempname; 45 Printf.fprintf c "Please check the state of these files immediately\n"; 46 Printf.fprintf c "(and delete this notice when you've done so).\n"; 47 close_out c) 48 49 let clearCommitLog tmpName = 50 debug (fun() -> (Util.msg "Deleting commit log\n")); 51 52 let commitLogNameWin () = 53 (* Work around an issue in Windows where unlink may not be immediate. *) 54 let p = commitLogName ^ (Filename.basename (Path.toString tmpName)) in 55 let rec tmp n = 56 let p = p ^ (string_of_int n) in 57 if System.file_exists p then tmp (n + 1) 58 else (System.rename commitLogName p; p) 59 in 60 try tmp 0 with 61 | Sys_error _ | Unix.Unix_error _ -> commitLogName 62 in 63 let commitLogUnlinkPath = 64 if Sys.unix then commitLogName else commitLogNameWin () in 65 66 Util.convertUnixErrorsToFatal 67 "clearing commit log" 68 (fun () -> System.unlink commitLogUnlinkPath) 69 70 let processCommitLog () = 71 if System.file_exists commitLogName then begin 72 raise(Util.Fatal( 73 Printf.sprintf 74 "Warning: the previous run of %s terminated in a dangerous state. 75 Please consult the file %s, delete it, and try again." 76 Uutil.myName 77 commitLogName)) 78 end else 79 Lwt.return () 80 81 let processCommitLogOnHost = 82 Remote.registerHostCmd "processCommitLog" Umarshal.unit Umarshal.unit processCommitLog 83 84 let processCommitLogs() = 85 Lwt_unix.run 86 (Globals.allRootsIter (fun r -> processCommitLogOnHost r ())) 87 88 (* ------------------------------------------------------------ *) 89 90 let copyOnConflict = Prefs.createBool "copyonconflict" false 91 ~category:(`Advanced `Syncprocess) 92 "keep copies of conflicting files" 93 "When this flag is set, Unison will make a copy of files that would \ 94 otherwise be overwritten or deleted in case of conflicting changes, \ 95 and more generally whenever the default behavior is overridden. \ 96 This makes it possible to automatically resolve conflicts in a \ 97 fairly safe way when synchronizing continuously, in combination \ 98 with the \\verb|-repeat watch| and \\verb|-prefer newer| preferences." 99 100 let prepareCopy workingDir path notDefault = 101 if notDefault && Prefs.read copyOnConflict then begin 102 match Fileinfo.getType true workingDir path with 103 | `ABSENT -> Some (workingDir, path, None) 104 | _ -> 105 begin 106 let tmpPath = Os.tempPath workingDir path in 107 Copy.recursively workingDir path workingDir tmpPath; 108 Some (workingDir, path, Some tmpPath) 109 end 110 end else 111 None 112 113 let finishCopy copyInfo = 114 match copyInfo with 115 Some (workingDir, path, tmpPathOpt) -> 116 let tm = Unix.localtime (Unix.gettimeofday ()) in 117 let rec copyPath n = 118 let p = 119 Path.addToFinalName path 120 (Format.sprintf " (conflict%s_on_%04d-%02d-%02d%s)" 121 (if n = 0 then "" else " #" ^ string_of_int n) 122 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday 123 (if tmpPathOpt = None then "_was_deleted" else "")) 124 in 125 if Os.exists workingDir p then copyPath (n + 1) else p 126 in begin 127 match tmpPathOpt with 128 | Some tmpPath -> 129 Os.rename "keepCopy" workingDir tmpPath workingDir (copyPath 0); 130 None 131 | None -> Some (copyPath 0) 132 end 133 | None -> 134 None 135 136 (* ------------------------------------------------------------ *) 137 138 let deleteLocal (fspathTo, (pathTo, ui, notDefault)) = 139 debug (fun () -> 140 Util.msg "deleteLocal [%s] (None, %s)\n" 141 (Fspath.toDebugString fspathTo) (Path.toString pathTo)); 142 let localPathTo = Update.translatePathLocal fspathTo pathTo in 143 let copyInfo = prepareCopy fspathTo localPathTo notDefault in 144 (* Make sure the target is unchanged first *) 145 (* (There is an unavoidable race condition here.) *) 146 let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in 147 ignore (finishCopy copyInfo); 148 Stasher.backup fspathTo localPathTo `AndRemove prevArch; 149 (* Archive update must be done last *) 150 Update.replaceArchiveLocal fspathTo localPathTo Update.NoArchive; 151 Lwt.return () 152 153 let convV0 = Remote.makeConvV0FunArg 154 (fun (fspathTo, (pathTo, ui, notDefault)) -> 155 (fspathTo, (pathTo, Common.ui_to_compat251 ui, notDefault))) 156 (fun (fspathTo, (pathTo, ui, notDefault)) -> 157 (fspathTo, (pathTo, Common.ui_of_compat251 ui, notDefault))) 158 159 let deleteOnRoot = Remote.registerRootCmd "delete" ~convV0 160 Umarshal.(prod3 Path.m Common.mupdateItem bool id id) Umarshal.unit 161 deleteLocal 162 163 let delete rootFrom pathFrom rootTo pathTo ui notDefault = 164 deleteOnRoot rootTo (pathTo, ui, notDefault) >>= fun _ -> 165 Update.replaceArchive rootFrom pathFrom Update.NoArchive 166 167 (* ------------------------------------------------------------ *) 168 169 let fileUpdated ui = 170 match ui with 171 Updates (File (_, ContentsUpdated _), _) -> true 172 | _ -> false 173 174 let setPropLocal (fspath, (path, ui, newDesc, oldDesc)) = 175 (* [ui] provides the modtime while [newDesc] provides the other 176 file properties *) 177 let localPath = Update.translatePathLocal fspath path in 178 let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in 179 Fileinfo.set workingDir realPath (`Update oldDesc) newDesc; 180 let newDesc = Props.purgeExtData newDesc in 181 if fileUpdated ui then Stasher.stashCurrentVersion fspath localPath None; 182 (* Archive update must be done last *) 183 Update.updateProps fspath localPath (Some newDesc) ui; 184 Lwt.return () 185 186 let convV0 = Remote.makeConvV0FunArg 187 (fun (fspath, (path, ui, newDesc, oldDesc)) -> 188 (fspath, (path, Common.ui_to_compat251 ui, 189 Props.to_compat251 newDesc, Props.to_compat251 oldDesc))) 190 (fun (fspath, (path, ui, newDesc, oldDesc)) -> 191 (fspath, (path, Common.ui_of_compat251 ui, 192 Props.of_compat251 newDesc, Props.of_compat251 oldDesc))) 193 194 let setPropOnRoot = Remote.registerRootCmd "setProp" ~convV0 195 Umarshal.(prod4 Path.m Common.mupdateItem Props.mx Props.m id id) Umarshal.unit 196 setPropLocal 197 198 let propOpt_to_compat251 = function 199 | Some prop -> Some (Props.to_compat251 prop) 200 | None -> None 201 202 let propOpt_of_compat251 = function 203 | Some prop -> Some (Props.of_compat251 prop) 204 | None -> None 205 206 let convV0 = Remote.makeConvV0FunArg 207 (fun (fspath, (path, propOpt, ui)) -> 208 (fspath, (Path.makeGlobal path, propOpt_to_compat251 propOpt, 209 Common.ui_to_compat251 ui))) 210 (fun (fspath, (path, propOpt, ui)) -> 211 (fspath, (Path.forceLocal path, 212 propOpt_of_compat251 propOpt, Common.ui_of_compat251 ui))) 213 214 let updatePropsOnRoot = 215 Remote.registerRootCmd 216 "updateProps" ~convV0 217 Umarshal.(prod3 Path.mlocal (option Props.m) Common.mupdateItem id id) 218 Umarshal.unit 219 (fun (fspath, (path, propOpt, ui)) -> 220 (* Previous versions of this function received a global path as input *) 221 let localPath = if Props.xattrEnabled () then path 222 else Update.translatePathLocal fspath (Path.makeGlobal path) in 223 (* Archive update must be done first *) 224 Update.updateProps fspath localPath propOpt ui; 225 if fileUpdated ui then 226 Stasher.stashCurrentVersion fspath localPath None; 227 Lwt.return ()) 228 229 let updateProps root path propOpt ui = 230 updatePropsOnRoot root (path, propOpt, ui) 231 232 (* FIX: we should check there has been no update before performing the 233 change *) 234 let setProp rootFrom pathFrom rootTo pathTo newDesc oldDesc uiFrom uiTo = 235 debug (fun() -> 236 Util.msg 237 "setProp %s %s %s\n %s %s %s\n" 238 (root2string rootFrom) (Path.toString pathFrom) 239 (Props.toString newDesc) 240 (root2string rootTo) (Path.toString pathTo) 241 (Props.toString oldDesc)); 242 Copy.readPropsExtDataG rootFrom pathFrom newDesc >>= fun (p, newDesc) -> 243 setPropOnRoot rootTo (pathTo, uiTo, newDesc, oldDesc) >>= fun _ -> 244 (match p with 245 | None -> Update.translatePath rootFrom pathFrom 246 | Some path -> Lwt.return path) >>= fun localPathFrom -> 247 updateProps rootFrom localPathFrom None uiFrom 248 249 (* ------------------------------------------------------------ *) 250 251 let convV0 = Remote.makeConvV0FunRet 252 (fun (b, desc) -> (b, Props.to_compat251 desc)) 253 (fun (b, desc) -> (b, Props.of_compat251 desc)) 254 255 let mkdirOnRoot = 256 Remote.registerRootCmd 257 "mkdir" ~convV0 258 Umarshal.(prod2 Fspath.m Path.mlocal id id) 259 Umarshal.(prod2 bool Props.mbasic id id) 260 (fun (fspath,(workingDir,path)) -> 261 let info = Fileinfo.getBasic false workingDir path in 262 if info.Fileinfo.typ = `DIRECTORY then begin 263 if not (Prefs.read Props.dontChmod) then begin try 264 (* Make sure the directory is writable *) 265 Fs.chmod (Fspath.concat workingDir path) 266 (Props.perms info.Fileinfo.desc lor 0o700) 267 with Unix.Unix_error _ -> () end; 268 Lwt.return (true, info.Fileinfo.desc) 269 end else begin 270 if info.Fileinfo.typ <> `ABSENT then 271 Os.delete workingDir path; 272 Os.createDir workingDir path (Props.perms Props.dirDefault); 273 Lwt.return (false, (Fileinfo.getBasic false workingDir path).desc) 274 end) 275 276 let convV0 = Remote.makeConvV0FunArg 277 (fun (fspath, (workingDir, path, initialDesc, newDesc)) -> 278 (fspath, (workingDir, path, 279 Props.to_compat251 initialDesc, Props.to_compat251 newDesc))) 280 (fun (fspath, (workingDir, path, initialDesc, newDesc)) -> 281 (fspath, (workingDir, path, 282 Props.of_compat251 initialDesc, Props.of_compat251 newDesc))) 283 284 let setDirPropOnRoot = 285 Remote.registerRootCmd 286 "setDirProp" ~convV0 287 Umarshal.(prod4 Fspath.m Path.mlocal Props.mbasic Props.mx id id) 288 Umarshal.unit 289 (fun (_, (workingDir, path, initialDesc, newDesc)) -> 290 Fileinfo.set workingDir path (`Set initialDesc) newDesc; 291 Lwt.return ()) 292 293 let makeSymlink = 294 Remote.registerRootCmd 295 "makeSymlink" 296 Umarshal.(prod3 Fspath.m Path.mlocal string id id) 297 Umarshal.unit 298 (fun (fspath, (workingDir, path, l)) -> 299 if Os.exists workingDir path then 300 Os.delete workingDir path; 301 let execInDir dir f = 302 let cwd = System.getcwd () in 303 begin try System.chdir dir with Sys_error _ -> () end; 304 f (); 305 begin try System.chdir cwd with Sys_error _ -> () end 306 in 307 let f () = Os.symlink workingDir path l in 308 (* Changing the working directory in Windows is a workaround to improve 309 the chances of [Unix.symlink] being able to figure out if a relative 310 symlink is supposed to be a file symlink or a directory symlink (this 311 differentiation only exists in Windows). *) 312 if not Sys.win32 then f () else execInDir (Fspath.toString workingDir) f; 313 Lwt.return ()) 314 315 (* ------------------------------------------------------------ *) 316 317 let performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch = 318 debug (fun () -> Util.msg "Renaming %s to %s in %s; root is %s\n" 319 (Path.toString pathFrom) 320 (Path.toString pathTo) 321 (Fspath.toDebugString workingDir) 322 (Fspath.toDebugString fspathTo)); 323 let source = Fspath.concat workingDir pathFrom in 324 let target = Fspath.concat workingDir pathTo in 325 Util.convertUnixErrorsToTransient 326 (Printf.sprintf "renaming %s to %s" 327 (Fspath.toDebugString source) (Fspath.toDebugString target)) 328 (fun () -> 329 debugverbose (fun() -> 330 Util.msg "calling Fileinfo.getType from renameLocal\n"); 331 let filetypeFrom = 332 Fileinfo.getType false source Path.empty in 333 debugverbose (fun() -> 334 Util.msg "back from Fileinfo.getType from renameLocal\n"); 335 if filetypeFrom = `ABSENT then raise (Util.Transient (Printf.sprintf 336 "Error while renaming %s to %s -- source file has disappeared!" 337 (Fspath.toPrintString source) (Fspath.toPrintString target))); 338 let filetypeTo = Fileinfo.getType false target Path.empty in 339 340 (* Windows and Unix operate differently if the target path of a 341 rename already exists: in Windows an exception is raised, in 342 Unix the file is clobbered. In both Windows and Unix, if 343 the target is an existing **directory**, an exception will 344 be raised. We want to avoid doing the move first, if possible, 345 because this opens a "window of danger" during which the contents of 346 the path is nothing. *) 347 let moveFirst = 348 match (filetypeFrom, filetypeTo) with 349 | (_, `ABSENT) -> false 350 | ((`FILE | `SYMLINK), 351 (`FILE | `SYMLINK)) -> Sys.win32 352 | _ -> true (* Safe default *) in 353 if moveFirst then begin 354 debug (fun() -> Util.msg "rename: moveFirst=true\n"); 355 let tmpPath = Os.tempPath workingDir pathTo in 356 let temp = Fspath.concat workingDir tmpPath in 357 let temp' = Fspath.toDebugString temp in 358 359 debug (fun() -> 360 Util.msg "moving %s to %s\n" (Fspath.toDebugString target) temp'); 361 Stasher.backup fspathTo localPathTo `ByCopying prevArch; 362 writeCommitLog source target temp'; 363 Util.finalize (fun() -> 364 (* If the first rename fails, the log can be removed: the 365 filesystem is in a consistent state *) 366 Os.rename "renameLocal(1)" target Path.empty temp Path.empty; 367 (* If the next renaming fails, we will be left with 368 DANGER.README file which will make any other 369 (similar) renaming fail in a cryptic way. So it 370 seems better to abort early by converting Unix errors 371 to Fatal ones (rather than Transient). *) 372 Util.convertUnixErrorsToFatal "renaming with commit log" 373 (fun () -> 374 debug (fun() -> Util.msg "rename %s to %s\n" 375 (Fspath.toDebugString source) 376 (Fspath.toDebugString target)); 377 Os.rename "renameLocal(2)" 378 source Path.empty target Path.empty)) 379 (fun _ -> clearCommitLog tmpPath); 380 (* It is ok to leave a temporary file. So, the log can be 381 cleared before deleting it. *) 382 Os.delete temp Path.empty 383 end else begin 384 debug (fun() -> Util.msg "rename: moveFirst=false\n"); 385 Stasher.backup fspathTo localPathTo `ByCopying prevArch; 386 Os.rename "renameLocal(3)" source Path.empty target Path.empty; 387 debug (fun() -> 388 if filetypeFrom = `FILE then 389 Util.msg 390 "Contents of %s after renaming = %s\n" 391 (Fspath.toDebugString target) 392 (Fingerprint.toString (Fingerprint.file target Path.empty))); 393 end) 394 395 (* FIX: maybe we should rename the destination before making any check ? *) 396 (* JV (6/09): the window is small again... 397 FIX: When this code was originally written, we assumed that the 398 checkNoUpdates would happen immediately before the rename, so that 399 the window of danger where other processes could invalidate the thing we 400 just checked was very small. But now that transport is multi-threaded, 401 this window of danger could get very long because other transfers are 402 saturating the link. It would be better, I think, to introduce a real 403 2PC protocol here, so that both sides would (locally and almost-atomically) 404 check that their assumptions had not been violated and then switch the 405 temp file into place, but remain able to roll back if something fails 406 either locally or on the other side. *) 407 let renameLocal 408 (fspathTo, 409 ((localPathTo, workingDir, pathFrom, pathTo), (ui, archOpt, notDefault))) = 410 let copyInfo = prepareCopy workingDir pathTo notDefault in 411 (* Make sure the target is unchanged, then do the rename. 412 (Note that there is an unavoidable race condition here...) *) 413 let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in 414 (* Create a conflict copy if the file was modified in one replica 415 and deleted in the other replica. *) 416 let pathTo = match finishCopy copyInfo with 417 | Some conflictPath -> conflictPath 418 | None -> pathTo in 419 performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch; 420 begin match archOpt with 421 Some archTo -> Stasher.stashCurrentVersion fspathTo localPathTo None; 422 Update.iterFiles fspathTo localPathTo archTo 423 Xferhint.insertEntry; 424 (* Archive update must be done last *) 425 Update.replaceArchiveLocal fspathTo localPathTo archTo 426 | None -> () 427 end; 428 Lwt.return () 429 430 let archOpt_to_compat251 = function 431 | Some arch -> Some (Update.to_compat251 arch) 432 | None -> None 433 434 let archOpt_of_compat251 = function 435 | Some arch -> Some (Update.of_compat251 arch) 436 | None -> None 437 438 let convV0 = Remote.makeConvV0FunArg 439 (fun (fspathTo, 440 ((localPathTo, workingDir, pathFrom, pathTo), (ui, archOpt, notDefault))) -> 441 (fspathTo, 442 (localPathTo, workingDir, pathFrom, pathTo, 443 Common.ui_to_compat251 ui, archOpt_to_compat251 archOpt, notDefault))) 444 (fun (fspathTo, 445 (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt, notDefault)) -> 446 (fspathTo, 447 ((localPathTo, workingDir, pathFrom, pathTo), 448 (Common.ui_of_compat251 ui, archOpt_of_compat251 archOpt, notDefault)))) 449 450 let mrename = Umarshal.(prod2 451 (prod4 Path.mlocal Fspath.m Path.mlocal Path.mlocal id id) 452 (prod3 Common.mupdateItem (option Update.marchive) bool id id) 453 id id) 454 455 let renameOnHost = 456 Remote.registerRootCmd "rename" ~convV0 mrename Umarshal.unit renameLocal 457 458 let rename root localPath workingDir pathOld pathNew ui archOpt notDefault = 459 debug (fun() -> 460 Util.msg "rename(root=%s, localPath=%s, pathOld=%s, pathNew=%s)\n" 461 (root2string root) 462 (Path.toString localPath) 463 (Path.toString pathOld) (Path.toString pathNew)); 464 renameOnHost root 465 ((localPath, workingDir, pathOld, pathNew), (ui, archOpt, notDefault)) 466 467 (* ------------------------------------------------------------ *) 468 469 (* Calculate the target working directory and paths for the copy. 470 workingDir is an fspath naming the directory on the target 471 host where the copied file will actually live. 472 (In the case where pathTo names a symbolic link, this 473 will be the parent directory of the file that the 474 symlink points to, not the symlink itself. Note that 475 this fspath may be outside of the replica, or even 476 on a different volume.) 477 realPathTo is the name of the target file relative to workingDir. 478 (If pathTo names a symlink, this will be the name of 479 the file pointed to by the symlink, not the name of the 480 link itself.) 481 tempPathTo is a temporary file name in the workingDir. The file (or 482 directory structure) will first be copied here, then 483 "almost atomically" moved onto realPathTo. *) 484 485 let setupTargetPathsLocal (fspath, path) = 486 let localPath = Update.translatePathLocal fspath path in 487 let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in 488 let tempPath = Os.tempPath ~fresh:false workingDir realPath in 489 Lwt.return (workingDir, realPath, tempPath, localPath) 490 491 let msetupTargetPaths = Umarshal.(prod4 Fspath.m Path.mlocal Path.mlocal Path.mlocal id id) 492 493 let setupTargetPaths = 494 Remote.registerRootCmd "setupTargetPaths" Path.m msetupTargetPaths setupTargetPathsLocal 495 496 let rec createDirectories fspath localPath props = 497 match props with 498 [] -> 499 () 500 | desc :: rem -> 501 match Path.deconstructRev localPath with 502 None -> 503 assert false 504 | Some (_, parentPath) -> 505 createDirectories fspath parentPath rem; 506 try 507 let absolutePath = Fspath.concat fspath parentPath in 508 Fs.mkdir absolutePath (Props.perms Props.dirDefault); 509 Fileinfo.set fspath parentPath (`Copy parentPath) desc 510 (* The directory may have already been created 511 if there are several paths with the same prefix *) 512 with Unix.Unix_error (Unix.EEXIST, _, _) -> () 513 514 let setupTargetPathsAndCreateParentDirectoryLocal (fspath, (path, props)) = 515 let localPath = Update.translatePathLocal fspath path in 516 Util.convertUnixErrorsToTransient 517 "creating parent directories" 518 (fun () -> createDirectories fspath localPath props); 519 let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in 520 let tempPath = Os.tempPath ~fresh:false workingDir realPath in 521 Lwt.return (workingDir, realPath, tempPath, localPath) 522 523 let convV0 = Remote.makeConvV0FunArg 524 (fun (fspath, (path, props)) -> 525 (fspath, (path, Safelist.map Props.to_compat251 props))) 526 (fun (fspath, (path, props)) -> 527 (fspath, (path, Safelist.map Props.of_compat251 props))) 528 529 let setupTargetPathsAndCreateParentDirectory = 530 Remote.registerRootCmd "setupTargetPathsAndCreateParentDirectory" ~convV0 531 Umarshal.(prod2 Path.m (list Props.mx) id id) 532 Umarshal.(prod4 Fspath.m Path.mlocal Path.mlocal Path.mlocal id id) 533 setupTargetPathsAndCreateParentDirectoryLocal 534 535 let rec readParentsExtData rootFrom pathFrom acc = function 536 | [] -> Safelist.rev acc |> Lwt.return 537 | desc :: rem -> 538 match Path.deconstructRev pathFrom with 539 | None -> assert false 540 | Some (_, parentPath) -> 541 Copy.readPropsExtData rootFrom parentPath desc >>= fun desc' -> 542 readParentsExtData rootFrom parentPath (desc' :: acc) rem 543 544 (* ------------------------------------------------------------ *) 545 546 let updateSourceArchiveLocal (fspathFrom, (localPathFrom, uiFrom, errPaths)) = 547 (* Archive update must be done first (before Stasher call) *) 548 let newArch = Update.updateArchive fspathFrom localPathFrom uiFrom in 549 (* We update the archive with what we were expected to copy *) 550 Update.replaceArchiveLocal fspathFrom localPathFrom newArch; 551 (* Then, we remove all pieces of which the copy failed *) 552 List.iter 553 (fun p -> 554 debug (fun () -> 555 Util.msg "Copy under %s/%s was aborted\n" 556 (Fspath.toDebugString fspathFrom) (Path.toString p)); 557 Update.replaceArchiveLocal fspathFrom p Update.NoArchive) 558 errPaths; 559 Stasher.stashCurrentVersion fspathFrom localPathFrom None; 560 Lwt.return () 561 562 let convV0 = Remote.makeConvV0FunArg 563 (fun (fspathFrom, (localPathFrom, uiFrom, errPaths)) -> 564 (fspathFrom, (localPathFrom, Common.ui_to_compat251 uiFrom, errPaths))) 565 (fun (fspathFrom, (localPathFrom, uiFrom, errPaths)) -> 566 (fspathFrom, (localPathFrom, Common.ui_of_compat251 uiFrom, errPaths))) 567 568 let updateSourceArchive = 569 Remote.registerRootCmd "updateSourceArchive" ~convV0 570 Umarshal.(prod3 Path.mlocal Common.mupdateItem (list Path.mlocal) id id) Umarshal.unit 571 updateSourceArchiveLocal 572 573 (* ------------------------------------------------------------ *) 574 575 let deleteSpuriousChild fspathTo pathTo nm = 576 (* FIX: maybe we should turn them into Unison temporary files? *) 577 let path = (Path.child pathTo nm) in 578 debug (fun() -> Util.msg "Deleting spurious file %s/%s\n" 579 (Fspath.toDebugString fspathTo) (Path.toString path)); 580 Os.delete fspathTo path 581 582 let rec deleteSpuriousChildrenRec fspathTo pathTo archChildren children = 583 match archChildren, children with 584 archNm :: archRem, nm :: rem -> 585 let c = Name.compare archNm nm in 586 if c < 0 then 587 deleteSpuriousChildrenRec fspathTo pathTo archRem children 588 else if c = 0 then 589 deleteSpuriousChildrenRec fspathTo pathTo archChildren rem 590 else begin 591 deleteSpuriousChild fspathTo pathTo nm; 592 deleteSpuriousChildrenRec fspathTo pathTo archChildren rem 593 end 594 | [], nm :: rem -> 595 deleteSpuriousChild fspathTo pathTo nm; 596 deleteSpuriousChildrenRec fspathTo pathTo [] rem 597 | _, [] -> 598 () 599 600 let deleteSpuriousChildrenLocal (_, (fspathTo, pathTo, archChildren)) = 601 deleteSpuriousChildrenRec 602 fspathTo pathTo archChildren 603 (List.sort Name.compare (Os.childrenOf fspathTo pathTo)); 604 Lwt.return () 605 606 let deleteSpuriousChildren = 607 Remote.registerRootCmd "deleteSpuriousChildren" Umarshal.(prod3 Fspath.m Path.mlocal (list Name.m) id id) Umarshal.unit deleteSpuriousChildrenLocal 608 609 let rec normalizeProps propsFrom propsTo = 610 match propsFrom, propsTo with 611 d :: r, d' :: r' -> normalizeProps r r' 612 | _, [] -> (Safelist.rev propsFrom) 613 | [], _ :: _ -> assert false 614 615 (* ------------------------------------------------------------ *) 616 617 let copyReg = Remote.lwtRegionWithConnCleanup 50 618 619 let copy 620 update 621 rootFrom pathFrom (* copy from here... *) 622 uiFrom (* (and then check that this updateItem still 623 describes the current state of the src replica) *) 624 propsFrom (* the properties of the parent directories, in 625 case we need to propagate them *) 626 rootTo pathTo (* ...to here *) 627 uiTo (* (but, before committing the copy, check that 628 this updateItem still describes the current 629 state of the target replica) *) 630 propsTo (* the properties of the parent directories *) 631 notDefault (* [true] if not Unison's default action *) 632 id = (* for progress display *) 633 debug (fun() -> 634 Util.msg 635 "copy %s %s ---> %s %s \n" 636 (root2string rootFrom) (Path.toString pathFrom) 637 (root2string rootTo) (Path.toString pathTo)); 638 (* Calculate source path *) 639 Update.translatePath rootFrom pathFrom >>= fun localPathFrom -> 640 (* Calculate target paths *) 641 normalizeProps propsFrom propsTo 642 |> readParentsExtData rootFrom localPathFrom [] >>= fun parentProps -> 643 setupTargetPathsAndCreateParentDirectory rootTo 644 (pathTo, parentProps) 645 >>= fun (workingDir, realPathTo, tempPathTo, localPathTo) -> 646 (* When in Unicode case-insensitive mode, we want to create files 647 with NFC normal-form filenames. *) 648 let realPathTo = 649 match update with 650 `Update _ -> 651 realPathTo 652 | `Copy -> 653 match Path.deconstructRev realPathTo with 654 None -> 655 assert false 656 | Some (name, parentPath) -> 657 Path.child parentPath (Name.normalize name) 658 in 659 let errors = ref [] in 660 (* Inner loop for recursive copy... *) 661 let rec copyRec pFrom (* Path to copy from *) 662 pTo (* (Temp) path to copy to *) 663 realPTo (* Path where this file will ultimately be placed 664 (needed by rsync, which uses the old contents 665 of this file to optimize transfer) *) 666 f = (* Source archive subtree for this path *) 667 debug (fun() -> 668 Util.msg "copyRec %s --> %s (really to %s)\n" 669 (Path.toString pFrom) (Path.toString pTo) 670 (Path.toString realPTo)); 671 Lwt.catch 672 (fun () -> 673 match f with 674 Update.ArchiveFile (desc, fp, stamp, ress) -> 675 Lwt_util.run_in_region !copyReg 1 (fun () -> 676 Abort.check id; 677 let stmp = 678 if Update.useFastChecking () then Some stamp else None in 679 Copy.file 680 rootFrom pFrom rootTo workingDir pTo realPTo 681 update desc fp stmp ress id 682 >>= fun info -> 683 let ress' = Osx.stamp info.Fileinfo.osX in 684 Lwt.return 685 (Update.ArchiveFile (Props.override info.Fileinfo.desc desc, 686 fp, Fileinfo.stamp info, ress'), 687 [])) 688 | Update.ArchiveSymlink l -> 689 Lwt_util.run_in_region !copyReg 1 (fun () -> 690 debug (fun() -> Util.msg "Making symlink %s/%s -> %s\n" 691 (root2string rootTo) (Path.toString pTo) l); 692 Abort.check id; 693 makeSymlink rootTo (workingDir, pTo, l) >>= fun () -> 694 Lwt.return (f, [])) 695 | Update.ArchiveDir (desc, children) -> 696 Lwt_util.run_in_region !copyReg 1 (fun () -> 697 debug (fun() -> Util.msg "Creating directory %s/%s\n" 698 (root2string rootTo) (Path.toString pTo)); 699 mkdirOnRoot rootTo (workingDir, pTo)) 700 >>= fun (dirAlreadyExisting, initialDesc) -> 701 Abort.check id; 702 (* We start a thread for each child *) 703 let childThreads = 704 Update.NameMap.mapi 705 (fun name child -> 706 let nameTo = Name.normalize name in 707 copyRec (Path.child pFrom name) 708 (Path.child pTo nameTo) 709 (Path.child realPTo nameTo) 710 child) 711 children 712 in 713 (* We collect the thread results *) 714 Update.NameMap.fold 715 (fun nm childThr remThr -> 716 childThr >>= fun (arch, paths) -> 717 remThr >>= fun (children, pathl, error) -> 718 let childErr = arch = Update.NoArchive in 719 let children = 720 if childErr then children else 721 Update.NameMap.add nm arch children 722 in 723 Lwt.return (children, paths :: pathl, error || childErr)) 724 childThreads 725 (Lwt.return (Update.NameMap.empty, [], false)) 726 >>= fun (newChildren, pathl, childError) -> 727 begin if dirAlreadyExisting || childError then 728 let childNames = 729 Update.NameMap.fold (fun nm _ l -> nm :: l) newChildren [] in 730 deleteSpuriousChildren rootTo (workingDir, pTo, childNames) 731 else 732 Lwt.return () 733 end >>= fun () -> 734 Copy.readPropsExtData rootFrom pFrom desc >>= fun desc' -> 735 Lwt_util.run_in_region !copyReg 1 (fun () -> 736 (* We use the actual file permissions so as to preserve 737 inherited bits *) 738 setDirPropOnRoot rootTo 739 (workingDir, pTo, initialDesc, desc')) >>= fun () -> 740 Lwt.return (Update.ArchiveDir (desc, newChildren), 741 Safelist.flatten pathl) 742 | Update.NoArchive -> 743 assert false) 744 (fun e -> 745 match e with 746 Util.Transient _ -> 747 if not (Abort.testException e) then Abort.file id; 748 errors := e :: !errors; 749 Lwt.return (Update.NoArchive, [pFrom]) 750 | _ -> 751 Lwt.fail e) 752 in 753 (* Compute locally what we need to propagate *) 754 let rootLocal = List.hd (Globals.rootsInCanonicalOrder ()) in 755 let localArch = 756 Update.updateArchive (snd rootLocal) localPathFrom uiFrom in 757 copyRec localPathFrom tempPathTo realPathTo localArch 758 >>= fun (archTo, errPaths) -> 759 if archTo = Update.NoArchive then 760 (* We were not able to transfer anything *) 761 Lwt.fail (List.hd !errors) 762 else begin 763 (* Rename the files to their final location and then update the 764 archive on the destination replica *) 765 debugverbose (fun () -> Util.msg "rename from copy\n"); 766 rename rootTo localPathTo workingDir tempPathTo realPathTo uiTo 767 (Some archTo) notDefault >>= fun () -> 768 (* Update the archive on the source replica 769 FIX: we could reuse localArch if rootFrom is the same as rootLocal *) 770 updateSourceArchive rootFrom (localPathFrom, uiFrom, errPaths) >>= fun () -> 771 (* Return the first error, if any *) 772 match Safelist.rev !errors with 773 e :: _ -> Lwt.fail e 774 | [] -> Lwt.return () 775 end 776 777 (* ------------------------------------------------------------ *) 778 779 let (>>=) = Lwt.bind 780 781 let diffCmd = 782 Prefs.createString "diff" "diff -u OLDER NEWER" 783 ~category:(`Advanced `General) 784 "set command for showing differences between files" 785 ("This preference can be used to control the name and command-line " 786 ^ "arguments of the system " 787 ^ "utility used to generate displays of file differences. The default " 788 ^ "is `\\verb|diff -u OLDER NEWER|'. If the value of this preference contains the substrings " 789 ^ "CURRENT1 and CURRENT2, these will be replaced by the names of the files to be " 790 ^ "diffed. If the value of this preference contains the substrings " 791 ^ "NEWER and OLDER, these will be replaced by the names of files to be " 792 ^ "diffed, NEWER being the most recently modified file of the two. " 793 ^ "Without any of these substrings, the two filenames will be appended to the command. In all " 794 ^ "cases, the filenames are suitably quoted.") 795 796 let tempName s = Os.tempFilePrefix ^ s 797 798 let rec diff root1 path1 ui1 root2 path2 ui2 showDiff id = 799 debug (fun () -> 800 Util.msg 801 "diff %s %s %s %s ...\n" 802 (root2string root1) (Path.toString path1) 803 (root2string root2) (Path.toString path2)); 804 let (desc1, fp1, ress1, desc2, fp2, ress2) = Common.fileInfos ui1 ui2 in 805 let displayDiff fspath1 fspath2 = 806 let cmd = 807 if Util.findsubstring "NEWER" (Prefs.read diffCmd) <> None then 808 let newer1 = (Props.time desc1) > (Props.time desc2) in 809 let (newer, older) = if newer1 then 810 (fspath1, fspath2) 811 else 812 (fspath2, fspath1) 813 in 814 Util.replacesubstrings (Prefs.read diffCmd) 815 ["OLDER", Fspath.quotes older; 816 "NEWER", Fspath.quotes newer] 817 else if Util.findsubstring "CURRENT1" (Prefs.read diffCmd) = None then 818 (Prefs.read diffCmd) 819 ^ " " ^ (Fspath.quotes fspath1) 820 ^ " " ^ (Fspath.quotes fspath2) 821 else 822 Util.replacesubstrings (Prefs.read diffCmd) 823 ["CURRENT1", Fspath.quotes fspath1; 824 "CURRENT2", Fspath.quotes fspath2] in 825 let _, diffResult = Lwt_unix.run (External.runExternalProgram cmd) in 826 if diffResult <> "" then 827 showDiff cmd diffResult 828 in 829 match root1,root2 with 830 (Local,fspath1),(Local,fspath2) -> 831 Util.convertUnixErrorsToTransient 832 "diffing files" 833 (fun () -> 834 let path1 = Update.translatePathLocal fspath1 path1 in 835 let path2 = Update.translatePathLocal fspath2 path2 in 836 displayDiff 837 (Fspath.concat fspath1 path1) (Fspath.concat fspath2 path2)) 838 | (Local,fspath1),(Remote host2,fspath2) -> 839 Util.convertUnixErrorsToTransient 840 "diffing files" 841 (fun () -> 842 let path1 = Update.translatePathLocal fspath1 path1 in 843 let (workingDir, realPath) = Fspath.findWorkingDir fspath1 path1 in 844 let tmppath = Os.tempPath ~fresh:false workingDir 845 (Path.addSuffixToFinalName realPath "-diff") in 846 Os.delete workingDir tmppath; 847 Lwt_unix.run 848 (Update.translatePath root2 path2 >>= (fun path2 -> 849 Copy.file root2 path2 root1 workingDir tmppath realPath 850 `Copy (Props.setLength desc1 (Props.length desc2)) 851 fp2 None ress2 id) >>= fun info -> 852 Lwt.return ()); 853 displayDiff 854 (Fspath.concat workingDir realPath) 855 (Fspath.concat workingDir tmppath); 856 Os.delete workingDir tmppath) 857 | (Remote host1,fspath1),(Local,fspath2) -> 858 Util.convertUnixErrorsToTransient 859 "diffing files" 860 (fun () -> 861 let path2 = Update.translatePathLocal fspath2 path2 in 862 let (workingDir, realPath) = Fspath.findWorkingDir fspath2 path2 in 863 let tmppath = Os.tempPath ~fresh:false workingDir 864 (Path.addSuffixToFinalName realPath "-diff") in 865 Lwt_unix.run 866 (Update.translatePath root1 path1 >>= (fun path1 -> 867 (* Note that we don't need the resource fork *) 868 Copy.file root1 path1 root2 workingDir tmppath realPath 869 `Copy (Props.setLength desc2 (Props.length desc1)) 870 fp1 None ress1 id >>= fun info -> 871 Lwt.return ())); 872 displayDiff 873 (Fspath.concat workingDir tmppath) 874 (Fspath.concat workingDir realPath); 875 Os.delete workingDir tmppath) 876 | (Remote host1,fspath1),(Remote host2,fspath2) -> 877 assert false 878 879 880 (**********************************************************************) 881 882 (* Taken from ocamltk/jpf/fileselect.ml *) 883 let get_files_in_directory dir = 884 let dirh = System.opendir dir in 885 let files = ref [] in 886 begin try 887 while true do files := dirh.System.readdir () :: !files done 888 with End_of_file -> 889 dirh.System.closedir () 890 end; 891 List.sort String.compare !files 892 893 let ls dir pattern = 894 Util.convertUnixErrorsToTransient 895 "listing files" 896 (fun () -> 897 let files = get_files_in_directory dir in 898 let re = Rx.glob pattern in 899 let rec filter l = 900 match l with 901 [] -> 902 [] 903 | hd :: tl -> 904 if Rx.match_string re hd then hd :: filter tl else filter tl 905 in 906 filter files) 907 908 909 (*********************************************************************** 910 CALL OUT TO EXTERNAL MERGE PROGRAM 911 ************************************************************************) 912 913 let formatMergeCmd p f1 f2 backup out1 out2 outarch batchmode = 914 if not (Globals.shouldMerge p) then 915 raise (Util.Transient ("'merge' preference not set for "^(Path.toString p))); 916 let raw = 917 try Globals.mergeCmdForPath p 918 with Not_found -> 919 raise (Util.Transient ("'merge' preference does not provide a command " 920 ^ "template for " ^ (Path.toString p))) 921 in 922 let cooked = raw in 923 let cooked = Util.replacesubstring cooked "CURRENT1" f1 in 924 let cooked = Util.replacesubstring cooked "CURRENT2" f2 in 925 let cooked = 926 match backup with 927 None -> begin 928 let cooked = Util.replacesubstring cooked "CURRENTARCHOPT" "" in 929 match Util.findsubstring "CURRENTARCH" cooked with 930 None -> cooked 931 | Some _ -> raise (Util.Transient 932 ("No archive found, but the 'merge' command " 933 ^ "template expects one. (Consider enabling " 934 ^ "'backupcurrent' for this file or using CURRENTARCHOPT " 935 ^ "instead of CURRENTARCH.)")) 936 end 937 | Some(s) -> 938 let cooked = Util.replacesubstring cooked "CURRENTARCHOPT" s in 939 let cooked = Util.replacesubstring cooked "CURRENTARCH" s in 940 cooked in 941 let cooked = Util.replacesubstring cooked "NEW1" out1 in 942 let cooked = Util.replacesubstring cooked "NEW2" out2 in 943 let cooked = Util.replacesubstring cooked "NEWARCH" outarch in 944 let cooked = Util.replacesubstring cooked "NEW" out1 in 945 let cooked = Util.replacesubstring cooked "BATCHMODE" batchmode in 946 let cooked = Util.replacesubstring cooked "PATH" 947 (Uutil.quotes (Path.toString p)) in 948 cooked 949 950 let copyBack fspathFrom pathFrom rootTo pathTo propsTo uiTo archTo id = 951 setupTargetPaths rootTo pathTo 952 >>= (fun (workingDirForCopy, realPathTo, tempPathTo, localPathTo) -> 953 let info = Fileinfo.getBasicWithRess false fspathFrom pathFrom in 954 let fp = Os.fingerprint fspathFrom pathFrom info.Fileinfo.typ in 955 let stamp = Osx.stamp info.Fileinfo.osX in 956 let newprops = Props.setLength propsTo (Props.length info.Fileinfo.desc) in 957 Copy.file 958 (Local, fspathFrom) pathFrom rootTo workingDirForCopy tempPathTo realPathTo 959 `Copy newprops fp None stamp id >>= fun info -> 960 debugverbose (fun () -> Util.msg "rename from copyBack\n"); 961 rename rootTo localPathTo workingDirForCopy tempPathTo realPathTo 962 uiTo archTo false) 963 964 let keeptempfilesaftermerge = 965 Prefs.createBool 966 "keeptempfilesaftermerge" false 967 ~category:(`Internal `Devel) 968 "*" "" 969 970 let showStatus = function 971 | Unix.WEXITED i -> Printf.sprintf "exited (%d)" i 972 | Unix.WSIGNALED i -> Printf.sprintf "killed with signal %d" i 973 | Unix.WSTOPPED i -> Printf.sprintf "stopped with signal %d" i 974 975 let merge root1 path1 ui1 root2 path2 ui2 id showMergeFn = 976 debug (fun () -> Util.msg "merge path %s between roots %s and %s\n" 977 (Path.toString path1) (root2string root1) (root2string root2)); 978 979 (* The following assumes root1 is always local: switch them if needed to make this so *) 980 let (root1,path1,ui1,root2,path2,ui2) = 981 match root1 with 982 (Local,fspath1) -> (root1,path1,ui1,root2,path2,ui2) 983 | _ -> (root2,path2,ui2,root1,path1,ui1) in 984 985 let (localPath1, (workingDirForMerge, basep), fspath1) = 986 match root1 with 987 (Local,fspath1) -> 988 let localPath1 = Update.translatePathLocal fspath1 path1 in 989 (localPath1, Fspath.findWorkingDir fspath1 localPath1, fspath1) 990 | _ -> assert false in 991 992 (* We're going to be doing a lot of copying, so let's define a shorthand 993 that fixes most of the arguments to Copy.localfile *) 994 let copy l = 995 Safelist.iter 996 (fun (src,trg) -> 997 debug (fun () -> Util.msg "Copying %s to %s\n" (Path.toString src) (Path.toString trg)); 998 Os.delete workingDirForMerge trg; 999 let info = Fileinfo.get false workingDirForMerge src in 1000 Copy.localFile 1001 workingDirForMerge src 1002 workingDirForMerge trg trg 1003 `Copy info.Fileinfo.desc 1004 (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) (Some id)) 1005 l in 1006 1007 let working1 = Path.addPrefixToFinalName basep (tempName "merge1-") in 1008 let working2 = Path.addPrefixToFinalName basep (tempName "merge2-") in 1009 let workingarch = Path.addPrefixToFinalName basep (tempName "mergearch-") in 1010 let new1 = Path.addPrefixToFinalName basep (tempName "mergenew1-") in 1011 let new2 = Path.addPrefixToFinalName basep (tempName "mergenew2-") in 1012 let newarch = Path.addPrefixToFinalName basep (tempName "mergenewarch-") in 1013 1014 let (desc1, fp1, ress1, desc2, fp2, ress2) = Common.fileInfos ui1 ui2 in 1015 1016 Util.convertUnixErrorsToTransient "merging files" (fun () -> 1017 (* Install finalizer (below) in case we unwind the stack *) 1018 Util.finalize (fun () -> 1019 1020 (* Make local copies of the two replicas *) 1021 Os.delete workingDirForMerge working1; 1022 Os.delete workingDirForMerge working2; 1023 Os.delete workingDirForMerge workingarch; 1024 Lwt_unix.run 1025 (Copy.file 1026 root1 localPath1 root1 workingDirForMerge working1 basep 1027 `Copy desc1 fp1 None ress1 id >>= fun info -> 1028 Lwt.return ()); 1029 Lwt_unix.run 1030 (Update.translatePath root2 path2 >>= (fun path2 -> 1031 Copy.file 1032 root2 path2 root1 workingDirForMerge working2 basep 1033 `Copy desc2 fp2 None ress2 id) >>= fun info -> 1034 Lwt.return ()); 1035 1036 (* retrieve the archive for this file, if any *) 1037 let arch = 1038 match ui1, ui2 with 1039 | Updates (_, Previous (_,_,fp,_)), Updates (_, Previous (_,_,fp2,_)) -> 1040 if fp = fp2 then 1041 Stasher.getRecentVersion fspath1 localPath1 fp 1042 else 1043 assert false 1044 | NoUpdates, Updates(_, Previous (_,_,fp,_)) 1045 | Updates(_, Previous (_,_,fp,_)), NoUpdates -> 1046 Stasher.getRecentVersion fspath1 localPath1 fp 1047 | Updates (_, New), Updates(_, New) 1048 | Updates (_, New), NoUpdates 1049 | NoUpdates, Updates (_, New) -> 1050 debug (fun () -> Util.msg "File is new, no current version will be searched"); 1051 None 1052 | _ -> assert false in 1053 1054 (* Make a local copy of the archive file (in case the merge program 1055 overwrites it and the program crashes before the call to the Stasher). *) 1056 begin 1057 match arch with 1058 Some fspath -> 1059 let info = Fileinfo.get false fspath Path.empty in 1060 Copy.localFile 1061 fspath Path.empty 1062 workingDirForMerge workingarch workingarch 1063 `Copy 1064 info.Fileinfo.desc 1065 (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) 1066 None 1067 | None -> 1068 () 1069 end; 1070 1071 (* run the merge command *) 1072 Os.delete workingDirForMerge new1; 1073 Os.delete workingDirForMerge new2; 1074 Os.delete workingDirForMerge newarch; 1075 let info1 = Fileinfo.getType false workingDirForMerge working1 in 1076 (* FIX: Why split out the parts of the pair? Why is it not abstract anyway??? *) 1077 let fp1 = Os.fingerprint workingDirForMerge working1 info1 in 1078 let info2 = Fileinfo.getType false workingDirForMerge working2 in 1079 let fp2 = Os.fingerprint workingDirForMerge working2 info2 in 1080 let cmd = formatMergeCmd 1081 path1 1082 (Fspath.quotes (Fspath.concat workingDirForMerge working1)) 1083 (Fspath.quotes (Fspath.concat workingDirForMerge working2)) 1084 (match arch with None -> None | Some f -> Some(Fspath.quotes f)) 1085 (Fspath.quotes (Fspath.concat workingDirForMerge new1)) 1086 (Fspath.quotes (Fspath.concat workingDirForMerge new2)) 1087 (Fspath.quotes (Fspath.concat workingDirForMerge newarch)) 1088 (if Prefs.read Globals.batch then "batch" else "") in 1089 Trace.log (Printf.sprintf "Merge command: %s\n" cmd); 1090 1091 let returnValue, mergeResultLog = 1092 Lwt_unix.run (External.runExternalProgram cmd) in 1093 1094 Trace.log (Printf.sprintf "Merge result (%s):\n%s\n" 1095 (showStatus returnValue) mergeResultLog); 1096 debug (fun () -> Util.msg "Merge result = %s\n" 1097 (showStatus returnValue)); 1098 1099 (* This query to the user probably belongs below, after we've gone through all the 1100 logic that might raise exceptions in various conditions. But it has the side effect of 1101 *displaying* the results of the merge (or putting them in a "details" area), so we don't 1102 want to skip doing it if we raise one of these exceptions. Better might be to split out 1103 the displaying from the querying... *) 1104 if not 1105 (showMergeFn 1106 (Printf.sprintf "Results of merging %s" (Path.toString path1)) 1107 mergeResultLog) then 1108 raise (Util.Transient ("Merge command canceled by the user")); 1109 1110 (* It's useful for now to be a bit verbose about what we're doing, but let's 1111 keep it easy to switch this to debug-only in some later release... *) 1112 (* Added check on [sendLogMsgsToStderr] because in Windows the GUI may not 1113 have stderr (and stdout) at all. *) 1114 let say f = if !Trace.sendLogMsgsToStderr then f () in 1115 1116 (* Check which files got created by the merge command and do something appropriate 1117 with them *) 1118 debug (fun()-> Util.msg "New file 1 = %s\n" (Fspath.toDebugString (Fspath.concat workingDirForMerge new1))); 1119 let new1exists = Fs.file_exists (Fspath.concat workingDirForMerge new1) in 1120 let new2exists = Fs.file_exists (Fspath.concat workingDirForMerge new2) in 1121 let newarchexists = Fs.file_exists (Fspath.concat workingDirForMerge newarch) in 1122 1123 if new1exists && new2exists then begin 1124 if newarchexists then 1125 say (fun () -> Util.msg "Three outputs detected \n") 1126 else 1127 say (fun () -> Util.msg "Two outputs detected \n"); 1128 let info1 = Fileinfo.getType false workingDirForMerge new1 in 1129 let info2 = Fileinfo.getType false workingDirForMerge new2 in 1130 let fp1' = Os.fingerprint workingDirForMerge new1 info1 in 1131 let fp2' = Os.fingerprint workingDirForMerge new2 info2 in 1132 if fp1'=fp2' then begin 1133 debug (fun () -> Util.msg "Two outputs equal => update the archive\n"); 1134 copy [(new1,working1); (new2,working2); (new1,workingarch)]; 1135 end else 1136 if returnValue = Unix.WEXITED 0 then begin 1137 say (fun () -> (Util.msg "Two outputs not equal but merge command returned 0, so we will\n"; 1138 Util.msg "overwrite the other replica and the archive with the first output\n")); 1139 copy [(new1,working1); (new1,working2); (new1,workingarch)]; 1140 end else begin 1141 say (fun () -> (Util.msg "Two outputs not equal and the merge command exited with nonzero status, \n"; 1142 Util.msg "so we will copy back the new files but not update the archive\n")); 1143 copy [(new1,working1); (new2,working2)]; 1144 1145 end 1146 end 1147 1148 else if new1exists && (not new2exists) && (not newarchexists) then begin 1149 if returnValue = Unix.WEXITED 0 then begin 1150 say (fun () -> Util.msg "One output detected \n"); 1151 copy [(new1,working1); (new1,working2); (new1,workingarch)]; 1152 end else begin 1153 say (fun () -> Util.msg "One output detected but merge command returned nonzero exit status\n"); 1154 raise (Util.Transient "One output detected but merge command returned nonzero exit status\n") 1155 end 1156 end 1157 1158 else if (not new1exists) && new2exists && (not newarchexists) then begin 1159 assert false 1160 end 1161 1162 else if (not new1exists) && (not new2exists) && (not newarchexists) then begin 1163 say (fun () -> Util.msg "No outputs detected \n"); 1164 let working1_still_exists = Fs.file_exists (Fspath.concat workingDirForMerge working1) in 1165 let working2_still_exists = Fs.file_exists (Fspath.concat workingDirForMerge working2) in 1166 1167 if working1_still_exists && working2_still_exists then begin 1168 say (fun () -> Util.msg "No output from merge cmd and both original files are still present\n"); 1169 let info1' = Fileinfo.getType false workingDirForMerge working1 in 1170 let fp1' = Os.fingerprint workingDirForMerge working1 info1' in 1171 let info2' = Fileinfo.getType false workingDirForMerge working2 in 1172 let fp2' = Os.fingerprint workingDirForMerge working2 info2' in 1173 if fp1 = fp1' && fp2 = fp2' then 1174 raise (Util.Transient "Merge program didn't change either temp file"); 1175 if fp1' = fp2' then begin 1176 say (fun () -> Util.msg "Merge program made files equal\n"); 1177 copy [(working1,workingarch)]; 1178 end else if fp2 = fp2' then begin 1179 say (fun () -> Util.msg "Merge program changed just first input\n"); 1180 copy [(working1,working2);(working1,workingarch)] 1181 end else if fp1 = fp1' then begin 1182 say (fun () -> Util.msg "Merge program changed just second input\n"); 1183 copy [(working2,working1);(working2,workingarch)] 1184 end else 1185 if returnValue <> Unix.WEXITED 0 then 1186 raise (Util.Transient ("Error: the merge function changed both of " 1187 ^ "its inputs but did not make them equal")) 1188 else begin 1189 say (fun () -> (Util.msg "Merge program changed both of its inputs in"; 1190 Util.msg "different ways, but returned zero.\n")); 1191 (* Note that we assume the merge program knew what it was doing when it 1192 returned 0 -- i.e., we assume a zero result means that the files are 1193 "morally equal" and either can be replaced by the other; we therefore 1194 choose one of them (#2) as the unique new result, so that we can update 1195 Unison's archive and call the file 'in sync' again. *) 1196 copy [(working2,working1);(working2,workingarch)]; 1197 end 1198 end 1199 1200 else if working1_still_exists && (not working2_still_exists) 1201 && returnValue = Unix.WEXITED 0 then begin 1202 say (fun () -> Util.msg "No outputs and second replica has been deleted \n"); 1203 copy [(working1,working2); (working1,workingarch)]; 1204 end 1205 1206 else if (not working1_still_exists) && working2_still_exists 1207 && returnValue = Unix.WEXITED 0 then begin 1208 say (fun () -> Util.msg "No outputs and first replica has been deleted \n"); 1209 copy [(working2,working1); (working2,workingarch)]; 1210 end 1211 else if returnValue = Unix.WEXITED 0 then begin 1212 raise (Util.Transient ("Error: the merge program deleted both of its " 1213 ^ "inputs and generated no output!")) 1214 end else begin 1215 say (fun() -> Util.msg "The merge program exited with nonzero status and did not leave"; 1216 Util.msg " both files equal"); 1217 raise (Util.Transient ("Error: the merge program failed and did not leave" 1218 ^ " both files equal")) 1219 end 1220 end else begin 1221 assert false 1222 end; 1223 1224 Lwt_unix.run 1225 (debug (fun () -> Util.msg "Committing results of merge\n"); 1226 let (desc1, desc2, archTo) = 1227 let arch_fspath = Fspath.concat workingDirForMerge workingarch in 1228 if Fs.file_exists arch_fspath then begin 1229 debug (fun () -> Util.msg "Updating unison archives for %s to reflect results of merge\n" 1230 (Path.toString path1)); 1231 if not (Stasher.shouldBackupCurrent path1) then 1232 Util.msg "Warning: 'backupcurrent' is not set for path %s\n" (Path.toString path1); 1233 let infoarch = Fileinfo.getBasicWithRess false arch_fspath Path.empty in 1234 let fp = Os.fingerprint arch_fspath Path.empty infoarch.typ in 1235 debug (fun () -> Util.msg "New fingerprint is %s\n" (Os.fullfingerprint_to_string fp)); 1236 let pseudoMergeDesc merge_desc = 1237 (* Length and times (because the merge result's mtime is set in 1238 both replicas) must come from the merge result. The remaining 1239 props should be as close as possible to one of the original 1240 files to reduce the possibility of props conflicts at the next 1241 sync. 1242 1243 Current props, desc1 and desc2, can't be compared before having 1244 same time and length (taken from the merge result). *) 1245 let fixup_desc desc n = 1246 let desc' = Props.setTime desc n in 1247 Props.setLength desc' (Props.length n) 1248 in 1249 let desc1' = fixup_desc desc1 merge_desc 1250 and desc2' = fixup_desc desc2 merge_desc in 1251 let pref_desc = 1252 if Props.similar desc1' desc2' then Some desc1 else 1253 match ui1, ui2 with 1254 | Updates (_, Previous (_, pdesc1, _, _)), 1255 Updates (_, Previous (_, pdesc2, _, _)) -> 1256 if Props.similar pdesc1 desc1 then Some desc1 else 1257 if Props.similar pdesc2 desc2 then Some desc2 else 1258 if Props.similar pdesc1 pdesc2 then Some pdesc1 else 1259 None (* Is it possible to arrive here? *) 1260 | NoUpdates, (NoUpdates | Updates _) -> Some desc1 1261 | Updates _, NoUpdates -> Some desc2 1262 | _ -> None 1263 in 1264 match pref_desc with 1265 | None -> None 1266 | Some pref_desc -> Some (fixup_desc pref_desc merge_desc) 1267 in 1268 let new_archive_entry = 1269 match pseudoMergeDesc infoarch.desc with 1270 | None -> None 1271 | Some new_arch_desc -> 1272 Some (Update.ArchiveFile (new_arch_desc, fp, 1273 Fileinfo.stamp infoarch, Osx.stamp infoarch.osX)) in 1274 (Props.setTime desc1 infoarch.Fileinfo.desc, 1275 Props.setTime desc2 infoarch.Fileinfo.desc, 1276 new_archive_entry) 1277 end else 1278 (desc1, desc2, None) 1279 in 1280 copyBack workingDirForMerge working1 root1 path1 desc1 ui1 archTo id >>= (fun () -> 1281 copyBack workingDirForMerge working2 root2 path2 desc2 ui2 archTo id >>= (fun () -> 1282 Lwt.return () )))) ) 1283 (fun _ -> 1284 Util.ignoreTransientErrors 1285 (fun () -> 1286 if not (Prefs.read keeptempfilesaftermerge) then begin 1287 Os.delete workingDirForMerge working1; 1288 Os.delete workingDirForMerge working2; 1289 Os.delete workingDirForMerge workingarch; 1290 Os.delete workingDirForMerge new1; 1291 Os.delete workingDirForMerge new2; 1292 Os.delete workingDirForMerge newarch 1293 end))