test.ml (24769B)
1 (* Unison file synchronizer: src/test.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 let (>>=) = Lwt.(>>=) 20 21 (* ---------------------------------------------------------------------- *) 22 (* Utility functions *) 23 24 let debug = Trace.debug "test" 25 let verbose = Trace.debug "test" 26 27 let rec remove_file_or_dir d = 28 match try Some(Fs.lstat d) with Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) -> None with 29 | Some(s) -> 30 if s.Unix.LargeFile.st_kind = Unix.S_DIR then begin 31 let handle = Fs.opendir d in 32 let rec loop () = 33 let r = try Some(handle.Fs.readdir ()) with End_of_file -> None in 34 match r with 35 | Some f -> 36 if f="." || f=".." then loop () 37 else begin 38 remove_file_or_dir (Fspath.concat d (Path.fromString f)); 39 loop () 40 end 41 | None -> 42 handle.Fs.closedir (); 43 Fs.rmdir d 44 in loop () 45 end else 46 Fs.unlink d 47 | None -> () 48 49 let read_chan chan = 50 let nbytes = in_channel_length chan in 51 let string = Bytes.create nbytes in 52 really_input chan string 0 nbytes; 53 string 54 55 let read file = 56 (* 57 if file = "-" then 58 read_chan stdin 59 else 60 *) 61 let chan = Fs.open_in_bin file in 62 try 63 let r = read_chan chan in 64 close_in chan; 65 r 66 with exn -> 67 close_in chan; 68 raise exn 69 70 let write file s = 71 (* 72 if file = "-" then 73 output_string stdout s 74 else 75 *) 76 let chan = 77 Fs.open_out_gen 78 [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o600 file in 79 try 80 output_string chan s; 81 close_out chan 82 with exn -> 83 close_out chan; 84 raise exn 85 86 let read_dir d = 87 let ignored = ["."; ".."] in 88 let d = Fs.opendir d in 89 let rec do_read acc = 90 try 91 (match (d.Fs.readdir ()) with 92 | s when Safelist.mem s ignored -> do_read acc 93 | f -> do_read (f :: acc)) 94 with End_of_file -> acc 95 in 96 let files = do_read [] in 97 d.Fs.closedir (); 98 files 99 100 let extend p file = Fspath.concat p (Path.fromString file) 101 102 type fs = 103 | File of string 104 | Link of string 105 | Dir of (string * fs) list 106 107 let mfs_rec fs = Umarshal.(sum3 string string (list (prod2 string fs id id)) 108 (function 109 | File a -> I31 a 110 | Link a -> I32 a 111 | Dir a -> I33 a) 112 (function 113 | I31 a -> File a 114 | I32 a -> Link a 115 | I33 a -> Dir a)) 116 117 let mfs = Umarshal.rec1 mfs_rec 118 119 let rec equal fs1 fs2 = 120 match fs1,fs2 with 121 | File s1, File s2 -> s1=s2 122 | Link s1, Link s2 -> s1=s2 123 | Dir d1, Dir d2 -> 124 let dom d = Safelist.sort String.compare (Safelist.map fst d) in 125 (dom d1 = dom d2) 126 && (Safelist.for_all 127 (fun x -> 128 equal (Safelist.assoc x d1) (Safelist.assoc x d2))) 129 (dom d1) 130 | _,_ -> false 131 132 let rec fs2string = function 133 | File s -> "File \"" ^ s ^ "\"" 134 | Link s -> "Link \"" ^ s ^ "\"" 135 | Dir s -> "Dir [" ^ (String.concat "; " 136 (Safelist.map (fun (n,fs') -> "(\""^n^"\", "^(fs2string fs')^")") s)) ^ "]" 137 138 let fsopt2string = function 139 None -> "MISSING" 140 | Some(f) -> fs2string f 141 142 let readfs p = 143 let rec loop p = 144 let s = Fs.lstat p in 145 match s.Unix.LargeFile.st_kind with 146 | Unix.S_REG -> File (Bytes.to_string (read p)) 147 | Unix.S_LNK -> Link (Fs.readlink p) 148 | Unix.S_DIR -> Dir (Safelist.map (fun x -> (x, loop (extend p x))) (read_dir p)) 149 | _ -> assert false 150 in try Some(loop p) with 151 Unix.Unix_error (Unix.ENOENT,_,_) -> None 152 153 let default_perm = 0o755 154 155 let writefs p fs = 156 verbose (fun() -> Util.msg "Writing new test filesystem\n"); 157 let rec loop p = function 158 | File s -> 159 verbose (fun() -> Util.msg "Writing %s with contents %s\n" 160 (Fspath.toDebugString p) s); 161 write p s 162 | Link s -> Fs.symlink s p 163 | Dir files -> 164 Fs.mkdir p default_perm; 165 Safelist.iter (fun (x,cont) -> loop (extend p x) cont) files 166 in 167 remove_file_or_dir p; 168 loop p fs 169 170 let checkRootEmpty : Common.root -> unit -> unit Lwt.t = 171 Remote.registerRootCmd 172 "checkRootEmpty" Umarshal.unit Umarshal.unit 173 (fun (fspath, ()) -> 174 if Os.exists fspath Path.empty then 175 raise (Util.Fatal (Printf.sprintf 176 "Path %s is not empty at start of tests!" 177 (Fspath.toPrintString fspath))); 178 Lwt.return ()) 179 180 let makeRootEmpty : Common.root -> unit -> unit Lwt.t = 181 Remote.registerRootCmd 182 "makeRootEmpty" Umarshal.unit Umarshal.unit 183 (fun (fspath, ()) -> 184 remove_file_or_dir fspath; 185 Lwt.return ()) 186 187 let getfs : Common.root -> unit -> (fs option) Lwt.t = 188 Remote.registerRootCmd 189 "getfs" Umarshal.unit Umarshal.(option mfs) 190 (fun (fspath, ()) -> 191 Lwt.return (readfs fspath)) 192 193 let getbackup : Common.root -> unit -> (fs option) Lwt.t = 194 Remote.registerRootCmd 195 "getbackup" Umarshal.unit Umarshal.(option mfs) 196 (fun (fspath, ()) -> 197 Lwt.return (readfs (Stasher.backupDirectory ()))) 198 199 let makeBackupEmpty : Common.root -> unit -> unit Lwt.t = 200 Remote.registerRootCmd 201 "makeBackupEmpty" Umarshal.unit Umarshal.unit 202 (fun (fspath, ()) -> 203 let b = Stasher.backupDirectory () in 204 debug (fun () -> Util.msg "Removing %s\n" (Fspath.toDebugString b)); 205 Lwt.return (remove_file_or_dir b)) 206 207 let putfs : Common.root -> fs -> unit Lwt.t = 208 Remote.registerRootCmd 209 "putfs" mfs Umarshal.unit 210 (fun (fspath, fs) -> 211 writefs fspath fs; 212 Lwt.return ()) 213 214 let loadPrefs l = 215 Prefs.loadStrings l; 216 Lwt_unix.run (Globals.propagatePrefs ()); 217 Stasher.initBackups() 218 219 (* ---------------------------------------------------------------------------- *) 220 221 let displayRis ris = 222 Safelist.iter 223 (fun ri -> 224 Util.msg "%s\n" (Uicommon.reconItem2string Path.empty ri "")) 225 ris 226 227 let minisleep (sec: float) = 228 ignore (Unix.select [] [] [] sec) 229 230 let sync ?(verbose=false) () = 231 let (reconItemList, _, _) = 232 Recon.reconcileAll (Update.findUpdates None) in 233 if verbose then begin 234 Util.msg "Sync result:\n"; 235 displayRis reconItemList 236 end; 237 minisleep 0.1; 238 Uicommon.transportItems (Array.of_list reconItemList) (fun _ -> true) 239 (fun _ ri -> 240 Transport.transportItem ri (Uutil.File.ofLine 0) (fun _ _ -> true)); 241 Update.commitUpdates() 242 243 let currentTest = ref "" 244 245 type checkable = R1 | R2 | BACKUP1 | BACKUP2 246 247 let checkable2string = function 248 R1 -> "R1" | R2 -> "R2" | BACKUP1 -> "BACKUP1" | BACKUP2 -> "BACKUP2" 249 250 let test() = 251 Util.warnPrinter := None; 252 Prefs.set Trace.logging false; 253 Prefs.set Trace.terse true; 254 Trace.sendLogMsgsToStderr := false; 255 256 let origPrefs = Prefs.dump 99 in 257 258 let runtest name prefs f = 259 Util.msg "%s...\n" name; 260 Util.convertUnixErrorsToFatal "Test.test" (fun() -> 261 currentTest := name; 262 Prefs.load origPrefs 99; 263 loadPrefs prefs; 264 debug (fun() -> Util.msg "Emptying backup directory\n"); 265 Lwt_unix.run (Globals.allRootsIter (fun r -> makeBackupEmpty r ())); 266 debug (fun() -> Util.msg "Running test\n"); 267 f(); 268 ) in 269 270 Util.msg "Running internal tests...\n"; 271 272 (* Paranoid checks, to make sure we do not delete anybody's filesystem! *) 273 if not (Safelist.for_all 274 (fun r -> Util.findsubstring "test" r <> None) 275 (Globals.rawRoots())) then 276 raise (Util.Fatal 277 "Self-tests can only be run if both roots include the string 'test'"); 278 if Util.findsubstring "test" (Fspath.toPrintString (Stasher.backupDirectory())) = None then 279 raise (Util.Fatal 280 ("Self-tests can only be run if the 'backupdir' preference (or wherever the backup " 281 ^ "directory name is coming from, e.g. the UNISONBACKUPDIR environment variable) " 282 ^ "includes the string 'test'")); 283 284 Lwt_unix.run (Globals.allRootsIter (fun r -> makeRootEmpty r ())); 285 286 let (r2,r1) = Globals.roots () in 287 (* Util.msg "r1 = %s r2 = %s...\n" (Common.root2string r1) (Common.root2string r2); *) 288 let bothRootsLocal = 289 match (r1,r2) with 290 (Common.Local,_),(Common.Local,_) -> true 291 | _ -> false in 292 293 let put c fs = 294 Lwt_unix.run 295 (match c with 296 R1 -> putfs r1 fs | R2 -> putfs r2 fs | BACKUP1 | BACKUP2 -> assert false) in 297 298 let failures = ref 0 in 299 300 let check name c fs = 301 debug (fun() -> Util.msg "Checking %s / %s\n" (!currentTest) name); 302 let actual = 303 Lwt_unix.run 304 ((match c with 305 R1 -> getfs r1 | R2 -> getfs r2 | BACKUP1 -> getbackup r1 | BACKUP2 -> getbackup r2) ()) in 306 let fail () = 307 Util.msg 308 "Test %s / %s: \nExpected %s = \n %s\nbut found\n %s\n" 309 (!currentTest) name (checkable2string c) (fs2string fs) (fsopt2string actual); 310 failures := !failures+1; 311 raise (Util.Fatal (Printf.sprintf "Self-test %s / %s failed!" (!currentTest) name)) in 312 match actual with 313 Some(a) -> if not (equal a fs) then fail() 314 | None -> fail() in 315 316 let checkmissing name c = 317 debug (fun() -> Util.msg "Checking nonexistence %s / %s\n" (!currentTest) name); 318 let actual = 319 Lwt_unix.run 320 ((match c with 321 R1 -> getfs r1 | R2 -> getfs r2 | BACKUP1 -> getbackup r1 | BACKUP2 -> getbackup r2) ()) in 322 if actual <> None then begin 323 Util.msg 324 "Test %s / %s: \nExpected %s MISSING\nbut found\n %s\n" 325 (!currentTest) name (checkable2string c) (fsopt2string actual); 326 failures := !failures+1; 327 raise (Util.Fatal (Printf.sprintf "Self-test %s / %s failed!" (!currentTest) name)) 328 end in 329 330 (* N.b.: When making up tests, it's important to choose file contents of different 331 lengths. The reason for this is that, on some Unix systems, it is possible for 332 the inode number of a just-deleted file to be reassigned to the very next file 333 created -- i.e., to the updated version of the file that the test script has 334 just written. If the length of the contents is also the same and the test is 335 running fast enough that the whole thing happens within a second, then the 336 update will be missed! *) 337 338 (* Test that update propagation transport works *) 339 let maxth = [| "0"; "1"; "5"; "6"; "7" |] in 340 (* Number of threads: default (0); 1 (corner case); 341 one less, equal to, and one more than number of updates *) 342 for i = 1 to Array.length maxth do 343 runtest ("propagation 1." ^ string_of_int i) ["maxthreads = " ^ maxth.(i - 1)] (fun () -> 344 put R1 (Dir []); put R2 (Dir []); sync (); 345 let r1 = ["a", File "a"; "b", File "b"; "d1", Dir ["a", File "a1"; "b", File "b1"]] 346 and r2 = ["x", File "x"; "y", File "y"; "d2", Dir ["x", File "x2"; "y", File "y2"]] in 347 let expect = Dir (r1 @ r2) in 348 put R1 (Dir r1); put R2 (Dir r2); sync (); 349 check "1" R1 expect; 350 check "2" R2 expect 351 ) 352 done; 353 354 (* Test that .git is treated atomically. *) 355 runtest "Atomicity of certain directories 1" ["atomic = Name .git"; 356 "force = newer"] (fun() -> 357 let orig = (Dir ["foo", Dir [".git", Dir ["a", File "foo"; 358 "b", File "bar"; 359 "c", File "baz"]]]) in 360 put R1 orig; 361 Unix.sleep 2; (* in case time granularity is coarse on this FS *) 362 put R2 orig; sync(); 363 let expected = (Dir ["foo", Dir [".git", Dir ["a", File "modified on R1"; 364 "b", File "bar"; 365 "c", File "modified on R1"]]]) in 366 put R2 (Dir ["foo", Dir [".git", 367 Dir ["a", File "foo"; 368 "b", File "modified on R2"; 369 "c", File "modified on R2"]]]); 370 Unix.sleep 2; 371 put R1 expected; 372 sync (); 373 check "1" R2 expected; 374 check "2" R1 expected 375 ); 376 377 runtest "Atomicity of certain directories 2" ["atomic = Name .git"] (fun() -> 378 let a = (Dir ["foo", Dir [".git", Dir ["a", File "foo"; 379 "b", File "bar"; 380 "c", File "baz"; 381 "d", File "quux"]]]) in 382 let b = (Dir ["foo", Dir [".git", Dir ["a", File "foo"; 383 "b", File "bar"; 384 "c", File "baz"; 385 "e", File "quux"]]]) in 386 put R1 a; put R2 b; sync(); 387 check "1" R1 a; 388 check "2" R2 b 389 ); 390 391 (* Check for the bug reported by Ralf Lehmann *) 392 if not bothRootsLocal then 393 runtest "backups 1 (remote)" ["backup = Name *"] (fun() -> 394 put R1 (Dir []); put R2 (Dir []); sync(); 395 debug (fun () -> Util.msg "First check\n"); 396 checkmissing "1" BACKUP1; 397 checkmissing "2" BACKUP2; 398 (* Create a file *) 399 put R1 (Dir ["test.txt", File "1"]); sync(); 400 checkmissing "3" BACKUP1; 401 checkmissing "4" BACKUP2; 402 (* Change it and check that the old version got backed up on the target host *) 403 put R1 (Dir ["test.txt", File "2"]); sync(); 404 checkmissing "5" BACKUP1; 405 check "6" BACKUP2 (Dir [("test.txt", File "1")]); 406 ); 407 408 if bothRootsLocal then 409 runtest "fastercheckUNSAFE 1" ["fastercheckUNSAFE = true"] (fun() -> 410 put R1 (Dir []); put R2 (Dir []); sync(); 411 (* Create a file on both sides with different contents *) 412 put R1 (Dir ["x", File "foo"]); 413 put R2 (Dir ["x", File "bar"]); sync(); 414 check "1a" R1 (Dir ["x", File "foo"]); 415 check "1b" R2 (Dir ["x", File "bar"]); 416 (* Change contents on one side and see that we do NOT get a conflict (!) *) 417 put R1 (Dir ["x", File "newcontents"]); sync(); 418 check "2a" R1 (Dir ["x", File "newcontents"]); 419 check "2b" R2 (Dir ["x", File "newcontents"]); 420 421 (* Start again *) 422 put R1 (Dir []); put R2 (Dir []); sync(); 423 (* Create a file on both sides with different contents *) 424 put R1 (Dir ["x", File "foo"]); 425 put R2 (Dir ["x", File "bar"]); sync(); 426 (* Change contents without changing size and check that change is propagated *) 427 put R1 (Dir ["x", File "f00"]); sync(); 428 429 check "3a" R1 (Dir ["x", File "f00"]); 430 check "3b" R2 (Dir ["x", File "f00"]); 431 432 (* Start again *) 433 put R1 (Dir []); put R2 (Dir []); sync(); 434 (* Create a new file on one side only *) 435 put R1 (Dir ["x", File "foo"]); sync(); 436 (* Check that change is propagated *) 437 check "4" R2 (Dir ["x", File "foo"]); 438 ); 439 440 if bothRootsLocal then 441 runtest "backups 1 (local)" ["backup = Name *"] (fun() -> 442 put R1 (Dir []); put R2 (Dir []); sync(); 443 (* Create a file and a directory *) 444 put R1 (Dir ["x", File "foo"; "d", Dir ["a", File "barr"]]); sync(); 445 (* Delete them *) 446 put R1 (Dir []); sync(); 447 check "1" BACKUP1 (Dir ["x", File "foo"; "d", Dir ["a", File "barr"]]); 448 (* Put them back and delete them once more *) 449 put R1 (Dir ["x", File "FOO"; "d", Dir ["a", File "BARR"]]); sync(); 450 put R1 (Dir []); sync(); 451 check "2" BACKUP1 (Dir [("x", File "FOO"); ("d", Dir [("a", File "BARR")]); 452 (".bak.1.x", File "foo"); (".bak.1.d", Dir [("a", File "barr")])]) 453 ); 454 455 runtest "backups 2" ["backup = Name *"; "backuplocation = local"] (fun() -> 456 put R1 (Dir []); put R2 (Dir []); sync(); 457 (* Create a file and a directory *) 458 put R1 (Dir ["x", File "foo"; "d", Dir ["a", File "barr"]]); sync(); 459 (* Delete them *) 460 put R1 (Dir []); sync(); 461 (* Check that they have been backed up correctly on the other side *) 462 check "1" R2 (Dir [(".bak.0.x", File "foo"); (".bak.0.d", Dir [("a", File "barr")])]); 463 ); 464 465 runtest "backups 2a" ["backup = Name *"; "backuplocation = local"] (fun() -> 466 put R1 (Dir []); put R2 (Dir []); sync(); 467 (* Create a file and a directory *) 468 put R1 (Dir ["foo", File "1"]); sync(); 469 check "1" R1 (Dir [("foo", File "1")]); 470 check "2" R2 (Dir [("foo", File "1")]); 471 put R1 (Dir ["foo", File "2"]); sync(); 472 check "3" R1 (Dir [("foo", File "2")]); 473 check "4" R2 (Dir [("foo", File "2"); (".bak.0.foo", File "1")]); 474 ); 475 476 runtest "backups 3" ["backup = Name *"; "backuplocation = local"; "backupcurrent = Name *"] (fun() -> 477 put R1 (Dir []); put R2 (Dir []); sync(); 478 put R1 (Dir ["x", File "foo"]); sync (); 479 check "1a" R1 (Dir [("x", File "foo"); (".bak.0.x", File "foo")]); 480 check "1b" R2 (Dir [("x", File "foo"); (".bak.0.x", File "foo")]); 481 put R2 (Dir ["x", File "barr"; (".bak.0.x", File "foo")]); sync (); 482 check "2a" R1 (Dir [("x", File "barr"); (".bak.1.x", File "foo"); (".bak.0.x", File "barr")]); 483 check "2b" R2 (Dir [("x", File "barr"); (".bak.1.x", File "foo"); (".bak.0.x", File "barr")]); 484 ); 485 486 runtest "backups 4" ["backup = Name *"; "backupcurrent = Name *"; "maxbackups = 7"] (fun() -> 487 put R1 (Dir []); put R2 (Dir []); sync(); 488 put R1 (Dir ["x", File "foo"]); sync(); 489 check "1a" BACKUP1 (Dir [("x", File "foo")]); 490 put R1 (Dir ["x", File "barr"]); sync(); 491 check "1b" BACKUP1 (Dir [("x", File "barr"); (".bak.1.x", File "foo")]); 492 put R2 (Dir ["x", File "bazzz"]); sync(); 493 check "1c" BACKUP1 (Dir [("x", File "bazzz"); (".bak.2.x", File "foo"); (".bak.1.x", File "barr")]); 494 ); 495 496 runtest "backups 5 (directories)" ["backup = Name *"; "backupcurrent = Name *"; "maxbackups = 7"] (fun() -> 497 put R1 (Dir []); put R2 (Dir []); sync(); 498 (* Create a directory x containing files a and l; check that the current version gets backed up *) 499 put R1 (Dir ["x", Dir ["a", File "foo"; "l", File "./foo"]]); sync(); 500 check "1" BACKUP1 (Dir [("x", Dir [("l", File "./foo"); ("a", File "foo")])]); 501 (* On replica 2, delete file a, create file b, and edit file l *) 502 put R2 (Dir ["x", Dir ["b", File "barr"; "l", File "./barr"]]); sync(); 503 check "2" BACKUP1 (Dir [("x", Dir [("l", File "./barr"); ("b", File "barr"); ("a", File "foo"); (".bak.1.l", File "./foo")])]); 504 (* On replica 1, replace the whole directory by a file; when we check the result, we need to know 505 whether we're running the test locally or remotely; in the former case, we should see *both* the 506 old and the new version as backups *) 507 put R1 (Dir ["x", File "bazzz"]); sync(); 508 if bothRootsLocal then 509 check "3" BACKUP1 (Dir [("x", File "bazzz"); (".bak.2.x", Dir [("l", File "./barr"); ("b", File "barr"); ("a", File "foo"); (".bak.1.l", File "./foo")]); (".bak.1.x", Dir [("l", File "./barr"); ("b", File "barr")])]) 510 else 511 check "3" BACKUP1 (Dir [("x", File "bazzz"); (".bak.1.x", Dir [("l", File "./barr"); ("b", File "barr"); ("a", File "foo"); (".bak.1.l", File "./foo")])]); 512 ); 513 514 runtest "backups 6 (backup prefix/suffix)" ["backup = Name *"; 515 "backuplocation = local"; 516 "backupprefix = back/$VERSION-"; 517 "backupsuffix = .backup"; 518 "backupcurrent = Name *"] (fun() -> 519 put R1 (Dir []); put R2 (Dir []); sync(); 520 put R1 (Dir ["x", File "foo"]); sync(); 521 check "1" R1 (Dir [("x", File "foo"); ("back", Dir [("0-x.backup", File "foo")])]); 522 ); 523 524 if not (Prefs.read Globals.someHostIsRunningWindows) then begin 525 runtest "links 1 (directories and links)" ["backup = Name *"; "backupcurrent = Name *"; "maxbackups = 7"] (fun() -> 526 put R1 (Dir []); put R2 (Dir []); sync(); 527 put R1 (Dir ["x", Dir ["a", File "foo"; "l", Link "./foo"]]); sync(); 528 check "1" BACKUP1 (Dir [("x", Dir [("l", Link "./foo"); ("a", File "foo")])]); 529 put R2 (Dir ["x", Dir ["b", File "barr"; "l", Link "./barr"]]); sync(); 530 check "2" BACKUP1 (Dir [("x", Dir [("l", Link "./barr"); ("b", File "barr"); ("a", File "foo"); (".bak.1.l", Link "./foo")])]); 531 put R1 (Dir ["x", File "bazzz"]); sync(); 532 if bothRootsLocal then 533 check "3" BACKUP1 534 (Dir [("x", File "bazzz"); 535 (".bak.2.x", Dir [("l", Link "./barr"); ("b", File "barr"); ("a", File "foo"); 536 (".bak.1.l", Link "./foo")]); 537 (".bak.1.x", Dir [("l", Link "./barr"); ("b", File "barr")])]) 538 else 539 check "3" BACKUP1 540 (Dir [("x", File "bazzz"); 541 (".bak.1.x", Dir [("l", Link "./barr"); ("b", File "barr"); 542 ("a", File "foo"); (".bak.1.l", Link "./foo")])]); 543 ); 544 545 (* Test that we correctly fail when we try to 'follow' a symlink that does not 546 point to anything *) 547 runtest "links 2 (symlink to nowhere)" ["follow = Name y"] (fun() -> 548 let orig = (Dir []) in 549 put R1 orig; put R2 orig; sync(); 550 put R1 (Dir ["y", Link "x"]); sync(); 551 check "1" R2 orig; 552 ); 553 554 (* Check for the bug reported by Sebastian Elsner (Jan 2018) *) 555 (* NOT POSSIBLE because the test API does not enable one to play with file 556 owners, but I put the test here anyway. *) 557 (* 558 runtest "owner of path directories" ["owner"; "path = a/b"] (fun() -> 559 put R1 (Dir ["a", Dir ["b", Dir["foo", File "Foo"; 560 "bar", File "Bar"; 561 "baz", File "Baz";]]]]); 562 setOwner R1 "a/b" "testuser"; (* does not exist *) 563 put R2 (Dir []); 564 sync(); 565 checkOwner "1" R2 "a/b" "testuser"; (* does not exist *) 566 ); 567 *) 568 end; 569 570 if not bothRootsLocal then 571 begin 572 let localR, remoteR, localRaw = 573 match r1 with 574 | Common.Local, _ -> R1, R2, r1 575 | _ -> R2, R1, r2 576 in 577 578 (* Test RPC function "fingerprintSubfile" *) 579 runtest "RPC: transfer append" [] (fun () -> 580 let prefixLen = 1024 * 1024 + 1 in 581 let len = prefixLen + 31 in 582 let contents = String.make len '.' in 583 let fileName = "bigfile" in 584 let prefixPath = Path.fromString fileName in 585 let (workingDir, _) = Fspath.findWorkingDir (snd localRaw) prefixPath in 586 let prefixName = Path.toString (Os.tempPath ~fresh:false workingDir prefixPath) in 587 put remoteR (Dir [(fileName, File contents)]); 588 put localR (Dir [(prefixName, File (String.sub contents 0 prefixLen))]); 589 sync (); 590 check "1" localR (Dir [(fileName, File contents)]); 591 ); 592 593 (* Test RPC function "updateProps" *) 594 runtest "RPC: update props" ["times = true"] (fun () -> 595 let state = [("a", File "x")] in 596 put remoteR (Dir state); 597 put localR (Dir []); 598 sync (); 599 (* Having to sleep here is an unfortunate side-effect of the current 600 Windows limitations-inspired time comparison algorithm which is 601 designed to work on FAT filesystems (2-second granularity). *) 602 Unix.sleep 2; 603 put remoteR (Dir state); 604 sync (); 605 check "1" localR (Dir state); 606 ); 607 608 (* Test RPC function "replaceArchive" *) 609 runtest "RPC: replaceArchive" [] (fun () -> 610 put localR (Dir [("n", File "to delete")]); 611 put remoteR (Dir []); 612 sync (); 613 put remoteR (Dir []); 614 sync (); 615 check "1" localR (Dir []); 616 ); 617 618 (* Test RPC functions "mkdir" and "setDirProp" *) 619 runtest "RPC: mkdir, setDirProp" [] (fun () -> 620 let state = [("subd", Dir [])] in 621 put localR (Dir state); 622 put remoteR (Dir []); 623 sync (); 624 check "1" remoteR (Dir state); 625 ); 626 627 (* Test RPC function "setupTargetPaths" *) 628 runtest "RPC: merge" ["merge = Name ma -> echo x> NEW"; "backupcurr = Name ma"] (fun () -> 629 let result = match Sys.os_type with 630 | "Win32" -> ("ma", File "x\r\n") 631 | _ -> ("ma", File "x\n") 632 in 633 put localR (Dir [("ma", File "a")]); 634 put remoteR (Dir [("ma", File "b")]); 635 sync (); 636 check "1" localR (Dir [result]); 637 check "2" remoteR (Dir [result]); 638 ); 639 end; 640 641 if !failures = 0 then 642 Util.msg "Success :-)\n" 643 else 644 raise (Util.Fatal "Self-tests failed\n") 645 646 (* Initialization: tie the knot between this module and Uicommon *) 647 let _ = (Uicommon.testFunction := test)