recon.ml (36530B)
1 (* Unison file synchronizer: src/recon.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 21 (* ------------------------------------------------------------------------- *) 22 (* Handling of prefer/force *) 23 (* ------------------------------------------------------------------------- *) 24 let debug = Trace.debug "recon" 25 26 let setDirection ri dir force = 27 match ri.replicas with 28 Different 29 ({rc1 = rc1; rc2 = rc2; direction = d; default_direction = default } as diff) 30 when force=`Force || isConflict default -> 31 if dir=`Replica1ToReplica2 then 32 diff.direction <- Replica1ToReplica2 33 else if dir=`Replica2ToReplica1 then 34 diff.direction <- Replica2ToReplica1 35 else if dir=`Merge then begin 36 if Globals.shouldMerge ri.path1 then diff.direction <- Merge 37 end else begin (* dir = `Older or dir = `Newer *) 38 match rc1.status, rc2.status with 39 `Deleted, _ -> 40 if isConflict default then 41 diff.direction <- Replica2ToReplica1 42 | _, `Deleted -> 43 if isConflict default then 44 diff.direction <- Replica1ToReplica2 45 | _ -> 46 let comp = Props.time rc1.desc -. Props.time rc2.desc in 47 (* If mtimes are equal then `Older and `Newer are not defined 48 and will be ignored. This is safer than the previous way of 49 always propagating from replica 2 to replica 1. *) 50 if comp <> 0.0 then 51 let comp = if dir=`Newer then -. comp else comp in 52 if comp<0.0 then 53 diff.direction <- Replica1ToReplica2 54 else 55 diff.direction <- Replica2ToReplica1 56 end 57 | _ -> 58 () 59 60 let revertToDefaultDirection ri = 61 match ri.replicas with 62 Different diff -> diff.direction <- diff.default_direction 63 | _ -> () 64 65 (* Find out which direction we need to propagate changes if we want to *) 66 (* consider the given root to be the "truth" *) 67 (* -- *) 68 (* root := "older" | "newer" | <one of the two roots> *) 69 (* return value := 'Older | 'Newer | 'Replica1ToReplica2 | *) 70 (* 'Replica2ToReplica1 *) 71 (* -- *) 72 let root2direction root = 73 let partialMatch s = function 74 | Clroot.ConnectLocal (None | Some "") -> false 75 | Clroot.ConnectLocal (Some root) -> 76 Util.startswith root s || Util.endswith root s 77 | ConnectByShell (_, host, _, _, Some root) 78 | ConnectBySocket (host, _, Some root) -> 79 Util.startswith root s || Util.endswith root s || Util.startswith host s 80 | ConnectByShell (_, host, _, _, None) 81 | ConnectBySocket (host, _, None) -> 82 Util.startswith host s 83 in 84 let partialRootMatches prefVal = 85 Safelist.map (partialMatch prefVal) (Globals.parsedClRawRoots ()) 86 in 87 if root="older" then `Older 88 else if root="newer" then `Newer 89 else if root = "" then `None 90 else 91 let (r1, r2) = Globals.rawRootPair () in 92 debug (fun() -> 93 Printf.eprintf "root2direction called to choose %s from %s and %s\n" 94 root r1 r2); 95 if r1 = root then `Replica1ToReplica2 else 96 if r2 = root then `Replica2ToReplica1 else 97 match partialRootMatches root with 98 | [true; false] -> `Replica1ToReplica2 99 | [false; true] -> `Replica2ToReplica1 100 | _ -> 101 raise (Util.Fatal (Printf.sprintf "%s\nis not uniquely identifying one \ 102 of the current roots:\n %s\n %s" root r1 r2)) 103 104 let rootDirCache = ref [] 105 106 let clearRootDirCache () = rootDirCache := [] 107 108 let prefRoot prefV = 109 (* Use physical equality with cache keys. The goal is not to avoid as many 110 cache misses as possible but to make cache checking much cheaper than 111 calculating the value (in this case, hashing and string comparison are 112 not quite cheap enough). *) 113 match List.assq_opt prefV !rootDirCache with 114 | Some x -> x 115 | None -> let x = root2direction prefV in 116 rootDirCache := (prefV, x) :: !rootDirCache; x 117 118 let forceRoot: string Prefs.t = 119 Prefs.createString "force" "" 120 ~category:(`Advanced `Sync) 121 "force changes from this replica to the other" 122 ("Including the preference \\texttt{-force \\ARG{root}} causes Unison to " 123 ^ "resolve all differences (even non-conflicting changes) in favor of " 124 ^ "\\ARG{root}. " 125 ^ "This effectively changes Unison from a synchronizer into a mirroring " 126 ^ "utility. \n\n" 127 ^ "You can also specify a unique prefix or suffix of the path of one of " 128 ^ "the roots or a unique prefix of the hostname of a remote root.\n\n" 129 ^ "You can also specify \\verb|-force newer| (or \\verb|-force older|) " 130 ^ "to force Unison to choose the file with the later (earlier) " 131 ^ "modtime. In this case, the \\verb|-times| preference must also " 132 ^ "be enabled. If modtimes are equal in both replicas when using " 133 ^ "\\verb|newer| or \\verb|older| then this preference will have no " 134 ^ "effect (changes will be synced as if without this preference or " 135 ^ "remain unsynced in case of a conflict).\n\n" 136 ^ "This preference is overridden by the \\verb|forcepartial| preference.\n\n" 137 ^ "This preference should be used only if you are {\\em sure} you " 138 ^ "know what you are doing!") 139 140 let forceRootPartial: Pred.t = 141 Pred.create "forcepartial" 142 ~category:(`Advanced `Sync) 143 ("Including the preference \\texttt{forcepartial = \\ARG{PATHSPEC} -> \\ARG{root}} causes Unison to " 144 ^ "resolve all differences (even non-conflicting changes) in favor of " 145 ^ "\\ARG{root} for the files in \\ARG{PATHSPEC} (see \\sectionref{pathspec}{Path Specification} " 146 ^ "for more information). " 147 ^ "This effectively changes Unison from a synchronizer into a mirroring " 148 ^ "utility. \n\n" 149 ^ "You can also specify a unique prefix or suffix of the path of one of " 150 ^ "the roots or a unique prefix of the hostname of a remote root.\n\n" 151 ^ "You can also specify \\verb|forcepartial PATHSPEC -> newer| " 152 ^ "(or \\verb|forcepartial PATHSPEC -> older|) " 153 ^ "to force Unison to choose the file with the later (earlier) " 154 ^ "modtime. In this case, the \\verb|-times| preference must also " 155 ^ "be enabled. If modtimes are equal in both replicas when using " 156 ^ "\\verb|newer| or \\verb|older| then this preference will have no " 157 ^ "effect (changes will be synced as if without this preference or " 158 ^ "remain unsynced in case of a conflict).\n\n" 159 ^ "This preference should be used only if you are {\\em sure} you " 160 ^ "know what you are doing!") 161 162 let preferRoot: string Prefs.t = 163 Prefs.createString "prefer" "" 164 ~category:(`Advanced `Sync) 165 "choose this replica's version for conflicting changes" 166 ("Including the preference \\texttt{-prefer \\ARG{root}} causes Unison always to " 167 ^ "resolve conflicts in favor of \\ARG{root}, rather than asking for " 168 ^ "guidance from the user, except for paths marked by the preference " 169 ^ "\\texttt{merge}. (The syntax of \\ARG{root} is the same as " 170 ^ "for the \\verb|root| preference, plus the special values " 171 ^ "\\verb|newer| and \\verb|older|.) \n\n" 172 ^ "You can also specify a unique prefix or suffix of the path of one of " 173 ^ "the roots or a unique prefix of the hostname of a remote root.\n\n" 174 ^ "This preference is overridden by the \\verb|preferpartial| preference.\n\n" 175 ^ "This preference should be used only if you are {\\em sure} you " 176 ^ "know what you are doing!") 177 178 let preferRootPartial: Pred.t = 179 Pred.create "preferpartial" 180 ~category:(`Advanced `Sync) 181 ("Including the preference \\texttt{preferpartial = \\ARG{PATHSPEC} -> \\ARG{root}} " 182 ^ "causes Unison always to " 183 ^ "resolve conflicts in favor of \\ARG{root}, rather than asking for " 184 ^ "guidance from the user, for the files in \\ARG{PATHSPEC} (see " 185 ^ "\\sectionref{pathspec}{Path Specification} " 186 ^ "for more information). (The syntax of \\ARG{root} is the same as " 187 ^ "for the \\verb|root| preference, plus the special values " 188 ^ "\\verb|newer| and \\verb|older|.) \n\n" 189 ^ "You can also specify a unique prefix or suffix of the path of one of " 190 ^ "the roots or a unique prefix of the hostname of a remote root.\n\n" 191 ^ "This preference should be used only if you are {\\em sure} you " 192 ^ "know what you are doing!") 193 194 (* [lookupPreferredRoot (): string * [`Force | `Prefer]] checks validity of *) 195 (* preferences "force"/"preference", returns a pair (root, force) *) 196 let lookupPreferredRoot () = 197 if Prefs.read forceRoot <> "" then 198 (prefRoot (Prefs.read forceRoot), `Force) 199 else if Prefs.read preferRoot <> "" then 200 (prefRoot (Prefs.read preferRoot), `Prefer) 201 else 202 (`None, `Prefer) 203 204 (* [lookupPreferredRootPartial: Path.t -> string * [`Force | `Prefer]] checks validity of *) 205 (* preferences "forcepartial", returns a pair (root, force) *) 206 let lookupPreferredRootPartial p = 207 let s = Path.toString p in 208 if Pred.test forceRootPartial s then 209 (prefRoot (Pred.assoc forceRootPartial s), `Force) 210 else if Pred.test preferRootPartial s then 211 (prefRoot (Pred.assoc preferRootPartial s), `Prefer) 212 else 213 (`None, `Prefer) 214 215 let noDeletion = 216 Prefs.createStringList "nodeletion" 217 ~category:(`Basic `Sync) 218 "prevent file deletions on one replica" 219 ("Including the preference \\texttt{-nodeletion \\ARG{root}} prevents \ 220 Unison from performing any file deletion on root \\ARG{root}.\n\n\ 221 You can also specify a unique prefix or suffix of the path of one of \ 222 the roots or a unique prefix of the hostname of a remote root.\n\n\ 223 This preference can be included twice, once for each root, if you \ 224 want to prevent any deletion.") 225 226 let noUpdate = 227 Prefs.createStringList "noupdate" 228 ~category:(`Basic `Sync) 229 "prevent file updates and deletions on one replica" 230 ("Including the preference \\texttt{-noupdate \\ARG{root}} prevents \ 231 Unison from performing any file update or deletion on root \ 232 \\ARG{root}.\n\n\ 233 You can also specify a unique prefix or suffix of the path of one of \ 234 the roots or a unique prefix of the hostname of a remote root.\n\n\ 235 This preference can be included twice, once for each root, if you \ 236 want to prevent any update.") 237 238 let noCreation = 239 Prefs.createStringList "nocreation" 240 ~category:(`Basic `Sync) 241 "prevent file creations on one replica" 242 ("Including the preference \\texttt{-nocreation \\ARG{root}} prevents \ 243 Unison from performing any file creation on root \\ARG{root}.\n\n\ 244 You can also specify a unique prefix or suffix of the path of one of \ 245 the roots or a unique prefix of the hostname of a remote root.\n\n\ 246 This preference can be included twice, once for each root, if you \ 247 want to prevent any creation.") 248 249 let noDeletionPartial = 250 Pred.create "nodeletionpartial" 251 ~category:(`Advanced `Sync) 252 ("Including the preference \ 253 \\texttt{nodeletionpartial = \\ARG{PATHSPEC} -> \\ARG{root}} prevents \ 254 Unison from performing any file deletion in \\ARG{PATHSPEC} \ 255 on root \\ARG{root} (see \\sectionref{pathspec}{Path Specification} \ 256 for more information). It is recommended to use {\\tt BelowPath} \ 257 patterns when selecting a directory and all its contents.") 258 259 let noUpdatePartial = 260 Pred.create "noupdatepartial" 261 ~category:(`Advanced `Sync) 262 ("Including the preference \ 263 \\texttt{noupdatepartial = \\ARG{PATHSPEC} -> \\ARG{root}} prevents \ 264 Unison from performing any file update or deletion in \ 265 \\ARG{PATHSPEC} on root \\ARG{root} (see \ 266 \\sectionref{pathspec}{Path Specification} for more information). \ 267 It is recommended to use {\\tt BelowPath} \ 268 patterns when selecting a directory and all its contents.") 269 270 let noCreationPartial = 271 Pred.create "nocreationpartial" 272 ~category:(`Advanced `Sync) 273 ("Including the preference \ 274 \\texttt{nocreationpartial = \\ARG{PATHSPEC} -> \\ARG{root}} prevents \ 275 Unison from performing any file creation in \\ARG{PATHSPEC} \ 276 on root \\ARG{root} (see \\sectionref{pathspec}{Path Specification} \ 277 for more information). \ 278 It is recommended to use {\\tt BelowPath} \ 279 patterns when selecting a directory and all its contents.") 280 281 let maxSizeThreshold = 282 Prefs.createInt "maxsizethreshold" (-1) 283 ~category:(`Advanced `General) 284 "prevent transfer of files bigger than this (if >=0, in Kb)" 285 ("A number indicating above what filesize (in kilobytes) Unison should " 286 ^ "flag a conflict instead of transferring the file. " 287 ^ "This conflict remains even in the presence of force or prefer options. " 288 ^ "A negative number will allow every transfer independently of the size. " 289 ^ "The default is -1. ") 290 291 let testPartialCancelPref root path actionKind = 292 let partialCancelPref actionKind = 293 match actionKind with 294 `DELETION -> noDeletionPartial 295 | `UPDATE -> noUpdatePartial 296 | `CREATION -> noCreationPartial 297 in 298 Pred.assoc_all (partialCancelPref actionKind) path 299 |> List.exists (fun x -> root = prefRoot x) 300 301 let testCancelPref root actionKind = 302 let cancelPref actionKind = 303 match actionKind with 304 `DELETION -> noDeletion 305 | `UPDATE -> noUpdate 306 | `CREATION -> noCreation 307 in 308 Prefs.read (cancelPref actionKind) 309 |> List.exists (fun x -> root = prefRoot x) 310 311 let actionKind fromRc toRc = 312 let fromTyp = fromRc.typ in 313 let toTyp = toRc.typ in 314 if fromTyp = toTyp then `UPDATE else 315 if toTyp = `ABSENT then `CREATION else 316 `DELETION 317 318 let shouldCancel path rc1 rc2 root = 319 let test kind = 320 testCancelPref root kind 321 || 322 testPartialCancelPref root path kind 323 in 324 let testSize rc = 325 Prefs.read maxSizeThreshold >= 0 326 && Props.length rc.desc >= 327 Uutil.Filesize.ofInt64 328 (Int64.mul (Int64.of_int 1000) 329 (Int64.of_int (Prefs.read maxSizeThreshold))) 330 in 331 match actionKind rc1 rc2 with 332 `UPDATE -> 333 if test `UPDATE then true, "would update a file with noupdate or noupdatepartial set" 334 else testSize rc1, "would transfer a file of size greater than maxsizethreshold" 335 | `DELETION -> 336 if test `UPDATE then true, "would update a file with noupdate or noupdatepartial set" 337 else test `DELETION, "would delete a file with nodeletion or nodeletionpartial set" 338 | `CREATION -> 339 if test `CREATION then true, "would create a file with nocreation or nocreationpartial set" 340 else testSize rc1, "would transfer a file of size greater than maxsizethreshold" 341 342 let filterRi ri = 343 match ri.replicas with 344 Problem _ -> 345 () 346 | Different diff -> 347 let cancel,reason = 348 match diff.direction with 349 Replica1ToReplica2 -> 350 shouldCancel (Path.toString ri.path1) diff.rc1 diff.rc2 `Replica2ToReplica1 351 | Replica2ToReplica1 -> 352 shouldCancel (Path.toString ri.path1) diff.rc2 diff.rc1 `Replica1ToReplica2 353 | Conflict _ | Merge -> 354 false,"" 355 in 356 if cancel 357 then 358 diff.direction <- Conflict reason 359 360 let filterRis ris = 361 Safelist.iter filterRi ris 362 363 (* Use the current values of the '-prefer <ROOT>' and '-force <ROOT>' *) 364 (* preferences to override the reconciler's choices *) 365 let overrideReconcilerChoices ris = 366 clearRootDirCache (); 367 let (dir, force) = lookupPreferredRoot () in 368 if dir <> `None then Safelist.iter (fun ri -> setDirection ri dir force) ris; 369 Safelist.iter (fun ri -> 370 let (dir, forcep) = lookupPreferredRootPartial ri.path1 in 371 if dir <> `None then setDirection ri dir forcep) ris; 372 filterRis ris 373 374 (* Look up the preferred root and verify that it is OK (this is called at *) 375 (* the beginning of the run, so that we don't have to wait to hear about *) 376 (* errors *) 377 let checkThatPreferredRootIsValid () = 378 let test_root explicitRoot predname predvalue = 379 match prefRoot predvalue with 380 | `None | `Replica1ToReplica2 | `Replica2ToReplica1 -> () 381 | (`Newer | `Older) when explicitRoot -> 382 raise (Util.Fatal ("Argument to preference '" ^ predname ^ "': " 383 ^ predvalue ^ " must not be keyword 'older' or 'newer'.")) 384 | `Newer -> () 385 | `Older -> 386 if not (Prefs.read Props.syncModtimes) then 387 raise (Util.Transient (Printf.sprintf 388 "The '%s=older' preference can only be used with 'times=true'" 389 predname)) 390 | `Merge -> assert false 391 | exception (Util.Fatal err) -> 392 raise (Util.Fatal ("Argument to preference '" ^ predname ^ "': " ^ err)) 393 in 394 let checkPrefs ~explicitRoot extract prefs = 395 Safelist.iter (fun (pref, prefName) -> 396 Safelist.iter (test_root explicitRoot prefName) (extract pref)) prefs 397 in 398 checkPrefs ~explicitRoot:false (fun x -> [Prefs.read x]) 399 [forceRoot, "force"; preferRoot, "prefer"]; 400 checkPrefs ~explicitRoot:false Pred.extern_associated_strings 401 [forceRootPartial, "forcepartial"; 402 preferRootPartial, "preferpartial"]; 403 checkPrefs ~explicitRoot:true Prefs.read 404 [noDeletion, "nodeletion"; noUpdate, "noupdate"; noCreation, "nocreation"]; 405 checkPrefs ~explicitRoot:true Pred.extern_associated_strings 406 [noDeletionPartial, "nodeletionpartial"; 407 noUpdatePartial, "noupdatepartial"; 408 noCreationPartial, "nocreationpartial"] 409 410 (* ------------------------------------------------------------------------- *) 411 (* Main Reconciliation stuff *) 412 (* ------------------------------------------------------------------------- *) 413 414 exception UpdateError of string 415 416 let rec checkForError ui = 417 match ui with 418 NoUpdates -> 419 () 420 | Error err -> 421 if not (Fileinfo.shouldIgnore err) then raise (UpdateError err) 422 | Updates (uc, _) -> 423 match uc with 424 Dir (_, children, _, _) -> 425 Safelist.iter (fun (_, uiSub) -> checkForError uiSub) children 426 | Absent | File _ | Symlink _ -> 427 () 428 429 let rec collectErrors ui rem = 430 match ui with 431 NoUpdates -> 432 rem 433 | Error err -> 434 if Fileinfo.shouldIgnore err then rem else err :: rem 435 | Updates (uc, _) -> 436 match uc with 437 Dir (_, children, _, _) -> 438 Safelist.fold_right 439 (fun (_, uiSub) rem -> collectErrors uiSub rem) children rem 440 | Absent | File _ | Symlink _ -> 441 rem 442 443 (* lifting errors in individual updates to replica problems *) 444 let propagateErrors allowPartial (rplc: Common.replicas): Common.replicas = 445 match rplc with 446 Problem _ -> 447 rplc 448 | Different diff when allowPartial -> 449 Different { diff with 450 errors1 = collectErrors diff.rc1.ui []; 451 errors2 = collectErrors diff.rc2.ui [] } 452 | Different diff -> 453 try 454 checkForError diff.rc1.ui; 455 try 456 checkForError diff.rc2.ui; 457 rplc 458 with UpdateError err -> 459 Problem ("[root 2]: " ^ err) 460 with UpdateError err -> 461 Problem ("[root 1]: " ^ err) 462 463 (* Using the error message to ignore symlinks is a bit fragile but this is 464 the easiest way to keep code changes local and avoid a huge backwards 465 compatibility burden. *) 466 467 let skipIgnored result s othUi = 468 match Fileinfo.shouldIgnore s, othUi with 469 | false, _ -> Tree.add result (Problem s) 470 | true, Error s2 -> 471 if Fileinfo.shouldIgnore s2 then result else Tree.add result (Problem s2) 472 | true, NoUpdates 473 | true, Updates (Symlink _, _) -> result 474 | true, Updates _ -> 475 Tree.add result (Problem "Syncing symbolic links is disabled, but \ 476 this path represents a symbolic link in one of the replicas and \ 477 a non-link in the other replica.") 478 479 type singleUpdate = Rep1Updated | Rep2Updated 480 481 let update2replicaContent path (conflict: bool) ui props ucNew oldType: 482 Common.replicaContent = 483 let size = Update.updateSize path ui in 484 match ucNew with 485 Absent -> 486 {typ = `ABSENT; status = `Deleted; desc = Props.dummy; 487 ui = ui; size = size; props = props} 488 | File (desc, ContentsSame) -> 489 {typ = `FILE; status = `PropsChanged; desc = desc; 490 ui = ui; size = size; props = props} 491 | File (desc, _) when oldType <> `FILE -> 492 {typ = `FILE; status = `Created; desc = desc; 493 ui = ui; size = size; props = props} 494 | File (desc, ContentsUpdated _) -> 495 {typ = `FILE; status = `Modified; desc = desc; 496 ui = ui; size = size; props = props} 497 | Symlink l when oldType <> `SYMLINK -> 498 {typ = `SYMLINK; status = `Created; desc = Props.dummy; 499 ui = ui; size = size; props = props} 500 | Symlink l -> 501 {typ = `SYMLINK; status = `Modified; desc = Props.dummy; 502 ui = ui; size = size; props = props} 503 | Dir (desc, _, _, _) when oldType <> `DIRECTORY -> 504 {typ = `DIRECTORY; status = `Created; desc = desc; 505 ui = ui; size = size; props = props} 506 | Dir (desc, _, PropsUpdated, _) -> 507 {typ = `DIRECTORY; status = `PropsChanged; desc = desc; 508 ui = ui; size = size; props = props} 509 | Dir (desc, _, PropsSame, _) when conflict -> 510 (* Special case: the directory contents has been modified and the *) 511 (* directory is in conflict. (We don't want to display a conflict *) 512 (* between an unchanged directory and a file, for instance: this would *) 513 (* be rather puzzling to the user) *) 514 {typ = `DIRECTORY; status = `Modified; desc = desc; 515 ui = ui; size = size; props = props} 516 | Dir (desc, _, PropsSame, _) -> 517 {typ = `DIRECTORY; status = `Unchanged; desc =desc; 518 ui = ui; size = size; props = props} 519 520 let oldType (prev: Common.prevState): Fileinfo.typ = 521 match prev with 522 Previous (typ, _, _, _) -> typ 523 | New -> `ABSENT 524 525 let oldDesc (prev: Common.prevState): Props.t = 526 match prev with 527 Previous (_, desc, _, _) -> desc 528 | New -> Props.dummy 529 530 (* [describeUpdate ui] returns the replica contents for both the case of *) 531 (* updating and the case of non-updating *) 532 let describeUpdate path props' ui props 533 : Common.replicaContent * Common.replicaContent = 534 match ui with 535 Updates (ucNewStatus, prev) -> 536 let typ = oldType prev in 537 (update2replicaContent path false ui props ucNewStatus typ, 538 {typ = typ; status = `Unchanged; desc = oldDesc prev; 539 ui = NoUpdates; size = Update.updateSize path NoUpdates; 540 props = props'}) 541 | _ -> assert false 542 543 (* Computes the reconItems when only one side has been updated. (We split *) 544 (* this out into a separate function to avoid duplicating all the symmetric *) 545 (* cases.) *) 546 let rec reconcileNoConflict allowPartial path props' ui props whatIsUpdated 547 (result: (Name.t * Name.t, Common.replicas) Tree.u) 548 : (Name.t * Name.t, Common.replicas) Tree.u = 549 let different() = 550 let rcUpdated, rcNotUpdated = describeUpdate path props' ui props in 551 match whatIsUpdated with 552 Rep2Updated -> 553 Different {rc1 = rcNotUpdated; rc2 = rcUpdated; 554 direction = Replica2ToReplica1; 555 default_direction = Replica2ToReplica1; 556 errors1 = []; errors2 = []} 557 | Rep1Updated -> 558 Different {rc1 = rcUpdated; rc2 = rcNotUpdated; 559 direction = Replica1ToReplica2; 560 default_direction = Replica1ToReplica2; 561 errors1 = []; errors2 = []} in 562 match ui with 563 | NoUpdates -> result 564 | Error err -> 565 skipIgnored result err NoUpdates 566 | Updates (Dir (desc, children, permchg, _), 567 Previous(`DIRECTORY, _, _, _)) -> 568 let r = 569 if permchg = PropsSame then result else Tree.add result (different ()) 570 in 571 Safelist.fold_left 572 (fun result (theName, uiChild) -> 573 Tree.leave 574 (reconcileNoConflict allowPartial (Path.child path theName) 575 [] uiChild [] whatIsUpdated 576 (Tree.enter result (theName, theName)))) 577 r children 578 | Updates _ -> 579 Tree.add result (propagateErrors allowPartial (different ())) 580 581 (* [combineChildrn children1 children2] combines two name-sorted lists of *) 582 (* type [(Name.t * Common.updateItem) list] to a single list of type *) 583 (* [(Name.t * Common.updateItem * Common.updateItem] *) 584 let combineChildren children1 children2 = 585 (* NOTE: This function assumes children1 and children2 are sorted. *) 586 let rec loop r children1 children2 = 587 match children1,children2 with 588 [],_ -> 589 Safelist.rev_append r 590 (Safelist.map 591 (fun (name,ui) -> (name,NoUpdates,name,ui)) children2) 592 | _,[] -> 593 Safelist.rev_append r 594 (Safelist.map 595 (fun (name,ui) -> (name,ui,name,NoUpdates)) children1) 596 | (name1,ui1)::rem1, (name2,ui2)::rem2 -> 597 let dif = Name.compare name1 name2 in 598 if dif = 0 then 599 loop ((name1,ui1,name2,ui2)::r) rem1 rem2 600 else if dif < 0 then 601 loop ((name1,ui1,name1,NoUpdates)::r) rem1 children2 602 else 603 loop ((name2,NoUpdates,name2,ui2)::r) children1 rem2 604 in 605 loop [] children1 children2 606 607 (* File are marked equal in groups of 5000 to lower memory consumption *) 608 let add_equal (counter, archiveUpdated) equal v = 609 let eq = Tree.add equal v in 610 incr counter; 611 archiveUpdated := true; 612 if !counter = 5000 then begin 613 counter := 0; 614 let (t, eq) = Tree.slice eq in (* take a snapshot of the tree *) 615 Update.markEqual t; (* work on it *) 616 eq (* and return the leftover spine *) 617 end else 618 eq 619 620 (* The main reconciliation function: takes a path and two updateItem *) 621 (* structures and returns a list of reconItems containing suggestions for *) 622 (* propagating changes to make the two replicas equal. *) 623 (* -- *) 624 (* It uses two accumulators: *) 625 (* equals: (Name.t * Name.t, Common.updateContent * Common.updateContent) *) 626 (* Tree.u *) 627 (* unequals: (Name.t * Name.t, Common.replicas) Tree.u *) 628 (* -- *) 629 let rec reconcile 630 allowPartial path ui1 props1 ui2 props2 counter equals unequals = 631 let different uc1 uc2 reason oldType equals unequals = 632 (equals, 633 Tree.add unequals 634 (propagateErrors allowPartial 635 (Different {rc1 = update2replicaContent 636 path true ui1 props1 uc1 oldType; 637 rc2 = update2replicaContent 638 path true ui2 props2 uc2 oldType; 639 direction = Conflict reason; 640 default_direction = Conflict reason; 641 errors1 = []; errors2 = []}))) in 642 let toBeMerged uc1 uc2 oldType equals unequals = 643 (equals, 644 Tree.add unequals 645 (propagateErrors allowPartial 646 (Different {rc1 = update2replicaContent 647 path true ui1 props1 uc1 oldType; 648 rc2 = update2replicaContent 649 path true ui2 props2 uc2 oldType; 650 direction = Merge; default_direction = Merge; 651 errors1 = []; errors2 = []}))) in 652 match (ui1, ui2) with 653 (Error s, _) -> 654 (equals, skipIgnored unequals s ui2) 655 | (_, Error s) -> 656 (equals, skipIgnored unequals s ui1) 657 | (NoUpdates, _) -> 658 (equals, 659 reconcileNoConflict 660 allowPartial path props1 ui2 props2 Rep2Updated unequals) 661 | (_, NoUpdates) -> 662 (equals, 663 reconcileNoConflict 664 allowPartial path props2 ui1 props1 Rep1Updated unequals) 665 | (Updates (Absent, _), Updates (Absent, _)) -> 666 (add_equal counter equals (Absent, Absent), unequals) 667 | (Updates (Dir (desc1, children1, propsChanged1, _) as uc1, prevState1), 668 Updates (Dir (desc2, children2, propsChanged2, _) as uc2, prevState2)) -> 669 if Pred.test Globals.atomic (Path.toString path) then 670 let action = Conflict "atomic directory" in 671 (equals, 672 Tree.add unequals 673 (Different 674 {rc1 = update2replicaContent path true ui1 [] uc1 `DIRECTORY; 675 rc2 = update2replicaContent path true ui2 [] uc2 `DIRECTORY; 676 direction = action; default_direction = action; 677 errors1 = []; errors2 = []})) 678 else 679 (* See if the directory itself should have a reconItem *) 680 let dirResult = 681 if propsChanged1 = PropsSame && propsChanged2 = PropsSame then 682 (equals, unequals) 683 else if Props.similar desc1 desc2 then 684 let uc1 = Dir (desc1, [], PropsSame, false) in 685 let uc2 = Dir (desc2, [], PropsSame, false) in 686 (add_equal counter equals (uc1, uc2), unequals) 687 else 688 let action = 689 if propsChanged1 = PropsSame then Replica2ToReplica1 690 else if propsChanged2 = PropsSame then Replica1ToReplica2 691 else Conflict "properties changed on both sides" in 692 (equals, 693 Tree.add unequals 694 (Different 695 {rc1 = update2replicaContent path false ui1 [] uc1 `DIRECTORY; 696 rc2 = update2replicaContent path false ui2 [] uc2 `DIRECTORY; 697 direction = action; default_direction = action; 698 errors1 = []; errors2 = []})) 699 in 700 (* Apply reconcile on children. *) 701 Safelist.fold_left 702 (fun (equals, unequals) (name1,ui1,name2,ui2) -> 703 let (eq, uneq) = 704 reconcile 705 allowPartial (Path.child path name1) ui1 [] ui2 [] counter 706 (Tree.enter equals (name1, name2)) 707 (Tree.enter unequals (name1, name2)) 708 in 709 (Tree.leave eq, Tree.leave uneq)) 710 dirResult 711 (combineChildren children1 children2) 712 | (Updates (File (desc1,contentsChanged1) as uc1, prev), 713 Updates (File (desc2,contentsChanged2) as uc2, _)) -> 714 begin match contentsChanged1, contentsChanged2 with 715 ContentsUpdated (dig1, _, ress1), ContentsUpdated (dig2, _, ress2) 716 when dig1 = dig2 -> 717 if Props.similar desc1 desc2 then 718 (add_equal counter equals (uc1, uc2), unequals) 719 else 720 (* Special case: when both sides are modified files but their contents turn *) 721 (* out to be the same, we want to display them as 'perms' rather than 'new' *) 722 (* on both sides, to avoid confusing the user. (The Transfer module also *) 723 (* expect this.) *) 724 let uc1' = File(desc1,ContentsSame) in 725 let uc2' = File(desc2,ContentsSame) in 726 different uc1' uc2' "properties changed on both sides" 727 (oldType prev) equals unequals 728 | ContentsSame, ContentsSame when Props.similar desc1 desc2 -> 729 (add_equal counter equals (uc1, uc2), unequals) 730 | ContentsSame, ContentsSame -> 731 different uc1 uc2 "properties changed on both sides" 732 (oldType prev) equals unequals 733 | ContentsUpdated _, ContentsUpdated _ 734 when Globals.shouldMerge path -> 735 toBeMerged uc1 uc2 (oldType prev) equals unequals 736 | _ -> 737 different uc1 uc2 "contents changed on both sides" 738 (oldType prev) equals unequals 739 end 740 | (Updates (Symlink(l1) as uc1, prev), 741 Updates (Symlink(l2) as uc2, _)) -> 742 if l1 = l2 then 743 (add_equal counter equals (uc1, uc2), unequals) 744 else 745 different uc1 uc2 "symbolic links changed on both sides" 746 (oldType prev) equals unequals 747 | (Updates (uc1, prev), Updates (uc2, _)) -> 748 different uc1 uc2 "conflicting updates" 749 (oldType prev) equals unequals 750 751 (* Sorts the paths so that they will be displayed in order *) 752 let sortPaths pathUpdatesList = 753 List.sort 754 Path.compare 755 pathUpdatesList 756 757 let rec enterPath p1 p2 t = 758 match Path.deconstruct p1, Path.deconstruct p2 with 759 None, None -> 760 t 761 | Some (nm1, p1'), Some (nm2, p2') -> 762 enterPath p1' p2' (Tree.enter t (nm1, nm2)) 763 | _ -> 764 assert false (* Cannot happen, as the paths are equal up to case *) 765 766 let rec leavePath p t = 767 match Path.deconstruct p with 768 None -> t 769 | Some (nm, p') -> leavePath p' (Tree.leave t) 770 771 (* A path is dangerous if one replica has been emptied but not the other *) 772 let dangerousPath u1 u2 = 773 let emptied u = 774 match u with 775 Updates (Absent, _) -> true 776 | Updates (Dir (_, _, _, empty), _) -> empty 777 | _ -> false 778 in 779 emptied u1 <> emptied u2 780 781 (* The second component of the return value is true if there is at least one *) 782 (* file that is updated in the same way on both roots *) 783 let reconcileList allowPartial 784 (pathUpdatesList: 785 ((Path.local * Common.updateItem * Props.t list) * 786 (Path.local * Common.updateItem * Props.t list)) list) 787 : Common.reconItem list * bool * Path.t list = 788 let counter = ref 0 in 789 let archiveUpdated = ref false in 790 let (equals, unequals, dangerous) = 791 Safelist.fold_left 792 (fun (equals, unequals, dangerous) 793 ((path1,ui1,props1),(path2,ui2,props2)) -> 794 (* We make the paths global as we may concatenate them with 795 names from the other replica *) 796 let path1 = Path.makeGlobal path1 in 797 let path2 = Path.makeGlobal path2 in 798 let (equals, unequals) = 799 reconcile allowPartial 800 path1 ui1 props1 ui2 props2 (counter, archiveUpdated) 801 (enterPath path1 path2 equals) 802 (enterPath path1 path2 unequals) 803 in 804 (leavePath path1 equals, leavePath path1 unequals, 805 if dangerousPath ui1 ui2 then path1 :: dangerous else dangerous)) 806 (Tree.start, Tree.start, []) pathUpdatesList in 807 let unequals = Tree.finish unequals in 808 debug (fun() -> Util.msg "reconcile: %d results\n" (Tree.size unequals)); 809 let equals = Tree.finish equals in 810 Update.markEqual equals; 811 (* Commit archive updates done up to now *) 812 if !archiveUpdated then Update.commitUpdates (); 813 let result = 814 Tree.flatten unequals (Path.empty, Path.empty) 815 (fun (p1, p2) (nm1, nm2) -> (Path.child p1 nm1, Path.child p2 nm2)) [] in 816 let unsorted = 817 Safelist.map 818 (fun ((p1, p2), rplc) -> {path1 = p1; path2 = p2; replicas = rplc}) 819 result in 820 let sorted = Sortri.sortReconItems unsorted in 821 overrideReconcilerChoices sorted; 822 (sorted, not (Tree.is_empty equals), dangerous) 823 824 (* This is the main function: it takes a list of updateItem lists and, 825 according to the roots and paths of synchronization, builds the 826 corresponding reconItem list. A second component indicates whether there 827 is any file updated in the same way on both sides. *) 828 let reconcileAll ?(allowPartial = false) updatesList = 829 Trace.status "Reconciling changes"; 830 debug (fun() -> Util.msg "reconcileAll\n"); 831 reconcileList allowPartial updatesList