stasher.ml (23258B)
1 (* Unison file synchronizer: src/stasher.ml *) 2 (* $I2: Last modified by lescuyer *) 3 (* Copyright 1999-2020, Benjamin C. Pierce 4 5 This program is free software: you can redistribute it and/or modify 6 it under the terms of the GNU General Public License as published by 7 the Free Software Foundation, either version 3 of the License, or 8 (at your option) any later version. 9 10 This program is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 GNU General Public License for more details. 14 15 You should have received a copy of the GNU General Public License 16 along with this program. If not, see <http://www.gnu.org/licenses/>. 17 *) 18 19 20 (* --------------------------------------------------------------------------*) 21 (* Preferences for backing up and stashing *) 22 23 let debug = Util.debug "stasher" 24 let verbose = Util.debug "stasher+" 25 26 let backuplocation = 27 Prefs.createString "backuploc" "central" 28 ~category:(`Advanced `Syncprocess) 29 "where backups are stored ('local' or 'central')" 30 ("This preference determines whether backups should be kept locally, near the " 31 ^ "original files, or" 32 ^" in a central directory specified by the \\texttt{backupdir} " 33 ^"preference. If set to \\verb|local|, backups will be kept in " 34 ^"the same directory as the original files, and if set to \\verb|central|," 35 ^" \\texttt{backupdir} will be used instead.") 36 37 let _ = Prefs.alias backuplocation "backuplocation" 38 39 let backup = 40 Pred.create "backup" 41 ~category:(`Advanced `Syncprocess) 42 ("Including the preference \\texttt{-backup \\ARG{pathspec}} " 43 ^ "causes Unison to keep backup files for each path that matches " 44 ^ "\\ARG{pathspec}; directories (nor their permissions or any other " 45 ^ " metadata) are not backed up. These backup files are kept in the " 46 ^ "directory specified by the \\verb|backuplocation| preference. The backups are named " 47 ^ "according to the \\verb|backupprefix| and \\verb|backupsuffix| preferences." 48 ^ " The number of versions that are kept is determined by the " 49 ^ "\\verb|maxbackups| preference." 50 ^ "\n\n The syntax of \\ARG{pathspec} is described in " 51 ^ "\\sectionref{pathspec}{Path Specification}.") 52 53 let _ = Pred.alias backup "mirror" 54 55 let backupnot = 56 Pred.create "backupnot" 57 ~category:(`Advanced `Syncprocess) 58 ("The values of this preference specify paths or individual files or" 59 ^ " regular expressions that should {\\em not} " 60 ^ "be backed up, even if the {\\tt backup} preference selects " 61 ^ "them---i.e., it selectively overrides {\\tt backup}.") 62 63 let _ = Pred.alias backupnot "mirrornot" 64 65 let shouldBackup p = 66 let s = (Path.toString p) in 67 Pred.test backup s && not (Pred.test backupnot s) 68 69 let backupprefix = 70 Prefs.createString "backupprefix" ".bak.$VERSION." 71 ~category:(`Advanced `Syncprocess) 72 "prefix for the names of backup files" 73 ("When a backup for a file \\verb|NAME| is created, it is stored " 74 ^ "in a directory specified by \\texttt{backuplocation}, in a file called " 75 ^ "\\texttt{backupprefix}\\verb|NAME|\\texttt{backupsuffix}." 76 ^ " \\texttt{backupprefix} can include a directory name (causing Unison to " 77 ^ "keep all backup files for a given directory in a subdirectory with this name), and both " 78 ^ " \\texttt{backupprefix} and \\texttt{backupsuffix} can contain the string " 79 ^ "\\ARG{\\$VERSION}, which will be replaced by the \\emph{age} of the backup " 80 ^ "(1 for the most recent, 2 for the second most recent, and so on...)." 81 ^ " This keyword is ignored if it appears in a directory name" 82 ^ " in the prefix; if it does not appear anywhere" 83 ^ " in the prefix or the suffix, it will be automatically" 84 ^ " placed at the beginning of the suffix. " 85 ^ "\n\n" 86 ^ "One thing to be careful of: If the {\\tt backuploc} preference is set " 87 ^ "to {\\tt local}, Unison will automatically ignore {\\em all} files " 88 ^ "whose prefix and suffix match {\\tt backupprefix} and {\\tt backupsuffix}. " 89 ^ "So be careful to choose values for these preferences that are sufficiently " 90 ^ "different from the names of your real files.") 91 92 let backupsuffix = 93 Prefs.createString "backupsuffix" "" 94 ~category:(`Advanced `Syncprocess) 95 "a suffix to be added to names of backup files" 96 ("See \\texttt{backupprefix} for full documentation.") 97 98 let backups = 99 Prefs.createBool "backups" false 100 ~category:(`Advanced `Syncprocess) 101 ~deprecated:true 102 "keep backup copies of all files (see also 'backup')" 103 ("Setting this flag to true is equivalent to " 104 ^" setting \\texttt{backuplocation} to \\texttt{local}" 105 ^" and \\texttt{backup} to \\verb|Name *|.") 106 107 (* The following function is used to express the old backup preference, if set, 108 in the terms of the new preferences *) 109 let translateOldPrefs () = 110 match (Pred.extern backup, Pred.extern backupnot, Prefs.read backups) with 111 ([], [], true) -> 112 debug (fun () -> 113 Util.msg "backups preference set: translated into backup and backuplocation\n"); 114 Pred.intern backup ["Name *"]; 115 Prefs.set backuplocation "local" 116 | (_, _, false) -> 117 () 118 | _ -> raise (Util.Fatal ( "Both old 'backups' preference and " 119 ^ "new 'backup' preference are set!")) 120 121 let maxbackups = 122 Prefs.createInt "maxbackups" 2 123 ~category:(`Advanced `Syncprocess) 124 "number of backed up versions of a file" 125 ("This preference specifies the number of backup versions that will " 126 ^ "be kept by unison, for each path that matches the predicate " 127 ^ "\\verb|backup|. The default is 2.") 128 129 let _ = Prefs.alias maxbackups "mirrorversions" 130 let _ = Prefs.alias maxbackups "backupversions" 131 132 let backupdir = 133 Prefs.createString "backupdir" "" 134 ~category:(`Advanced `Syncprocess) 135 "directory for storing centralized backups" 136 ("If this preference is set, Unison will use it as the name of the " 137 ^ "directory used to store backup files specified by " 138 ^ "the {\\tt backup} preference, when {\\tt backuplocation} is set" 139 ^ " to \\verb|central|. It is checked {\\em after} the " 140 ^ "{\\tt UNISONBACKUPDIR} environment variable.") 141 142 let backupDirectory () = 143 Util.convertUnixErrorsToTransient "backupDirectory()" (fun () -> 144 try Fspath.canonize (Some (System.getenv "UNISONBACKUPDIR")) 145 with Not_found -> 146 try Fspath.canonize (Some (System.getenv "UNISONMIRRORDIR")) 147 with Not_found -> 148 if Prefs.read backupdir <> "" 149 then Fspath.canonize (Some (Prefs.read backupdir)) 150 else Fspath.canonize 151 (Some (Util.fileInUnisonDir "backup"))) 152 153 let backupcurrent = 154 Pred.create "backupcurr" 155 ~category:(`Advanced `Syncprocess) 156 ("Including the preference \\texttt{-backupcurr \\ARG{pathspec}} " 157 ^" causes Unison to keep a backup of the {\\em current} version of every file " 158 ^ "matching \\ARG{pathspec}. " 159 ^" This file will be saved as a backup with version number 000. Such" 160 ^" backups can be used as inputs to external merging programs, for instance. See " 161 ^ "the documentation for the \\verb|merge| preference." 162 ^" For more details, see \\sectionref{merge}{Merging Conflicting Versions}." 163 ^"\n\n The syntax of \\ARG{pathspec} is described in " 164 ^ "\\sectionref{pathspec}{Path Specification}.") 165 166 let backupcurrentnot = 167 Pred.create "backupcurrnot" 168 ~category:(`Advanced `Syncprocess) 169 "Exceptions to \\verb|backupcurr|, like the \\verb|ignorenot| preference." 170 171 let shouldBackupCurrent p = 172 (let s = Path.toString p in 173 Pred.test backupcurrent s && not (Pred.test backupcurrentnot s)) 174 175 let _ = Pred.alias backupcurrent "backupcurrent" 176 let _ = Pred.alias backupcurrentnot "backupcurrentnot" 177 178 (* ---------------------------------------------------------------------------*) 179 180 (* NB: We use Str.regexp here because we need group matching to retrieve 181 and increment version numbers from backup file names. We only use 182 it here, though: to check if a path should be backed up or ignored, we 183 use Rx instead. (This is important because the Str regexp functions are 184 terribly slow.) *) 185 186 (* A tuple of string option * string * string, describing a regular 187 expression that matches the filenames of unison backups according 188 to the current preferences. The first regexp is an option to match 189 the local directory, if any, in which backups are stored; the second 190 one matches the prefix, the third the suffix. 191 192 Note that we always use forward slashes here (rather than using backslashes 193 when running on windows) because we are constructing rx's that are going to 194 be matched against Path.t's. (Strictly speaking, we ought to ask the Path 195 module what the path separator character is, rather than assuming it is slash, 196 but this is never going to change.) 197 *) 198 let backup_rx () = 199 let version_rx = "\\([0-9]+\\)" in 200 let prefix = Prefs.read backupprefix in 201 let suffix = Str.quote (Prefs.read backupsuffix) in 202 let (udir, uprefix) = 203 ((match Filename.dirname prefix with 204 | "." -> "" 205 | s -> (Fileutil.backslashes2forwardslashes s)^"/"), 206 Filename.basename prefix) in 207 let (dir, prefix) = 208 ((match udir with "" -> None | _ -> Some(Str.quote udir)), Str.quote uprefix) in 209 if Str.string_match (Str.regexp ".*\\\\\\$VERSION.*") (prefix^suffix) 0 then 210 (dir, 211 Str.global_replace (Str.regexp "\\\\\\$VERSION") version_rx prefix, 212 Str.global_replace (Str.regexp "\\\\\\$VERSION") version_rx suffix) 213 else 214 raise (Util.Fatal "Either backupprefix or backupsuffix must contain '$VERSION'") 215 216 (* We ignore files whose name ends in .unison.bak, since people may still have these 217 lying around from using previous versions of Unison. *) 218 let oldBackupPrefPathspec = "Name *.unison.bak" 219 220 (* This function creates Rx regexps based on the preferences to ignore 221 backups of old and current versions. *) 222 let addBackupFilesToIgnorePref () = 223 let (dir_rx, prefix_rx, suffix_rx) = backup_rx() in 224 let regexp_to_rx s = 225 Str.global_replace (Str.regexp "\\\\(") "" 226 (Str.global_replace (Str.regexp "\\\\)") "" s) in 227 let (full, dir) = 228 let d = 229 match dir_rx with 230 None -> "/" 231 | Some s -> regexp_to_rx s in 232 let p = regexp_to_rx prefix_rx in 233 let s = regexp_to_rx suffix_rx in 234 debug (fun() -> Util.msg "d = %s\n" d); 235 ("(.*/)?"^p^".*"^s, "(.*/)?"^(String.sub d 0 (String.length d - 1))) in 236 let theRegExp = 237 match dir_rx with 238 None -> "Regex " ^ full 239 | Some _ -> "Regex " ^ dir in 240 241 Globals.addRegexpToIgnore oldBackupPrefPathspec; 242 if Prefs.read backuplocation = "local" then begin 243 debug (fun () -> 244 Util.msg "New pattern being added to ignore preferences (for backup files):\n %s\n" 245 theRegExp); 246 Globals.addRegexpToIgnore theRegExp 247 end 248 249 (* We use references for functions that compute the prefixes and suffixes 250 in order to avoid using functions from the Str module each time we need them. *) 251 let make_prefix = ref (fun i -> assert false) 252 let make_suffix = ref (fun i -> assert false) 253 254 (* This function updates the function used to create prefixes and suffixes 255 for naming backup files, according to the preferences. *) 256 let updateBackupNamingFunctions () = 257 let makeFun s = 258 match Str.full_split (Str.regexp "\\$VERSION") s with 259 [] -> (fun _ -> "") 260 | [Str.Text t] -> 261 (fun _ -> t) 262 | [Str.Delim _; Str.Text t] -> 263 (fun i -> Printf.sprintf "%d%s" i t) 264 | [Str.Text t; Str.Delim _] -> 265 (fun i -> Printf.sprintf "%s%d" t i) 266 | [Str.Text t; Str.Delim _; Str.Text t'] -> 267 (fun i -> Printf.sprintf "%s%d%s" t i t') 268 | _ -> raise (Util.Fatal ( 269 "The tag $VERSION should only appear " 270 ^"once in the backupprefix and backupsuffix preferences.")) in 271 272 make_prefix := makeFun (Prefs.read backupprefix); 273 make_suffix := makeFun (Prefs.read backupsuffix); 274 debug (fun () -> Util.msg 275 "Prefix and suffix regexps for backup filenames have been updated\n") 276 277 (*------------------------------------------------------------------------------------*) 278 279 let makeBackupName fspath path i = 280 (* In the special case when the root itself is a file, use the root's name 281 as the backup file name. Empty path will break backups. 282 We only check the path being empty, and not its type, because the root 283 can change from file to dir and vice versa between syncs. *) 284 let path' = 285 if Path.isEmpty path then 286 Path.fromString (Filename.basename (Fspath.toString fspath)) 287 else path in 288 289 (* if backups are kept centrally, the current version has exactly 290 the same name as the original, for convenience. *) 291 if i=0 && Prefs.read backuplocation = "central" then 292 path' 293 else 294 Path.addSuffixToFinalName 295 (Path.addPrefixToFinalName path' (!make_prefix i)) 296 (!make_suffix i) 297 298 let stashDirectory fspath path = 299 match Prefs.read backuplocation with 300 "central" -> backupDirectory () 301 | "local" when Path.isEmpty path -> 302 (* Special case when the root itself is a file. Can't use the root 303 as the backup location, which must be a directory. Use the root's 304 parent instead. *) 305 Fspath.canonize (Some (Filename.dirname (Fspath.toString fspath))) 306 | "local" -> fspath 307 | _ -> raise (Util.Fatal ("backuplocation preference should be set" 308 ^"to central or local.")) 309 310 let showContent typ fspath path = 311 match typ with 312 | `FILE -> Fingerprint.toString (Fingerprint.file fspath path) 313 | `SYMLINK -> Os.readLink fspath path 314 | `DIRECTORY -> "DIR" 315 | `ABSENT -> "ABSENT" 316 317 (* Generates a file name for a backup file. If backup file already exists, 318 the old file will be renamed with the count incremented. The newest 319 backup file is always the one with version number 1, larger numbers mean 320 older files. *) 321 (* BCP: Note that the way we keep bumping up the backup numbers on all existing 322 backup files could make backups very expensive if someone sets maxbackups to a 323 sufficiently large number! 324 *) 325 let backupPath fspath path = 326 let sFspath = stashDirectory fspath path in 327 328 let rec f fspath path i = 329 let tempPath = makeBackupName fspath path i in 330 verbose (fun () -> Util.msg "backupPath f %s %d\n" (Path.toString path) i); 331 if Os.exists sFspath tempPath then 332 if i < Prefs.read maxbackups then begin 333 verbose (fun () -> Util.msg "need to rename backup file\n"); 334 Os.rename "backupPath" sFspath tempPath sFspath (f fspath path (i + 1)) 335 end 336 else if i >= Prefs.read maxbackups then 337 Os.delete sFspath tempPath; 338 tempPath in 339 340 let rec mkdirectories backdir = 341 verbose (fun () -> Util.msg 342 "mkdirectories %s %s\n" 343 (Fspath.toDebugString sFspath) (Path.toString backdir)); 344 if not (Os.exists sFspath Path.empty) then 345 Os.createDir sFspath Path.empty (Props.perms Props.dirDefault); 346 match Path.deconstructRev backdir with 347 None -> () 348 | Some (_, parent) -> 349 mkdirectories parent; 350 let perms = Props.perms (Fileinfo.getBasic false sFspath Path.empty).desc in 351 if not (Os.exists sFspath backdir) then Os.createDir sFspath backdir perms 352 else (* Do not just check with Os.exists. It must also be a directory. 353 https://github.com/bcpierce00/unison/issues/30 354 If a non-directory with the same name exists, it must be moved 355 out of the way. Backup version rotation [f backdir] is used for 356 this purpose. 357 This is only applicable with backuplocation "central" as it 358 will create a separate directory tree. *) 359 if (Prefs.read backuplocation = "central") && 360 Fileinfo.getType false sFspath backdir != `DIRECTORY then 361 let backdir = f sFspath backdir 0 in 362 Os.createDir sFspath backdir perms in 363 364 let path0 = makeBackupName fspath path 0 in 365 let sourceTyp = Fileinfo.getType true fspath path in 366 let path0Typ = Fileinfo.getType false sFspath path0 in 367 368 if ( sourceTyp = `FILE && path0Typ = `FILE 369 && (Fingerprint.file fspath path) = (Fingerprint.file sFspath path0)) 370 || ( sourceTyp = `SYMLINK && path0Typ = `SYMLINK 371 && (Os.readLink fspath path) = (Os.readLink sFspath path0)) 372 then begin 373 debug (fun()-> Util.msg 374 "[%s / %s] = [%s / %s] = %s: no need to back up\n" 375 (Fspath.toDebugString sFspath) (Path.toString path0) 376 (Fspath.toDebugString fspath) (Path.toString path) 377 (showContent sourceTyp fspath path)); 378 None 379 end else begin 380 debug (fun()-> Util.msg 381 "stashed [%s / %s] = %s is not equal to new [%s / %s] = %s (or one is a dir): stash!\n" 382 (Fspath.toDebugString sFspath) (Path.toString path0) 383 (showContent path0Typ sFspath path0) 384 (Fspath.toDebugString fspath) (Path.toString path) 385 (showContent sourceTyp fspath path)); 386 let sPath = f fspath path 0 in 387 (* Make sure the parent directory exists *) 388 begin match Path.deconstructRev sPath with 389 | None -> mkdirectories Path.empty 390 | Some (_, backdir) -> mkdirectories backdir 391 end; 392 Some(sFspath, sPath) 393 end 394 395 (*------------------------------------------------------------------------------------*) 396 397 let backup fspath path (finalDisposition : [`AndRemove | `ByCopying]) arch = 398 debug (fun () -> Util.msg 399 "backup: %s / %s\n" 400 (Fspath.toDebugString fspath) 401 (Path.toString path)); 402 Util.convertUnixErrorsToTransient "backup" (fun () -> 403 let (workingDir,realPath) = Fspath.findWorkingDir fspath path in 404 let disposeIfNeeded() = 405 if finalDisposition = `AndRemove then 406 Os.delete workingDir realPath in 407 if not (Os.exists workingDir realPath) then 408 debug (fun () -> Util.msg 409 "File %s in %s does not exist, so no need to back up\n" 410 (Path.toString path) (Fspath.toDebugString fspath)) 411 else if shouldBackup path then begin 412 match backupPath fspath path with 413 None -> disposeIfNeeded() 414 | Some (backRoot, backPath) -> 415 debug (fun () -> Util.msg "Backing up %s / %s to %s in %s\n" 416 (Fspath.toDebugString fspath) (Path.toString path) 417 (Path.toString backPath) (Fspath.toDebugString backRoot)); 418 let byCopying() = 419 Copy.recursively fspath path backRoot backPath; 420 disposeIfNeeded() in 421 begin if finalDisposition = `AndRemove then 422 try 423 (*FIX: this does the wrong thing with followed symbolic links!*) 424 Os.rename "backup" workingDir realPath backRoot backPath 425 with Util.Transient _ -> 426 debug (fun () -> Util.msg "Rename failed -- copying instead\n"); 427 byCopying() 428 else 429 byCopying() 430 end; 431 Update.iterFiles backRoot backPath arch Xferhint.insertEntry 432 end else begin 433 debug (fun () -> Util.msg "Path %s / %s does not need to be backed up\n" 434 (Fspath.toDebugString fspath) 435 (Path.toString path)); 436 disposeIfNeeded() 437 end) 438 439 (*------------------------------------------------------------------------------------*) 440 441 let rec stashCurrentVersion fspath path sourcePathOpt = 442 if shouldBackupCurrent path then 443 Util.convertUnixErrorsToTransient "stashCurrentVersion" (fun () -> 444 let sourcePath = match sourcePathOpt with None -> path | Some p -> p in 445 debug (fun () -> Util.msg "stashCurrentVersion of %s (drawn from %s) in %s\n" 446 (Path.toString path) (Path.toString sourcePath) (Fspath.toDebugString fspath)); 447 let stat = Fileinfo.get true fspath sourcePath in 448 match stat.Fileinfo.typ with 449 `ABSENT -> () 450 | `DIRECTORY -> 451 assert (sourcePathOpt = None); 452 debug (fun () -> Util.msg "Stashing recursively because file is a directory\n"); 453 ignore (Safelist.iter 454 (fun n -> 455 let pathChild = Path.child path n in 456 if not (Globals.shouldIgnore pathChild) then 457 stashCurrentVersion fspath (Path.child path n) None) 458 (Os.childrenOf fspath path)) 459 | `SYMLINK -> 460 begin match backupPath fspath path with 461 | None -> () 462 | Some (stashFspath,stashPath) -> 463 Os.symlink stashFspath stashPath (Os.readLink fspath sourcePath) 464 end 465 | `FILE -> 466 begin match backupPath fspath path with 467 | None -> () 468 | Some (stashFspath, stashPath) -> 469 Copy.localFile 470 fspath sourcePath 471 stashFspath stashPath stashPath 472 `Copy 473 stat.Fileinfo.desc 474 (Osx.ressLength stat.Fileinfo.osX.Osx.ressInfo) 475 None 476 end) 477 478 let _ = 479 Update.setStasherFun (fun fspath path -> stashCurrentVersion fspath path None) 480 481 (*------------------------------------------------------------------------------------*) 482 483 (* This function tries to find a backup of a recent version of the file at location 484 (fspath, path) in the current replica, matching the given fingerprint. If no file 485 is found, then the functions returns None *without* searching on the other replica *) 486 let getRecentVersion fspath path fingerprint = 487 debug (fun () -> 488 Util.msg "getRecentVersion of %s in %s\n" 489 (Path.toString path) 490 (Fspath.toDebugString fspath)); 491 Util.convertUnixErrorsToTransient "getRecentVersion" (fun () -> 492 let dir = stashDirectory fspath path in 493 let rec aux_find i = 494 let path = makeBackupName fspath path i in 495 if Os.exists dir path && 496 (* FIX: should check that the existing file has the same size, to 497 avoid computing the fingerprint if it is obviously going to be 498 different... *) 499 (let dig = Os.fingerprint dir path (Fileinfo.getType false dir path) in 500 dig = fingerprint) 501 then begin 502 debug (fun () -> 503 Util.msg "recent version %s found in %s\n" 504 (Path.toString path) 505 (Fspath.toDebugString dir)); 506 Some (Fspath.concat dir path) 507 end else 508 if i = Prefs.read maxbackups then begin 509 debug (fun () -> 510 Util.msg "No recent version was available for %s on this root.\n" 511 (Fspath.toDebugString (Fspath.concat fspath path))); 512 None 513 end else 514 aux_find (i+1) 515 in 516 aux_find 0) 517 518 (*------------------------------------------------------------------------------------*) 519 520 (* This function initializes the Stasher module according to the preferences 521 defined in the profile. It should be called whenever a profile is reloaded. *) 522 let initBackupsLocal () = 523 debug (fun () -> Util.msg "initBackupsLocal\n"); 524 translateOldPrefs (); 525 addBackupFilesToIgnorePref (); 526 updateBackupNamingFunctions () 527 528 let initBackupsRoot: Common.root -> unit -> unit Lwt.t = 529 Remote.registerRootCmd 530 "initBackups" Umarshal.unit Umarshal.unit 531 (fun (fspath, ()) -> 532 Lwt.return (initBackupsLocal ())) 533 534 let initBackups () = 535 Lwt_unix.run ( 536 Globals.allRootsIter (fun r -> initBackupsRoot r ()))