globals.ml (13542B)
1 (* Unison file synchronizer: src/globals.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 let debug = Trace.debug "globals" 22 23 (*****************************************************************************) 24 (* ROOTS and PATHS *) 25 (*****************************************************************************) 26 27 let rawroots = 28 Prefs.createStringList "root" 29 ~category:(`Basic `Sync) 30 "root of a replica (should be used exactly twice)" 31 ("Each use of this preference names the root of one of the replicas " 32 ^ "for Unison to synchronize. Exactly two roots are needed, so normal " 33 ^ "modes of usage are either to give two values for \\verb|root| in the " 34 ^ "profile, or to give no values in the profile and provide two " 35 ^ "on the command line. " 36 ^ "Details of the syntax of roots can be found in " 37 ^ "\\sectionref{roots}{Roots}.\n\n" 38 ^ "The two roots can be given in either order; Unison will sort them " 39 ^ "into a canonical order before doing anything else. It also tries to " 40 ^ "`canonize' the machine names and paths that appear in the roots, so " 41 ^ "that, if Unison is invoked later with a slightly different name " 42 ^ "for the same root, it will be able to locate the correct archives.") 43 44 let setRawRoots l = Prefs.set rawroots (Safelist.rev l) 45 46 let rawRoots () = Safelist.rev (Prefs.read rawroots) 47 48 let parsedClrootCache = ref [] 49 50 let parsedClRawRoots () = 51 let key = Prefs.read rawroots in 52 match List.assq_opt key !parsedClrootCache with 53 | Some x -> x 54 | None -> let x = Safelist.map Clroot.parseRoot (rawRoots ()) in 55 parsedClrootCache := (key, x) :: !parsedClrootCache; x 56 57 let wrongNumRootsExn roots = 58 Util.Fatal (Printf.sprintf "Wrong number of roots: \ 59 2 expected, but %d provided (%s)\n(Maybe you specified \ 60 roots both on the command line and in the profile?)" 61 (Safelist.length roots) 62 (String.concat ", " roots)) 63 64 let rawRootPair () = 65 match rawRoots () with 66 [r1; r2] -> (r1, r2) 67 | roots -> raise (wrongNumRootsExn roots) 68 69 let theroots = ref [] 70 71 let uninstallRoots () = theroots := []; parsedClrootCache := [] 72 73 open Lwt 74 let installRoots termInteract = 75 let () = uninstallRoots () in (* Clear out potential old roots *) 76 let roots = rawRoots () in 77 if Safelist.length roots <> 2 then raise (wrongNumRootsExn roots); 78 Safelist.fold_right 79 (fun r cont -> 80 Remote.canonizeRoot r (Clroot.parseRoot r) termInteract 81 >>= (fun r' -> 82 cont >>= (fun l -> 83 return (r' :: l)))) 84 roots (return []) >>= (fun roots' -> 85 let () = match roots' with 86 | [r1; r2] when r1 = r2 -> 87 raise (Util.Fatal (Printf.sprintf 88 ("That's no good, the roots appear to be the same! Here's " 89 ^^ "what I found:\nFirst root: %s\nSecond root: %s") 90 (Common.root2string r1) (Common.root2string r2))) 91 | _ -> () 92 in 93 theroots := roots'; 94 Negotiate.features (Common.sortRoots roots') >>= 95 return) 96 97 (* Alternate interface, should replace old interface eventually *) 98 let installRoots2 () = 99 debug (fun () -> Util.msg "Installing roots..."); 100 let () = uninstallRoots () in (* Clear out potential old roots *) 101 let roots = rawRoots () in 102 theroots := 103 Safelist.map Remote.canonize ((Safelist.map Clroot.parseRoot) roots); 104 Lwt_unix.run (Negotiate.features (Common.sortRoots !theroots)) 105 106 let roots () = 107 match !theroots with 108 [root1;root2] -> (root1,root2) 109 | _ -> assert false 110 111 let rootsList() = !theroots 112 113 let rootsInCanonicalOrder() = Common.sortRoots (!theroots) 114 115 let localRoot () = List.hd (rootsInCanonicalOrder ()) 116 117 let reorderCanonicalListToUsersOrder l = 118 if rootsList() = rootsInCanonicalOrder() then l 119 else Safelist.rev l 120 121 let rec nice_rec i 122 : unit Lwt.t = 123 if i <= 0 then 124 Lwt.return () 125 else 126 Lwt_unix.yield() >>= (fun () -> nice_rec (i - 1)) 127 128 (* [nice r] yields 5 times on local roots [r] to give processes 129 corresponding to remote roots a chance to run *) 130 let nice r = 131 if List.exists (fun r -> fst r <> Local) (rootsList ()) && fst r = Local then 132 nice_rec 5 133 else 134 Lwt.return () 135 136 let allRootsIter f = 137 Lwt_util.iter 138 (fun r -> nice r >>= (fun () -> f r)) (rootsInCanonicalOrder ()) 139 140 let allRootsIter2 f l = 141 let l = Safelist.combine (rootsList ()) l in 142 Lwt_util.iter (fun (r, v) -> nice r >>= (fun () -> f r v)) 143 (Safelist.sort (fun (r, _) (r', _) -> Common.compareRoots r r') l) 144 145 let allRootsMap f = 146 Lwt_util.map 147 (fun r -> nice r >>= (fun () -> f r >>= (fun v -> return (r, v)))) 148 (rootsInCanonicalOrder ()) >>= (fun l -> 149 return (Safelist.map snd (reorderCanonicalListToUsersOrder l))) 150 151 let allRootsMapWithWaitingAction f wa = 152 Lwt_util.map_with_waiting_action 153 (fun r -> nice r >>= (fun () -> f r >>= (fun v -> return (r, v)))) 154 (fun r -> wa r) 155 (rootsInCanonicalOrder ()) >>= (fun l -> 156 return (Safelist.map snd (reorderCanonicalListToUsersOrder l))) 157 158 let paths = 159 Prefs.create "path" [] 160 ~category:(`Basic `Sync) 161 "path to synchronize" 162 ("When no \\verb|path| preference is given, Unison will simply synchronize " 163 ^ "the two entire replicas, beginning from the given pair of roots. " 164 ^ "If one or more \\verb|path| preferences are given, then Unison will " 165 ^ "synchronize only these paths and their children. (This is useful " 166 ^ "for doing a fast sync of just one directory, for example.) " 167 ^ "Note that {\\tt path} preferences are interpreted literally---they " 168 ^ "are not regular expressions.") 169 (fun oldpaths string -> Safelist.append oldpaths [Path.fromString string]) 170 (fun l -> Safelist.map Path.toString l) 171 Umarshal.(list Path.m) 172 173 (* FIX: this does weird things in case-insensitive mode... *) 174 let globPath lr p = 175 let p = Path.forceLocal p in 176 debug (fun() -> 177 Util.msg "Checking path '%s' for expansions\n" 178 (Path.toDebugString p) ); 179 match Path.deconstructRev p with 180 Some(n,parent) when (Name.toString n = "*") -> begin 181 debug (fun() -> Util.msg "Expanding path %s\n" (Path.toString p)); 182 match lr with 183 None -> raise (Util.Fatal (Printf.sprintf 184 "Path %s ends with *, %s" 185 (Path.toString p) 186 "but first root (after canonizing) is non-local")) 187 | Some lrfspath -> 188 Safelist.map (fun c -> Path.makeGlobal (Path.child parent c)) 189 (Os.childrenOf lrfspath parent) 190 end 191 | _ -> [Path.makeGlobal p] 192 193 let expandWildcardPaths() = 194 let lr = 195 match rootsInCanonicalOrder() with 196 [(Local, fspath); _] -> Some fspath 197 | _ -> None in 198 Prefs.set paths 199 (Safelist.flatten_map (globPath lr) (Prefs.read paths)) 200 201 (*****************************************************************************) 202 (* PROPAGATION OF PREFERENCES *) 203 (*****************************************************************************) 204 205 let propagatePrefsTo = 206 Remote.registerRootCmdWithConnection 207 "installPrefs" Prefs.mdumpedPrefs Umarshal.unit 208 (fun conn prefs -> return (Prefs.load prefs (Remote.connectionVersion conn))) 209 210 let propagatePrefs () = 211 let toRoot = function 212 | (Local, _) -> return () 213 | (Remote _, _) as root -> 214 let rpcVer = Remote.(connectionVersion (connectionOfRoot root)) in 215 let prefs = Prefs.dump rpcVer in 216 propagatePrefsTo root root prefs 217 in 218 allRootsIter toRoot 219 220 (*****************************************************************************) 221 (* PREFERENCES AND PREDICATES *) 222 (*****************************************************************************) 223 224 let batch = 225 Prefs.createBool "batch" false 226 ~category:(`Basic `Syncprocess) 227 "batch mode: ask no questions at all" 228 ("When this is set to {\\tt true}, the user " 229 ^ "interface will ask no questions at all. Non-conflicting changes " 230 ^ "will be propagated; conflicts will be skipped.") 231 232 let confirmBigDeletes = 233 Prefs.createBool "confirmbigdel" true 234 ~category:(`Advanced `Syncprocess) 235 "ask about whole-replica (or path) deletes" 236 ("When this is set to {\\tt true}, Unison will request an extra confirmation if it appears " 237 ^ "that the entire replica has been deleted, before propagating the change. If the {\\tt batch} " 238 ^ "flag is also set, synchronization will be aborted. When the {\\tt path} preference is used, " 239 ^ "the same confirmation will be requested for top-level paths. (At the moment, this flag only " 240 ^ "affects the text user interface.) See also the {\\tt mountpoint} preference.") 241 242 let () = Prefs.alias confirmBigDeletes "confirmbigdeletes" 243 244 let ignorePred = 245 Pred.create "ignore" 246 ~category:(`Basic `Sync) 247 ("Including the preference \\texttt{-ignore \\ARG{pathspec}} causes Unison to " 248 ^ "completely ignore paths that match \\ARG{pathspec} (as well as their " 249 ^ "children). This is useful for avoiding synchronizing temporary " 250 ^ "files, object files, etc. The syntax of \\ARG{pathspec} is " 251 ^ "described in \\sectionref{pathspec}{Path Specification}, and further " 252 ^ "details on ignoring paths is found in" 253 ^ " \\sectionref{ignore}{Ignoring Paths}.") 254 255 let ignorenotPred = 256 Pred.create "ignorenot" 257 ~category:(`Basic `Sync) 258 ("This preference overrides the preference \\texttt{ignore}. 259 It gives a list of patterns 260 (in the same format as 261 \\verb|ignore|) for paths that should definitely {\\em not} be ignored, 262 whether or not they happen to match one of the \\verb|ignore| patterns. 263 \\par Note that the semantics of {\\tt ignore} and {\\tt ignorenot} is a 264 little counter-intuitive. When detecting updates, Unison examines 265 paths in depth-first order, starting from the roots of the replicas 266 and working downwards. Before examining each path, it checks whether 267 it matches {\\tt ignore} and does not match {\\tt ignorenot}; in this case 268 it skips this path {\\em and all its descendants}. This means that, 269 if some parent of a given path matches an {\\tt ignore} pattern, then 270 it will be skipped even if the path itself matches an {\\tt ignorenot} 271 pattern. In particular, putting {\\tt ignore = Path *} in your profile 272 and then using {\\tt ignorenot} to select particular paths to be 273 synchronized will not work. Instead, you should use the {\\tt path} 274 preference to choose particular paths to synchronize.") 275 276 let atomic = Pred.create "atomic" 277 ~category:(`Advanced `Sync) 278 ~local:true 279 ("This preference specifies paths for directories whose " 280 ^ "contents will be considered as a group rather than individually when " 281 ^ "they are both modified. " 282 ^ "The backups are also made atomically in this case. The option " 283 ^ "\\texttt{backupcurr} however has no effect on atomic directories.") 284 285 let shouldIgnore p = 286 let p = Path.toString p in 287 (Pred.test ignorePred p) && not (Pred.test ignorenotPred p) 288 289 let addRegexpToIgnore re = 290 let oldRE = Pred.extern ignorePred in 291 let newRE = re::oldRE in 292 Pred.intern ignorePred newRE 293 294 let merge = 295 Pred.create "merge" 296 ~category:(`Advanced `Sync) 297 ("This preference can be used to run a merge program which will create " 298 ^ "a new version for each of the files and the backup, " 299 ^ "with the last backup and both replicas. " 300 ^ "The syntax of \\ARG{pathspec -> cmd} is " 301 ^ "described in \\sectionref{pathspec}{Path Specification}, and further " 302 ^ "details on Merging functions are present in " 303 ^ "\\sectionref{merge}{Merging Conflicting Versions}.") 304 305 let shouldMerge p = Pred.test merge (Path.toString p) 306 307 let mergeCmdForPath p = Pred.assoc merge (Path.toString p) 308 309 let someHostIsRunningWindows = 310 Prefs.createBool "someHostIsRunningWindows" false 311 ~category:(`Internal `Pseudo) 312 "*" "" 313 314 let allHostsAreRunningWindows = 315 Prefs.createBool "allHostsAreRunningWindows" false 316 ~category:(`Internal `Pseudo) 317 "*" "" 318 319 let fatFilesystem = 320 Prefs.createBool "fat" false 321 ~category:(`Advanced `Syncprocess) 322 ~local:true 323 "use appropriate options for FAT filesystems" 324 ("When this is set to {\\tt true}, Unison will use appropriate options \ 325 to synchronize efficiently and without error a replica located on a \ 326 FAT filesystem on a non-Windows machine: \ 327 do not synchronize permissions ({\\tt perms = 0}); \ 328 never use chmod ({\\tt dontchmod = true}); \ 329 treat filenames as case insensitive ({\\tt ignorecase = true}); \ 330 do not attempt to synchronize symbolic links ({\\tt links = false}); \ 331 ignore inode number changes when detecting updates \ 332 ({\\tt ignoreinodenumbers = true}). \ 333 Any of these change can be overridden by explicitly setting \ 334 the corresponding preference in the profile.")