uicommon.ml (45860B)
1 (* Unison file synchronizer: src/uicommon.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 open Common 19 open Lwt 20 21 (********************************************************************** 22 UI selection 23 **********************************************************************) 24 25 type interface = 26 Text 27 | Graphic 28 29 let minterface = 30 Umarshal.(sum2 unit unit 31 (function 32 | Text -> I21 () 33 | Graphic -> I22 ()) 34 (function 35 | I21 () -> Text 36 | I22 () -> Graphic)) 37 38 module type UI = 39 sig 40 val start : interface -> unit 41 val defaultUi : interface 42 end 43 44 45 (********************************************************************** 46 Preferences 47 **********************************************************************) 48 49 let auto = 50 Prefs.createBool "auto" false 51 ~category:(`Basic `Syncprocess_CLI) 52 "automatically accept default (nonconflicting) actions" 53 ("When set to {\\tt true}, this flag causes the user " 54 ^ "interface to skip asking for confirmations on " 55 ^ "non-conflicting changes. (More precisely, when the user interface " 56 ^ "is done setting the propagation direction for one entry and is about " 57 ^ "to move to the next, it will skip over all non-conflicting entries " 58 ^ "and go directly to the next conflict.)" ) 59 60 (* This has to be here rather than in uigtk.ml, because it is part of what 61 gets sent to the server at startup *) 62 let mainWindowHeight = 63 Prefs.createInt "height" 15 64 ~category:(`Advanced `GUI) 65 "height (in lines) of main window in graphical interface" 66 ("Used to set the height (in lines) of the main window in the graphical " 67 ^ "user interface.") 68 69 let expert = 70 Prefs.createBool "expert" false 71 ~category:(`Internal `Devel) 72 "*Enable some developers-only functionality in the UI" "" 73 74 let profileLabel = 75 Prefs.createString "label" "" 76 ~category:(`Advanced `General) 77 "provide a descriptive string label for this profile" 78 ("Used in a profile to provide a descriptive string documenting its " 79 ^ "settings. (This is useful for users that switch between several " 80 ^ "profiles, especially using the `fast switch' feature of the " 81 ^ "graphical user interface.)") 82 83 let profileKey = 84 Prefs.createString "key" "" 85 ~category:(`Advanced `General) 86 "define a keyboard shortcut for this profile (in some UIs)" 87 ("Used in a profile to define a numeric key (0-9) that can be used in " 88 ^ "the user interface to switch immediately to this profile.") 89 (* This preference is not actually referred to in the code anywhere, since 90 the keyboard shortcuts are constructed by a separate scan of the preference 91 file in uigtk.ml, but it must be present to prevent the preferences module 92 from complaining about 'key = n' lines in profiles. *) 93 94 let contactquietly = 95 Prefs.createBool "contactquietly" false 96 ~category:(`Advanced `General) 97 "suppress the 'contacting server' message during startup" 98 ("If this flag is set, Unison will skip displaying the " 99 ^ "`Contacting server' message (which some users find annoying) " 100 ^ "during startup.") 101 102 let contactingServerMsg () = 103 Printf.sprintf "Unison %s: Contacting server..." Uutil.myVersion 104 105 let repeat = 106 let parseRepeat s = 107 let parseTime ts = 108 try int_of_string ts with Failure _ -> 109 raise (Prefs.IllegalValue ("Value of 'repeat' preference (" 110 ^ s ^ ") should be either a number, 'watch' or 'watch+<number>'")) 111 in 112 let nonBlankLower x = 113 match String.trim x with "" -> None | s -> Some (String.lowercase_ascii s) 114 in 115 try 116 match Safelist.filterMap nonBlankLower (String.split_on_char '+' s) with 117 | [] -> `NoRepeat 118 | ["watch"] -> `Watch 119 | ["watch"; i] | [i; "watch"] -> `WatchAndInterval (parseTime i) 120 | _ -> `Interval (parseTime s) 121 with 122 | Prefs.IllegalValue _ as e -> `Invalid (s, e) 123 in 124 let externRepeat = function 125 | `NoRepeat | `Invalid _ -> "" 126 | `Watch -> "watch" 127 | `WatchAndInterval i -> "watch+" ^ (string_of_int i) 128 | `Interval i -> string_of_int i 129 in 130 Prefs.create "repeat" `NoRepeat 131 ~category:(`Advanced `Syncprocess_CLI) 132 "synchronize repeatedly (text interface only)" 133 ("Setting this preference causes the text-mode interface to synchronize " 134 ^ "repeatedly, rather than doing it just once and stopping. If the " 135 ^ "argument is a number, Unison will pause for that many seconds before " 136 ^ "beginning again. When the argument is \\verb|watch|, Unison relies on " 137 ^ "an external file monitoring process to synchronize whenever a change " 138 ^ "happens. You can combine the two with a \\verb|+| character to use " 139 ^ "file monitoring and also do a full scan every specified number of " 140 ^ "seconds. For example, \\verb|watch+3600| will react to changes " 141 ^ "immediately and additionally do a full scan every hour.") 142 (fun _ -> parseRepeat) 143 (fun r -> [externRepeat r]) 144 Umarshal.(sum1 string externRepeat parseRepeat) 145 let repeatWatcher () = 146 match Prefs.read repeat with `Watch | `WatchAndInterval _ -> true | _ -> false 147 148 let retry = 149 Prefs.createInt "retry" 0 150 ~category:(`Advanced `Syncprocess_CLI) 151 "re-try failed synchronizations N times (text ui only)" 152 ("Setting this preference causes the text-mode interface to try again " 153 ^ "to synchronize " 154 ^ "updated paths where synchronization fails. Each such path will be " 155 ^ "tried N times." 156 ) 157 158 let confirmmerge = 159 Prefs.createBool "confirmmerge" false 160 ~category:(`Advanced `Syncprocess) 161 "ask for confirmation before committing results of a merge" 162 ("Setting this preference causes both the text and graphical interfaces" 163 ^ " to ask the user if the results of a merge command may be committed " 164 ^ " to the replica or not. Since the merge command works on temporary files," 165 ^ " the user can then cancel all the effects of applying the merge if it" 166 ^ " turns out that the result is not satisfactory. In " 167 ^ " batch-mode, this preference has no effect. Default is false.") 168 169 let runTestsPrefName = "selftest" 170 let runtests = 171 Prefs.createBool runTestsPrefName false 172 ~category:`Expert 173 ~cli_only:true 174 "run internal tests and exit" 175 ("Run internal tests and exit. This option is mostly for developers and must be used " 176 ^ "carefully: in particular, " 177 ^ "it will delete the contents of both roots, so that it can install its own files " 178 ^ "for testing. This flag only makes sense on the command line. When it is " 179 ^ "provided, no preference file is read: all preferences must be specified on the" 180 ^ "command line. Also, since the self-test procedure involves overwriting the roots " 181 ^ "and backup directory, the names of the roots and of the backupdir preference " 182 ^ "must include the string " 183 ^ "\"test\" or else the tests will be aborted. (If these are not given " 184 ^ "on the command line, dummy " 185 ^ "subdirectories in the current directory will be created automatically.)") 186 187 (* This ref is set to Test.test during initialization, avoiding a circular 188 dependency *) 189 let testFunction = ref (fun () -> assert false) 190 191 (********************************************************************** 192 Formatting functions 193 **********************************************************************) 194 195 (* When no archives were found, we omit 'new' in status descriptions, since 196 *all* files would be marked new and this won't make sense to the user. *) 197 let choose s1 s2 = if !Update.foundArchives then s1 else s2 198 199 let showprev = 200 Prefs.createBool "showprev" false 201 ~category:(`Internal `Devel) 202 "*Show previous properties, if they differ from current" 203 "" 204 205 (* The next function produces nothing unless the "showprev" 206 preference is set. This is because it tends to make the 207 output trace too long and annoying. *) 208 let prevProps newprops ui = 209 if not (Prefs.read showprev) then "" 210 else match ui with 211 NoUpdates | Error _ 212 -> "" 213 | Updates (_, New) -> 214 " (new)" 215 | Updates (_, Previous(_,oldprops,_,_)) -> 216 (* || Props.similar newprops oldprops *) 217 " (was: "^(Props.toString oldprops)^")" 218 219 let replicaContentDesc rc = 220 Props.toString (Props.setLength rc.desc (snd rc.size)) 221 222 let replicaContent2string rc sep = 223 let d s = s ^ sep ^ replicaContentDesc rc ^ prevProps rc.desc rc.ui in 224 match rc.typ, rc.status with 225 `ABSENT, `Unchanged -> 226 "absent" 227 | _, `Unchanged -> 228 "unchanged " 229 ^(Util.padto 7 (Util.truncateString (Fileinfo.type2string rc.typ) 7)) 230 ^ sep 231 ^ replicaContentDesc rc 232 | `ABSENT, `Deleted -> "deleted" 233 | `FILE, `Created -> 234 d (choose "new file " "file ") 235 | `FILE, `Modified -> 236 d "changed file " 237 | `FILE, `PropsChanged -> 238 d "changed props " 239 | `SYMLINK, `Created -> 240 d (choose "new symlink " "symlink ") 241 | `SYMLINK, `Modified -> 242 d "changed symlink " 243 | `DIRECTORY, `Created -> 244 d (choose "new dir " "dir ") 245 | `DIRECTORY, `Modified -> 246 d "changed dir " 247 | `DIRECTORY, `PropsChanged -> 248 d "dir props changed" 249 250 (* Some cases that can't happen... *) 251 | `ABSENT, (`Created | `Modified | `PropsChanged) 252 | `SYMLINK, `PropsChanged 253 | (`FILE|`SYMLINK|`DIRECTORY), `Deleted -> 254 assert false 255 256 let replicaContent2shortString rc = 257 match rc.typ, rc.status with 258 _, `Unchanged -> " " 259 | `ABSENT, `Deleted -> "deleted " 260 | `FILE, `Created -> choose "new file" "file " 261 | `FILE, `Modified -> "changed " 262 | `FILE, `PropsChanged -> "props " 263 | `SYMLINK, `Created -> choose "new link" "link " 264 | `SYMLINK, `Modified -> "chgd lnk" 265 | `DIRECTORY, `Created -> choose "new dir " "dir " 266 | `DIRECTORY, `Modified -> "chgd dir" 267 | `DIRECTORY, `PropsChanged -> "props " 268 (* Cases that can't happen... *) 269 | `ABSENT, (`Created | `Modified | `PropsChanged) 270 | `SYMLINK, `PropsChanged 271 | (`FILE|`SYMLINK|`DIRECTORY), `Deleted 272 -> assert false 273 274 let roots2niceStrings length = function 275 (Local,fspath1), (Local,fspath2) -> 276 let name1, name2 = Fspath.differentSuffix fspath1 fspath2 in 277 (Util.truncateString name1 length, Util.truncateString name2 length) 278 | (Local,fspath1), (Remote host, fspath2) -> 279 (Util.truncateString "local" length, Util.truncateString host length) 280 | (Remote host, fspath1), (Local,fspath2) -> 281 (Util.truncateString host length, Util.truncateString "local" length) 282 | _ -> assert false (* BOGUS? *) 283 284 let details2string theRi sep = 285 match theRi.replicas with 286 Problem s -> 287 Printf.sprintf "Error: %s\n" s 288 | Different {rc1 = rc1; rc2 = rc2} -> 289 let root1str, root2str = 290 roots2niceStrings 12 (Globals.roots()) in 291 Printf.sprintf "%-12s : %s\n%-12s : %s" 292 root1str (replicaContent2string rc1 sep) 293 root2str (replicaContent2string rc2 sep) 294 295 let displayPath previousPath path = 296 let previousNames = Path.toNames previousPath in 297 let names = Path.toNames path in 298 if names = [] then "/" else 299 (* Strip the greatest common prefix of previousNames and names 300 from names. level is the number of names in the greatest 301 common prefix. *) 302 let rec loop level names1 names2 = 303 match (names1,names2) with 304 (hd1::tl1,hd2::tl2) -> 305 if Name.compare hd1 hd2 = 0 306 then loop (level+1) tl1 tl2 307 else (level,names2) 308 | _ -> (level,names2) in 309 let (level,suffixNames) = loop 0 previousNames names in 310 let suffixPath = 311 Safelist.fold_left Path.child Path.empty suffixNames in 312 let spaces = String.make (level*3) ' ' in 313 spaces ^ (Path.toString suffixPath) 314 315 let roots2string () = 316 let replica1, replica2 = roots2niceStrings 12 (Globals.roots()) in 317 (Printf.sprintf "%-12s %-12s " replica1 replica2) 318 319 type action = AError | ASkip of bool | ALtoR of bool | ARtoL of bool | AMerge 320 321 let direction2action partial dir = 322 match dir with 323 Conflict _ -> ASkip partial 324 | Replica1ToReplica2 -> ALtoR partial 325 | Replica2ToReplica1 -> ARtoL partial 326 | Merge -> AMerge 327 328 let action2niceString action = 329 match action with 330 AError -> "error" 331 | ASkip _ -> "<-?->" 332 | ALtoR false -> "---->" 333 | ALtoR true -> "--?->" 334 | ARtoL false -> "<----" 335 | ARtoL true -> "<-?--" 336 | AMerge -> "<-M->" 337 338 let reconItem2stringList oldPath theRI = 339 match theRI.replicas with 340 Problem s -> 341 (" ", AError, " ", displayPath oldPath theRI.path1) 342 | Different diff -> 343 let partial = diff.errors1 <> [] || diff.errors2 <> [] in 344 (replicaContent2shortString diff.rc1, 345 direction2action partial diff.direction, 346 replicaContent2shortString diff.rc2, 347 Path.toString theRI.path1) 348 349 let reconItem2string oldPath theRI status = 350 let (r1, action, r2, path) = reconItem2stringList oldPath theRI in 351 Format.sprintf "%s %s %s %s %s" r1 (action2niceString action) r2 status path 352 353 let exn2string e = 354 match e with 355 Sys.Break -> "Terminated!" 356 | Util.Fatal s -> s 357 | Util.Transient s -> s 358 | Unix.Unix_error (err, fun_name, arg) -> 359 Printf.sprintf "Uncaught unix error (please report a bug): %s failed%s: %s%s\n%s" 360 fun_name 361 (if String.length arg > 0 then Format.sprintf " on \"%s\"" arg else "") 362 (Unix.error_message err) 363 (match err with 364 Unix.EUNKNOWNERR n -> Format.sprintf " (code %d)" n 365 | _ -> "") 366 (Printexc.get_backtrace ()) 367 | Stack_overflow -> 368 "Stack overflow. This could indicate a programming error.\n\n\ 369 Technical information in case you need to report a bug:\n" 370 ^ (Printexc.get_backtrace ()) 371 | Invalid_argument s -> 372 Printf.sprintf "Invalid argument (please report a bug): %s\n%s" 373 s (Printexc.get_backtrace ()) 374 | other -> Printf.sprintf "Uncaught exception (please report a bug): %s\n%s" 375 (Printexc.to_string other) (Printexc.get_backtrace ()) 376 377 (* precondition: uc = File (Updates(_, ..) on both sides *) 378 let showDiffs ri printer errprinter id = 379 match ri.replicas with 380 Problem _ -> 381 errprinter 382 "Can't diff files: there was a problem during update detection" 383 | Different {rc1 = {typ = `FILE; ui = ui1}; rc2 = {typ = `FILE; ui = ui2}} -> 384 let (root1,root2) = Globals.roots() in 385 begin 386 try Files.diff root1 ri.path1 ui1 root2 ri.path2 ui2 printer id 387 with Util.Transient e -> errprinter e 388 end 389 | Different _ -> 390 errprinter "Can't diff: path doesn't refer to a file in both replicas" 391 392 393 exception Synch_props of Common.reconItem 394 395 (********************************************************************** 396 Common error messages 397 **********************************************************************) 398 399 let dangerousPathMsg dangerousPaths = 400 if dangerousPaths = [Path.empty] then 401 "The root of one of the replicas has been completely emptied.\n\ 402 Unison may delete everything in the other replica. (Set the \n\ 403 'confirmbigdel' preference to false to disable this check.)\n" 404 else 405 Printf.sprintf 406 "The following paths have been completely emptied in one replica:\n \ 407 %s\n\ 408 Unison may delete everything below these paths in the other replica.\n 409 (Set the 'confirmbigdel' preference to false to disable this check.)\n" 410 (String.concat "\n " 411 (Safelist.map (fun p -> "'" ^ (Path.toString p) ^ "'") 412 dangerousPaths)) 413 414 (********************************************************************** 415 Useful patterns for ignoring paths 416 **********************************************************************) 417 418 let globx_quote s = 419 let len = String.length s in 420 let buf = Bytes.create (2 * len) in 421 let pos = ref 0 in 422 for i = 0 to len - 1 do 423 match s.[i] with 424 '*' | '?' | '[' | '{' | '}' | ',' | '\\' as c -> 425 Bytes.set buf !pos '\\'; Bytes.set buf (!pos + 1) c; pos := !pos + 2 426 | c -> 427 Bytes.set buf !pos c; pos := !pos + 1 428 done; 429 "{" ^ Bytes.sub_string buf 0 !pos ^ "}" 430 let quote = 431 let escape_mapSeparator s = 432 let sep = Util.trimWhitespace Pred.mapSeparator in 433 assert ((String.length sep >= 2) && 434 (sep.[0]='-'||sep.[0]='='||sep.[0]='>'||sep.[0]='<'||sep.[0]='_')); 435 let esc = "[" ^ (String.make 1 sep.[0]) ^ "]" ^ 436 (String.sub sep 1 ((String.length sep)-1)) in 437 let rec loop s = 438 let e = String.concat esc (Util.splitIntoWordsByString s sep) in 439 if e = s then e else loop e in 440 loop s in 441 fun s -> escape_mapSeparator (globx_quote s) 442 443 let ignorePath path = "Path " ^ quote (Path.toString path) 444 445 let ignoreName path = 446 match Path.finalName path with 447 Some name -> "Name " ^ quote (Name.toString name) 448 | None -> assert false 449 450 let ignoreExt path = 451 match Path.finalName path with 452 Some name -> 453 let str = Name.toString name in 454 begin try 455 let pos = String.rindex str '.' in 456 let ext = String.sub str pos (String.length str - pos) in 457 "Name {,.}*" ^ quote ext 458 with Not_found -> (* str does not contain '.' *) 459 "Name " ^ quote str 460 end 461 | None -> 462 assert false 463 464 let addIgnorePattern theRegExp = 465 if theRegExp = "Path " then 466 raise (Util.Transient "Can't ignore the root path!"); 467 Globals.addRegexpToIgnore theRegExp; 468 let r = Prefs.add "ignore" theRegExp in 469 Trace.status r; 470 (* Make sure the server has the same ignored paths (in case, for 471 example, we do a "rescan") *) 472 Lwt_unix.run (Globals.propagatePrefs ()) 473 474 (********************************************************************** 475 Statistics for update progress 476 **********************************************************************) 477 478 (* This seemingly very complex code for calculating the progress rate 479 and ETA has partly to do with Unison currently not tracking progress 480 very accurately. Several potentially very time-consuming operations 481 are not tracked at all: hashing files before and after the copy, for 482 example. The entire amount of work may not even be known in advance 483 when continuing partial transfers after the previous sync has been 484 interrupted. This makes it very difficult to provide meaningful rate 485 and ETA information. The code below is the current best approximation. 486 The way to simplify this code here is to first and foremost improve 487 progress tracking and reporting. *) 488 489 module Stats = struct 490 491 let calcETA rem rate = 492 if Float.is_nan rate || Float.is_nan rem || rem < 0. then "" else 493 let t = truncate (rem /. rate +. 0.5) in 494 (* Estimating the remaining time is not accurate. Reduce the display 495 precision (and reduce more when longer time remaining). *) 496 if t >= 86220 then 497 let u = t + 180 in 498 Printf.sprintf "%dd %02d:%02d:00" (u / 86400) ((u mod 86400) / 3600) 499 (((u mod 3600) / 300) * 5) 500 else 501 let h, (m, sec) = 502 if t >= 3420 then 503 let u = t + 180 in u / 3600, (((u mod 3600) / 300) * 5, 0) 504 else 505 0, 506 if t >= 2640 then ((t + 180) / 300) * 5, 0 507 else if t >= 1800 then ((t + 119) / 120) * 2, 0 508 else if t >= 120 then let u = t + 15 in u / 60, ((u mod 60) / 30) * 30 509 else t / 60, t mod 60 510 in 511 Printf.sprintf "%02d:%02d:%02d" h m sec 512 513 let movAvg curr prev ?(c = 1.) deltaTime avgPeriod = 514 if Float.is_nan prev then curr else 515 let a = c *. Float.min (1. -. exp (-. deltaTime /. avgPeriod)) 1. in 516 (* Simplified from a *. curr +. (1. -. a) *. prev *) 517 prev +. a *. (curr -. prev) 518 519 type t = (* abstract in mli *) 520 { mutable t0 : float; 521 mutable t : float; 522 totalToComplete : int64; 523 mutable completed : int64; 524 mutable curRate : float; 525 mutable avgRateS : float; 526 mutable avgRateDoubleSGauss : float; 527 } 528 529 let gaussC = 2. *. (0.025 ** 2.) 530 let avgPeriodS = 4.0 531 let avgPeriodD = 3.5 532 let calcPeriod = 0.25 533 534 let init totalToTransfer = 535 let t0 = 0. in 536 { t0; t = t0; totalToComplete = Uutil.Filesize.toInt64 totalToTransfer; 537 completed = 0L; 538 curRate = Float.nan; avgRateS = Float.nan; avgRateDoubleSGauss = Float.nan; 539 } 540 541 let calcAvgRate' sta totTime deltaCompleted deltaTime = 542 let curRate = (Int64.to_float deltaCompleted) /. deltaTime in 543 (* We want to ignore small fluctuations but react faster to large 544 changes (like switching from cache to disk or from disk to network 545 of from receiving to sending or with wildly variable network speed). *) 546 let avgRateS = movAvg curRate sta.avgRateS deltaTime 547 (Float.min_num totTime avgPeriodS) in 548 let cpr = (avgRateS -. sta.avgRateDoubleSGauss) /. sta.avgRateDoubleSGauss in 549 let c = 1. -. exp (-.(cpr ** 2.) /. gaussC) in 550 let avgRateDoubleSGauss = movAvg avgRateS sta.avgRateDoubleSGauss ~c deltaTime 551 (Float.min_num totTime avgPeriodD) in 552 sta.curRate <- curRate; 553 sta.avgRateS <- avgRateS; 554 sta.avgRateDoubleSGauss <- avgRateDoubleSGauss 555 556 let update sta t1 totalCompleted = 557 let deltaTime = t1 -. sta.t in 558 let totalCompleted = Uutil.Filesize.toInt64 totalCompleted in 559 if sta.completed = 0L then begin 560 (* Skip the very first rate calculation because it will be skewed 561 due to (possibly significant) time losses during transport start. *) 562 sta.completed <- totalCompleted; 563 sta.t0 <- t1; 564 sta.t <- t1 565 end else if deltaTime >= calcPeriod then begin 566 let deltaCompleted = Int64.sub totalCompleted sta.completed in 567 sta.completed <- totalCompleted; 568 sta.t <- t1; 569 calcAvgRate' sta (t1 -. sta.t0) deltaCompleted deltaTime 570 end 571 572 let curRate sta = sta.curRate 573 let avgRate1 sta = sta.avgRateS 574 let avgRate2 sta = sta.avgRateDoubleSGauss 575 let eta sta ?(rate = sta.avgRateDoubleSGauss) default = 576 let rem = Int64.(to_float (sub sta.totalToComplete sta.completed)) in 577 let eta = calcETA rem rate in 578 if eta = "" then default else eta 579 580 end 581 582 (********************************************************************** 583 Update propagation 584 **********************************************************************) 585 586 (* (For context: the threads in question are all cooperating Lwt threads. 587 These are not OS threads or parallel running domains. There is no 588 preemption and only a single thread is executing at any time.) 589 590 Many (thousands) transport threads can run concurrently and 591 independently of each other. All threads run to completion as long as 592 there are no errors or only [Util.Transient] exceptions are raised. 593 594 The threads are _not_ guaranteed to run to completion when an exception 595 other than [Util.Transient] is raised in any of the threads. This means 596 that the threads may not even be able to complete their own cleanup 597 code and may leak resources. There must be separate resource cleanup code 598 that can be run after the threads have been stopped either forcefully or 599 by running to completion. 600 601 When an uncaught exception other than [Util.Transient] is raised in any 602 of the threads, the following happens: 603 604 - the thread raising the exception is aborted (all exception handlers 605 are run normally, so this thread is expected to run all its cleanup 606 code); 607 608 - any threads still waiting to be started are immediately cancelled 609 (they will not have run any meaningful code and don't require any 610 cleanup); 611 612 - any threads that have already run to completion are not impacted 613 in any way; 614 615 - any (sleeping) threads running concurrently with the raising thread 616 are stopped, which may have a different meaning depending on where 617 in the execution each thread was when it was stopped: 618 619 - some threads will not be able to continue at all (they are 620 never woken up); 621 - some threads may be woken up and may be able to continue 622 running for a short while but may get an error the next time 623 when accessing some resource (and may be able to run the error 624 handler); 625 - some threads may receive an exception and be able to continue 626 running for a short while. 627 628 - any exceptions raised in/by threads that are stopped, are ignored; 629 630 - the original exception from the first raising thread is reraised. 631 632 The code run in these thread must _not_ assume that: 633 - it will be run to completion; 634 - it can run some or all of its cleanup handlers; 635 - it will have had a chance to run a certain amount of its code; 636 - it will even know that it was stopped. 637 Depending on where and how a thread was stopped, it may be collected by 638 GC without any additional code ever being run in that thread. 639 640 641 There is a limit regulating how many threads can be run concurrently in 642 the [Transport] module. An attempt is made to not start threads that will 643 not be able to run due to this limit. This delayed starting is done for 644 two reasons. First, to make the cleanup in case of an uncaught exception 645 easier: if the thread was never run then there is nothing to clean up. 646 Second, even though the threads themselves are extremely lightweight, 647 they still consume some resources and this will add up when the number 648 of threads grows to hundreds of thousands and millions. 649 650 Not starting up all threads at once and allowing finished threads to 651 be collected by GC as soon as possible can potentially reduce the memory 652 requirement by gigabytes. (This is a reference to the old implementation 653 that started all threads in one go and kept them all around until all 654 were completed. This approach could result in running out of memory when 655 syncing large number of updates.) *) 656 657 let transportStart () = Transport.logStart () 658 659 let transportFinish () = Transport.logFinish () 660 661 let transportItems items pRiThisRound makeAction = 662 if Abort.isAll () then () else 663 let waiter = Lwt.wait () in 664 let outstanding = ref 0 in 665 let starting () = incr outstanding in 666 let completed () = 667 decr outstanding; 668 if !outstanding = 0 || (!outstanding = 1 && Abort.isAll ()) then begin 669 (* If there is a stop request then we might not get the [completed] 670 notice for the dispense loop itself, so we also stop at count 1. *) 671 try Lwt.wakeup waiter () with Invalid_argument _ -> () 672 end 673 in 674 let failed e = 675 try Lwt.wakeup_exn waiter e with Invalid_argument _ -> () 676 in 677 let waitAllCompleted () = 678 if !outstanding = 0 then Lwt.return () else waiter 679 in 680 681 let im = Array.length items in 682 let idx = ref 0 in 683 let stopDispense () = idx := im in 684 let makeAction' i item = 685 Lwt.try_bind 686 (fun () -> starting (); makeAction i item) 687 (fun () -> completed (); Lwt.return ()) 688 (fun ex -> stopDispense (); failed ex; Lwt.return ()) 689 in 690 let dispenseDone = 691 let c = ref 0 in (* Make sure [completed] is never called more than once *) 692 fun () -> 693 if (incr c; !c = 1) then completed (); 694 None 695 in 696 let rec dispenseAction () = 697 let i = !idx in 698 if Abort.isAll () then begin 699 stopDispense (); 700 dispenseDone () 701 end else if i < im then begin 702 let item = items.(i) in 703 incr idx; 704 if pRiThisRound item then 705 Some (fun () -> makeAction' i item) 706 else 707 dispenseAction () 708 end else 709 dispenseDone () 710 in 711 712 let doTransportFailCleanup () = 713 (* Don't start any new threads. *) 714 begin try stopDispense () with _ -> () end; 715 (* Stop all transfers. *) 716 begin try Abort.all () with _ -> () end; 717 (* Since we don't know what state the RPC protocol is in, we need 718 to close the remote connection to prevent hangs on select(2) 719 the next time [Lwt_unix.run] is called. 720 721 This will immediately trigger [on_close] handlers (which will 722 do some resource cleanup). *) 723 begin try 724 match Globals.rootsInCanonicalOrder () with 725 | [_; otherRoot] -> Remote.clientCloseRootConnection otherRoot 726 | _ -> assert false 727 with _ -> () end; 728 (* Threads that were still in the middle of execution are just 729 discarded and eventually collected by GC. Resources are cleaned 730 up and reclaimed by [Remote.at_conn_close] handlers. 731 732 Not all threads are stuck or purged and will continue the next 733 time [Lwt_unix.run] is called. Try to finish these threads now. 734 This must be done in a loop since each failing thread may raise 735 an uncaught exception which will end [Lwt_unix.run]. We don't 736 know how many threads can finish this way, so we don't know when 737 to stop looping. The limit of concurrent threads is used as an 738 approximation (which is probably much more than needed). *) 739 let rec loop_yield n () = 740 if n = 0 then Lwt.return () else Lwt_unix.yield () >>= loop_yield (n - 1) 741 in 742 for _ = 1 to Transport.maxThreads () do 743 try 744 Lwt_unix.run (loop_yield 10 ()) 745 with _ -> () 746 done 747 in 748 749 starting (); (* Count the dispense loop as one of the tasks to complete *) 750 try 751 Transport.run dispenseAction; 752 Lwt_unix.run (waitAllCompleted ()) 753 with e -> begin 754 (* Cleanup procedure must never raise exceptions. Just in case, 755 don't shadow the original exception. *) 756 let origbt = Printexc.get_raw_backtrace () in 757 let () = doTransportFailCleanup () in 758 Printexc.raise_with_backtrace e origbt 759 end 760 761 (********************************************************************** 762 Profile and command-line parsing 763 **********************************************************************) 764 765 let coreUsageMsg = 766 "Usage: " ^ Uutil.myName 767 ^ " [options]\n" 768 ^ " or " ^ Uutil.myName 769 ^ " root1 root2 [options]\n" 770 ^ " or " ^ Uutil.myName 771 ^ " profilename [options]\n" 772 773 let shortUsageMsg = 774 coreUsageMsg ^ "\n" 775 ^ "For a list of options, type \"" ^ Uutil.myName ^ " -help\".\n" 776 ^ "For a tutorial on basic usage, type \"" ^ Uutil.myName 777 ^ " -doc tutorial\".\n" 778 ^ "For other documentation, type \"" ^ Uutil.myName ^ " -doc topics\".\n" 779 780 let usageMsg = coreUsageMsg 781 782 let debug = Trace.debug "startup" 783 784 (* ---- *) 785 786 (* Determine the case sensitivity of a root (does filename FOO==foo?) *) 787 let architecture = 788 Remote.registerRootCmd 789 "architecture" 790 Umarshal.unit 791 Umarshal.(prod3 bool bool bool id id) 792 (fun (_,()) -> return (Sys.win32, Osx.isMacOSX, Sys.cygwin)) 793 794 (* During startup the client determines the case sensitivity of each root. 795 If any root is case insensitive, all roots must know this -- it's 796 propagated in a pref. Also, detects HFS (needed for resource forks) and 797 Windows (needed for permissions) and does some sanity checking. *) 798 let validateAndFixupPrefs () = 799 Props.validatePrefs(); 800 Globals.allRootsMap (fun r -> architecture r ()) >>= (fun archs -> 801 let someHostIsRunningWindows = 802 Safelist.exists (fun (isWin, _, _) -> isWin) archs in 803 let allHostsAreRunningWindows = 804 Safelist.for_all (fun (isWin, _, _) -> isWin) archs in 805 let someHostIsRunningCygwin = 806 Safelist.exists (fun (_, _, isCyg) -> isCyg) archs in 807 let someHostRunningOsX = 808 Safelist.exists (fun (_, isOSX, _) -> isOSX) archs in 809 let someHostIsCaseInsensitive = 810 someHostIsRunningWindows || someHostRunningOsX || someHostIsRunningCygwin in 811 if Prefs.read Globals.fatFilesystem then begin 812 Prefs.overrideDefault Props.permMask 0; 813 Prefs.overrideDefault Props.dontChmod true; 814 Prefs.overrideDefault Case.caseInsensitiveMode `True; 815 Prefs.overrideDefault Fileinfo.allowSymlinks `False; 816 Prefs.overrideDefault Fileinfo.ignoreInodeNumbers true 817 end; 818 Case.init someHostIsCaseInsensitive someHostRunningOsX; 819 Props.init (someHostIsRunningWindows || someHostIsRunningCygwin); 820 Osx.init someHostRunningOsX; 821 Fileinfo.init someHostIsRunningWindows; 822 Prefs.set Globals.someHostIsRunningWindows someHostIsRunningWindows; 823 Prefs.set Globals.allHostsAreRunningWindows allHostsAreRunningWindows; 824 if repeatWatcher () then Prefs.set Fswatch.useWatcher true; 825 Features.validateEnabled (); 826 return ()) 827 828 (* ---- *) 829 830 type profileInfo = {roots:string list; label:string option; key:string option} 831 832 let profileKeymap = Array.make 10 None 833 834 let provideProfileKey filename k profile info = 835 try 836 let i = int_of_string k in 837 if 0<=i && i<=9 then 838 match profileKeymap.(i) with 839 None -> profileKeymap.(i) <- Some(profile,info) 840 | Some(otherProfile,_) -> 841 raise (Util.Fatal 842 ("Error scanning profile "^ 843 filename ^":\n" 844 ^ "shortcut key "^k^" is already bound to profile " 845 ^ otherProfile)) 846 else 847 raise (Util.Fatal 848 ("Error scanning profile "^ filename ^":\n" 849 ^ "Value of 'key' preference must be a single digit (0-9), " 850 ^ "not " ^ k)) 851 with Failure _ -> raise (Util.Fatal 852 ("Error scanning profile "^ filename ^":\n" 853 ^ "Value of 'key' preference must be a single digit (0-9), " 854 ^ "not " ^ k)) 855 856 let profilesAndRoots = ref [] 857 858 let scanProfiles () = 859 Os.createUnisonDir (); 860 Array.iteri (fun i _ -> profileKeymap.(i) <- None) profileKeymap; 861 profilesAndRoots := 862 (Safelist.filterMap 863 (fun f -> 864 let f = Filename.chop_suffix f ".prf" in 865 let filename = Prefs.profilePathname f in 866 let prefs = 867 try Some (Prefs.readAFile f) with 868 | Util.Fatal s -> begin 869 Util.warn ("Error when reading list of profiles.\n" 870 ^ "Skipping file with error: " 871 ^ filename 872 ^ "\n\n" ^ s); 873 None end in 874 match prefs with 875 | None -> None 876 | Some prefs -> 877 let fileContents = Safelist.map (fun (_, n, v) -> (n, v)) prefs in 878 let roots = 879 Safelist.map snd 880 (Safelist.filter (fun (n, _) -> n = "root") fileContents) in 881 let label = 882 try Some(Safelist.assoc "label" fileContents) 883 with Not_found -> None in 884 let key = 885 try Some (Safelist.assoc "key" fileContents) 886 with Not_found -> None in 887 let info = {roots=roots; label=label; key=key} in 888 (* If this profile has a 'key' binding, put it in the keymap *) 889 (try 890 let k = Safelist.assoc "key" fileContents in 891 provideProfileKey filename k f info 892 with Not_found -> ()); 893 Some (f, info)) 894 (Safelist.filter (fun name -> not ( Util.startswith name ".#" 895 || Util.startswith name Os.tempFilePrefix)) 896 (Files.ls Util.unisonDir "*.prf"))) 897 898 (* ---- *) 899 900 let initRoots displayWaitMessage termInteract = 901 (* The following step contacts the server, so warn the user it could take 902 some time *) 903 if not (Prefs.read contactquietly || Prefs.read Trace.terse) then 904 displayWaitMessage(); 905 906 (* Canonize the names of the roots, sort them (with local roots first), 907 and install them in Globals. *) 908 Lwt_unix.run (Globals.installRoots termInteract); 909 910 Files.processCommitLogs (); 911 912 Update.storeRootsName (); 913 914 let hasRemote = 915 match Globals.rootsInCanonicalOrder () with 916 | _ :: (Remote _, _) :: [] -> true 917 | _ -> false in 918 if 919 hasRemote && not (Prefs.read contactquietly || Prefs.read Trace.terse) 920 then 921 Trace.status (Printf.sprintf "Connected [%s]\n" 922 (Util.replacesubstring (Update.getRootsName()) ", " " -> ")); 923 924 debug (fun() -> 925 Printf.eprintf "Roots: \n"; 926 Safelist.iter (fun clr -> Printf.eprintf " %s\n" clr) 927 (Globals.rawRoots ()); 928 Printf.eprintf " i.e. \n"; 929 Safelist.iter (fun clr -> Printf.eprintf " %s\n" 930 (Clroot.clroot2string (Clroot.parseRoot clr))) 931 (Globals.rawRoots ()); 932 Printf.eprintf " i.e. (in canonical order)\n"; 933 Safelist.iter (fun r -> 934 Printf.eprintf " %s\n" (root2string r)) 935 (Globals.rootsInCanonicalOrder()); 936 Printf.eprintf "\n"); 937 938 (* Expand any "wildcard" paths [with final component *] *) 939 Globals.expandWildcardPaths (); 940 941 Lwt_unix.run 942 (validateAndFixupPrefs () >>= 943 Globals.propagatePrefs); 944 945 (* Initializes some backups stuff according to the preferences just loaded from the profile. 946 Important to do it here, after prefs are propagated, because the function will also be 947 run on the server, if any. Also, this should be done each time a profile is reloaded 948 on this side, that's why it's here. *) 949 Stasher.initBackups () 950 951 (* ---- *) 952 953 let makeTempDir pattern = 954 let path = Filename.temp_file pattern "" in 955 System.unlink path; (* Remove file created by [temp_file]... *) 956 System.mkdir path 0o755; (* ... and create a dir instead. *) 957 path ^ Filename.dir_sep 958 959 let initComplete = ref false 960 961 (* Roots given on the command line *) 962 let cmdLineRawRoots = ref [] 963 964 let clearClRoots () = cmdLineRawRoots := [] 965 966 (* BCP: WARNING: Some of the code from here is duplicated in uimacbridge...! *) 967 let initPrefs ~profileName ~promptForRoots ?(prepDebug = fun () -> ()) () = 968 initComplete := false; 969 (* Restore prefs to their default values *) 970 Prefs.resetToDefaults (); 971 (* Clear out any roots left from a previous profile. They can't remain 972 hanging around if [initPrefs] for the new profile receives an exception 973 before fully completing. *) 974 Globals.uninstallRoots (); 975 Globals.setRawRoots !cmdLineRawRoots; 976 977 (* Tell the preferences module the name of the profile *) 978 Prefs.profileName := Some(profileName); 979 980 (* Check whether the -selftest flag is present on the command line *) 981 let testFlagPresent = 982 Util.StringMap.mem runTestsPrefName (Prefs.scanCmdLine usageMsg) in 983 984 (* If the -selftest flag is present, then we skip loading the preference file. 985 (This is prevents possible confusions where settings from a preference 986 file could cause unit tests to fail.) *) 987 if not testFlagPresent then begin 988 (* If the profile does not exist, create an empty one (this should only 989 happen if the profile is 'default', since otherwise we will already 990 have checked that the named one exists). *) 991 if not(System.file_exists (Prefs.profilePathname profileName)) then 992 Prefs.addComment "Unison preferences file"; 993 994 (* Load the profile *) 995 (debug (fun() -> Util.msg "about to load prefs"); 996 Prefs.loadTheFile()); 997 998 (* Now check again that the -selftest flag has not been set, and barf otherwise *) 999 if Prefs.read runtests then raise (Util.Fatal 1000 "The 'test' flag should only be given on the command line") 1001 end; 1002 1003 if Prefs.read Trace.debugmods <> [] then prepDebug (); 1004 1005 (* Parse the command line. This will override settings from the profile. *) 1006 (* JV (6/09): always reparse the command line *) 1007 if true (*!firstTime*) then begin 1008 debug (fun() -> Util.msg "about to parse command line"); 1009 Prefs.parseCmdLine usageMsg; 1010 end; 1011 1012 (* Turn on GC messages, if the '-debug gc' flag was provided *) 1013 Gc.set {(Gc.get ()) with Gc.verbose = if Trace.enabled "gc" then 0x43F else 0}; 1014 1015 (* Install dummy roots and backup directory if we are running self-tests *) 1016 if Prefs.read runtests then begin 1017 let tmpdir = makeTempDir "unisontest" in 1018 if Globals.rawRoots() = [] then 1019 Prefs.loadStrings [ 1020 "root = " ^ tmpdir ^ "a"; 1021 "root = " ^ tmpdir ^ "b"; 1022 "logfile = " ^ tmpdir ^ "unison.log"; 1023 ]; 1024 if (Prefs.read Stasher.backupdir) = "" then 1025 Prefs.loadStrings [ "backupdir = " ^ tmpdir ^ "backup" ] 1026 end; 1027 1028 (* Print the preference settings *) 1029 debug (fun() -> Prefs.dumpPrefsToStderr() ); 1030 1031 Trace.logonly (Printf.sprintf "\n%s log started at %s\n\n" 1032 (String.capitalize_ascii Uutil.myNameAndVersion) 1033 (Util.time2string (Unix.gettimeofday ()))); 1034 1035 (* If no roots are given either on the command line or in the profile, 1036 ask the user *) 1037 if Globals.rawRoots() = [] then begin 1038 (* Ask the user for the roots *) 1039 match promptForRoots () with 1040 | None -> raise (Util.Fatal "no roots given on command line or in profile") 1041 | Some (r1, r2) -> 1042 begin 1043 (* Remember them for this run, ordering them so that the first 1044 will come out on the left in the UI *) 1045 Globals.setRawRoots [r1; r2]; 1046 (* Save them in the current profile *) 1047 ignore (Prefs.add "root" r1); 1048 ignore (Prefs.add "root" r2) 1049 end 1050 end; 1051 1052 Trace.logonly "Roots:\n"; 1053 Globals.rawRoots () |> Safelist.iter 1054 (fun s -> Trace.logonly " "; Trace.logonly s; Trace.logonly "\n"); 1055 Trace.logonly "\n"; 1056 1057 (* Parse the roots to validate them *) 1058 let parsedRoots = 1059 try Globals.parsedClRawRoots () with 1060 | Invalid_argument s | Util.Fatal s | Prefs.IllegalValue s -> 1061 raise (Util.Fatal ("There's a problem with one of the roots:\n" ^ s)) 1062 in 1063 1064 (* Check to be sure that there is at most one remote root *) 1065 let numRemote = 1066 Safelist.fold_left 1067 (fun n (r : Clroot.clroot) -> match r with 1068 ConnectLocal _ -> n | ConnectByShell _ | ConnectBySocket _ -> n+1) 1069 0 1070 parsedRoots in 1071 if numRemote > 1 then 1072 raise(Util.Fatal "cannot synchronize more than one remote root"); 1073 1074 Recon.checkThatPreferredRootIsValid(); 1075 1076 (* If both roots are local, disable the xferhint table to save time *) 1077 if numRemote = 0 then Prefs.set Xferhint.xferbycopying false; 1078 1079 (* If no paths were specified, then synchronize the whole replicas *) 1080 if Prefs.read Globals.paths = [] then Prefs.set Globals.paths [Path.empty]; 1081 1082 initComplete := true 1083 1084 let connectRoots ?termInteract ~displayWaitMessage () = 1085 let numRoots = Safelist.length (Globals.rawRoots ()) in 1086 if !initComplete && numRoots > 1 then 1087 let numConn = ref 0 in 1088 Lwt_unix.run (Globals.allRootsIter 1089 (fun r -> if Remote.isRootConnected r then incr numConn; Lwt.return ())); 1090 if !numConn < numRoots then initRoots displayWaitMessage termInteract 1091 1092 (********************************************************************** 1093 Common startup sequence 1094 **********************************************************************) 1095 1096 let anonymousArgs = 1097 Prefs.createStringList "rest" 1098 ~category:(`Internal `Other) 1099 "*roots or profile name" "" 1100 1101 let testServer = 1102 Prefs.createBool "testserver" false 1103 ~category:(`Advanced `Remote) 1104 ~cli_only:true 1105 "exit immediately after the connection to the server" 1106 ("Setting this flag on the command line causes Unison to attempt to " 1107 ^ "connect to the remote server and, if successful, print a message " 1108 ^ "and immediately exit. Useful for debugging installation problems. " 1109 ^ "Should not be set in preference files.") 1110 1111 (* For backward compatibility *) 1112 let _ = Prefs.alias testServer "testServer" 1113 1114 (* ---- *) 1115 1116 let uiInitClRootsAndProfile ?(prepDebug = fun () -> ()) () = 1117 (* Make sure we have a directory for archives and profiles *) 1118 Os.createUnisonDir(); 1119 1120 let args = Prefs.scanCmdLine usageMsg in 1121 begin 1122 try if Util.StringMap.find "debug" args <> [] then prepDebug () 1123 with Not_found -> () 1124 end; 1125 1126 (* Extract any command line profile or roots *) 1127 match begin 1128 try 1129 match Util.StringMap.find "rest" args with 1130 | [] -> Ok None 1131 | [profile] -> Ok (Some profile) 1132 | [root2;root1] -> Ok (cmdLineRawRoots := [root1;root2]; None) 1133 | [root2;root1;profile] -> 1134 Ok (cmdLineRawRoots := [root1;root2]; Some profile) 1135 | _ -> 1136 Error (Printf.sprintf 1137 "%s was invoked incorrectly (too many roots)" Uutil.myName) 1138 with Not_found -> Ok None 1139 end with 1140 | Error _ as e -> e 1141 | Ok clprofile -> 1142 debug (fun () -> 1143 (* Print header for debugging output *) 1144 Printf.eprintf "%s, version %s\n\n" Uutil.myName Uutil.myVersion; 1145 Util.msg "initializing UI"; 1146 1147 (match clprofile with 1148 | None -> Util.msg "No profile given on command line" 1149 | Some s -> Printf.eprintf "Profile '%s' given on command line" s); 1150 (match !cmdLineRawRoots with 1151 | [] -> Util.msg "No roots given on command line" 1152 | [root1;root2] -> 1153 Printf.eprintf "Roots '%s' and '%s' given on command line" 1154 root1 root2 1155 | _ -> assert false)); 1156 1157 match clprofile with 1158 | None when !cmdLineRawRoots = [] -> 1159 (* Ask the user to choose a profile or create a new one. *) 1160 Ok None 1161 | None -> 1162 (* Roots given on command line. The profile should be the default. *) 1163 Ok (Some "default") 1164 | Some n -> 1165 let f = Prefs.profilePathname n in 1166 if not (System.file_exists f) 1167 then Error (Printf.sprintf 1168 "Profile '%s' does not exist (looking for file %s)" 1169 n f) 1170 else Ok (Some n) 1171 1172 (* Exit codes *) 1173 let perfectExit = 0 (* when everything's okay *) 1174 let skippyExit = 1 (* when some items were skipped, but no failure occurred *) 1175 let failedExit = 2 (* when there's some non-fatal failure *) 1176 let fatalExit = 3 (* when fatal failure occurred *) 1177 let exitCode = function 1178 (false, false) -> 0 1179 | (true, false) -> 1 1180 | _ -> 2 1181 (* (anySkipped?, anyFailure?) -> exit code *)