fspath.ml (17054B)
1 (* Unison file synchronizer: src/fspath.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 (* Defines an abstract type of absolute filenames (fspaths). Keeping the *) 20 (* type abstract lets us enforce some invariants which are important for *) 21 (* correct behavior of some system calls. *) 22 (* - *) 23 (* Invariants: *) 24 (* Fspath "" is not allowed *) 25 (* All root directories end in / *) 26 (* All non-root directories end in some other character *) 27 (* All separator characters are /, even in Windows *) 28 (* All fspaths are absolute *) 29 (* - *) 30 31 let debug = Util.debug "fspath" 32 let debugverbose = Util.debug "fsspath+" 33 34 type t = Fspath of string 35 36 let m = Umarshal.(sum1 string (function Fspath a -> a) (function a -> Fspath a)) 37 38 let toString (Fspath f) = f 39 let toPrintString (Fspath f) = f 40 let toDebugString (Fspath f) = String.escaped f 41 42 let winStylePaths = Sys.win32 || Sys.cygwin 43 44 (* Needed to hack around some ocaml/Windows bugs, see comment at stat, below *) 45 let winRootRx = Rx.rx "(([a-zA-Z]:)?/|//[^?/]+/[^/]+/|//[?]/[Uu][Nn][Cc]/[^/]+/[^/]+/)|//[?]/([^Uu][^/]*|[Uu]|[Uu][^Nn][^/]*|[Uu][Nn]|[Uu][Nn][^Cc][^/]*|[Uu][Nn][Cc][^/]+)/" 46 (* FIX I think we could just check the last character of [d]. *) 47 let isRootDir d = 48 (* We assume all path separators are slashes in d *) 49 d="/" || 50 (winStylePaths && Rx.match_string winRootRx d) 51 (* Here, backslashes are allowed as path separators in Windows *) 52 let isRootDirLocalString d = 53 let d = 54 if winStylePaths then Fileutil.backslashes2forwardslashes d else d 55 in 56 isRootDir ((Fileutil.removeTrailingSlashes d) ^ "/") 57 let winRootFix d = 58 if Rx.match_string winRootRx (d ^ "/") then d ^ "/" else d 59 let winFNsPrefixRx = Rx.rx "[\\/][\\/][?][\\/][^\\/]+" 60 let isInvalidWinPath p = 61 Rx.match_string winFNsPrefixRx p (* Is there a path after the prefix? *) 62 let winSafeDirname p = 63 if not winStylePaths then 64 Filename.dirname p 65 else 66 (* [Filename.dirname] can't handle Windows paths prefixed with \\?\ 67 (Win32 file namespace) if [dirname] goes all the way up to the fs root. 68 Most paths are still processed correctly because they are basically a 69 DOS path prefixed with \\?\ or something similar to \\server\share\ 70 paths. Only paths right at the fs root are problematic. 71 72 \\?\C:\ becomes \\? (correct is \\?\C:\) 73 \\?\C:\sub becomes \\?\C (correct is \\?\C:\) 74 \\?\Volume{GUID}\ becomes \\? (correct is \\?\Volume{GUID}\) 75 \\?\Volume{GUID}\sub becomes \\?\Volume{GUID} (correct is \\?\Volume{GUID}\) 76 77 As a workaround, first remove the \\?\ prefix and the first component of 78 the path (usually this would be the "volume", except for UNC paths). 79 Then add the removed prefix back to the result of [dirname]. *) 80 match Rx.match_prefix winFNsPrefixRx p 0 with 81 | None -> Filename.dirname p 82 | Some pos -> 83 String.sub p 0 pos ^ 84 Filename.dirname (String.sub p pos (String.length p - pos)) 85 86 (* [differentSuffix: fspath -> fspath -> (string * string)] returns the *) 87 (* least distinguishing suffixes of two fspaths, for displaying in the user *) 88 (* interface. *) 89 let differentSuffix (Fspath f1) (Fspath f2) = 90 if isRootDir f1 || isRootDir f2 then (f1,f2) 91 else begin 92 (* We use the invariant that neither f1 nor f2 ends in slash *) 93 let len1 = String.length f1 in 94 let len2 = String.length f2 in 95 let n = 96 (* The position of the character from the right where the fspaths *) 97 (* differ *) 98 let rec loop n = 99 let i1 = len1-n in 100 if i1<0 then n else 101 let i2 = len2-n in 102 if i2<0 then n else 103 if compare (String.get f1 i1) (String.get f2 i2) = 0 104 then loop (n+1) 105 else n in 106 loop 1 in 107 let suffix f len = 108 if n > len then f else 109 try 110 let n' = String.rindex_from f (len-n) '/' in 111 String.sub f (n'+1) (len-n'-1) 112 with Not_found -> f in 113 let s1 = suffix f1 len1 in 114 let s2 = suffix f2 len2 in 115 (s1,s2) 116 end 117 118 (* When an HFS file is stored on a non-HFS system it is stored as two 119 files, the data fork, and the rest of the file including resource 120 fork is stored in the AppleDouble file, which has the same name as 121 the data fork file with ._ prepended. *) 122 let appleDouble (Fspath f) = 123 if isRootDir f then raise(Invalid_argument "Fspath.appleDouble") else 124 let len = String.length f in 125 try 126 let i = 1 + String.rindex f '/' in 127 let res = Bytes.create (len + 2) in 128 String.blit f 0 res 0 i; 129 Bytes.set res i '.'; 130 Bytes.set res (i + 1) '_'; 131 String.blit f i res (i + 2) (len - i); 132 Fspath (Bytes.to_string res) 133 with Not_found -> 134 assert false 135 136 let rsrc (Fspath f) = 137 if isRootDir f then raise(Invalid_argument "Fspath.rsrc") else 138 Fspath(f^"/..namedfork/rsrc") 139 140 (* WRAPPED SYSTEM CALLS *) 141 142 (* CAREFUL! 143 Windows porting issue: 144 Unix.LargeFile.stat "c:\\windows\\" will fail, you must use 145 Unix.LargeFile.stat "c:\\windows" instead. 146 The standard file selection dialog, however, will return a directory 147 with a trailing backslash. 148 Therefore, be careful to remove a trailing slash or backslash before 149 calling this in Windows. 150 BUT Windows shares are weird! 151 //raptor/trevor and //raptor/trevor/mirror are directories 152 and //raptor/trevor/.bashrc is a file. We observe the following: 153 Unix.LargeFile.stat "//raptor" will fail. 154 Unix.LargeFile.stat "//raptor/" will fail. 155 Unix.LargeFile.stat "//raptor/trevor" will fail. 156 Unix.LargeFile.stat "//raptor/trevor/" will succeed. 157 Unix.LargeFile.stat "//raptor/trevor/mirror" will succeed. 158 Unix.LargeFile.stat "//raptor/trevor/mirror/" will fail. 159 Unix.LargeFile.stat "//raptor/trevor/.bashrc/" will fail. 160 Unix.LargeFile.stat "//raptor/trevor/.bashrc" will succeed. 161 Not sure what happens for, e.g., 162 Unix.LargeFile.stat "//raptor/FOO" 163 where //raptor/FOO is a file. 164 I guess the best we can do is: 165 To stat //host/xxx, assume xxx is a directory, and use 166 Unix.LargeFile.stat "//host/xxx/". If xxx is not a directory, 167 who knows. 168 To stat //host/path where path has length >1, don't use 169 a trailing slash. 170 The way I did this was to assume //host/xxx/ is a root directory. 171 Then by the invariants of fspath it should always end in /. 172 173 Unix.LargeFile.stat "c:" will fail. 174 Unix.LargeFile.stat "c:/" will succeed. 175 Unix.LargeFile.stat "c://" will fail. 176 (The Unix version of ocaml handles either a trailing slash or no 177 trailing slash.) 178 179 Invariant on fspath will guarantee that argument is OK for stat 180 *) 181 182 (* HACK: 183 Under Windows 98, 184 Unix.opendir "c:/" fails 185 Unix.opendir "c:/*" works 186 Unix.opendir "/" fails 187 Under Windows 2000, 188 Unix.opendir "c:/" works 189 Unix.opendir "c:/*" fails 190 Unix.opendir "/" fails 191 192 Unix.opendir "c:" works as well, but, this refers to the current 193 working directory AFAIK. 194 195 let opendir (Fspath d) = 196 if Util.osType<>`Win32 || not(isRootDir d) then Unix.opendir d else 197 try 198 Unix.opendir d 199 with Unix.Unix_error _ -> 200 Unix.opendir (d^"*") 201 *) 202 203 let child (Fspath f) n = 204 (* Note, f is not "" by invariants on Fspath *) 205 if 206 (* We use the invariant that f ends in / iff f is a root filename *) 207 isRootDir f 208 then 209 Fspath(Printf.sprintf "%s%s" f (Name.toString n)) 210 else 211 Fspath (Printf.sprintf "%s%c%s" f '/' (Name.toString n)) 212 213 let concat fspath path = 214 if Path.isEmpty path then 215 fspath 216 else begin 217 let Fspath fspath = fspath in 218 if 219 (* We use the invariant that f ends in / iff f is a root filename *) 220 isRootDir fspath 221 then 222 Fspath (fspath ^ Path.toString path) 223 else 224 let p = Path.toString path in 225 let l = String.length fspath in 226 let l' = String.length p in 227 let s = Bytes.create (l + l' + 1) in 228 String.blit fspath 0 s 0 l; 229 Bytes.set s l '/'; 230 String.blit p 0 s (l + 1) l'; 231 Fspath (Bytes.to_string s) 232 end 233 234 (*****************************************************************************) 235 (* CANONIZING PATHS *) 236 (*****************************************************************************) 237 238 (* Convert a string to an fspath. HELP ENFORCE INVARIANTS listed above. *) 239 let localString2fspath s = 240 (* Force path separators to be slashes in Windows, handle weirdness in *) 241 (* Windows network names *) 242 let s = 243 if winStylePaths 244 then winRootFix (Fileutil.backslashes2forwardslashes s) 245 else s in 246 (* Note: s may still contain backslashes under Unix *) 247 if isRootDir s then Fspath s 248 else if String.length s > 0 then 249 let s' = Fileutil.removeTrailingSlashes s in 250 if String.length s' = 0 then Fspath "/" (* E.g., s="///" *) 251 else Fspath s' 252 else 253 (* Prevent Fspath "" *) 254 raise(Invalid_argument "Os.localString2fspath") 255 256 (* Return the canonical fspath of a filename (string), relative to the *) 257 (* current host, current directory. *) 258 259 (* THIS IS A HACK. It has to take account of some porting issues between *) 260 (* the Unix and Windows versions of ocaml, etc. In particular, the Unix, *) 261 (* Filename, and Sys modules of ocaml have subtle differences under Windows *) 262 (* and Unix. So, be very careful with any changes !!! *) 263 let canonizeFspath p0 = 264 let p = match p0 with None -> "." | Some "" -> "." | Some s -> s in 265 let p' = 266 begin 267 let original = System.getcwd () in 268 try 269 let newp = 270 System.chdir p; (* This might raise Sys_error *) 271 System.getcwd () in 272 System.chdir original; 273 newp 274 with 275 Sys_error why -> 276 (* We could not chdir to p. Either *) 277 (* - *) 278 (* (1) p does not exist *) 279 (* (2) p is a file *) 280 (* (3) p is a dir but we don't have permission *) 281 (* - *) 282 (* In any case, we try to cd to the parent of p, and if that *) 283 (* fails, we just quit. This works nicely for most cases of (1), *) 284 (* it works for (2), and on (3) it may leave a mess for someone *) 285 (* else to pick up. *) 286 if isRootDirLocalString p || isInvalidWinPath p then raise 287 (Util.Fatal (Printf.sprintf 288 "Cannot find canonical name of root directory %s\n(%s)%s" p why 289 (if isInvalidWinPath p then "\nMaybe you need to add a " 290 ^ "backslash at end of the root path?" else ""))); 291 let parent = winSafeDirname p in 292 let parent' = begin 293 (try System.chdir parent with 294 Sys_error why2 -> raise (Util.Fatal (Printf.sprintf 295 "Cannot find canonical name of %s: unable to cd either to it \ 296 (%s)\nor to its parent %s\n(%s)" p why parent why2))); 297 System.getcwd () end in 298 System.chdir original; 299 let bn = Filename.basename p in 300 if bn="" then parent' 301 else toString(child (localString2fspath parent') 302 (Name.fromString bn)) 303 end in 304 localString2fspath p' 305 306 (* 307 (* TJ--I'm disabling this for now. It is causing directories to be created *) 308 (* with the wrong case, e.g., an upper case directory that needs to be *) 309 (* propagated will be created with a lower case name. We'll see if the *) 310 (* weird problem with changing case is still happening. *) 311 if Util.osType<>`Win32 then localString2fspath p' 312 else 313 (* A strange bug turns up in Windows: sometimes p' has mixed case, *) 314 (* sometimes it is all lower case. (Sys.getcwd seems to make a random *) 315 (* choice.) Since file names are not case-sensitive in Windows we just *) 316 (* force everything to lower case. *) 317 318 (* NOTE: WE DON'T ENFORCE THAT FSPATHS CREATED BY CHILDFSPATH ARE ALL *) 319 (* LOWER CASE!! *) 320 let p' = String.lowercase p' in 321 localString2fspath p' 322 *) 323 324 let canonize x = 325 Util.convertUnixErrorsToFatal "canonizing path" (fun () -> canonizeFspath x) 326 327 let maxlinks = 100 328 let findWorkingDir fspath path = 329 let abspath = toString (concat fspath path) in 330 let realpath = 331 if not (Path.followLink path) then abspath else 332 let rec followlinks n p = 333 if n>=maxlinks then 334 raise 335 (Util.Transient (Printf.sprintf 336 "Too many symbolic links from %s" abspath)); 337 try 338 (* Relevant on Windows: We can (and should) use [extendedPath] only 339 on the very first input, which is known to satisfy [Fspath.t] 340 invariants. Inputs used for all following loops come from the output 341 of [readlink] either without any processing done on it (if the link 342 is an absolute path) - such paths are potentially unsuitable as 343 input to [extendedPath] - or already extended (when concatenating 344 a relative path). *) 345 let link = System.readlink (if n = 0 then System.extendedPath p else p) in 346 let linkabs = 347 if Filename.is_relative link then 348 (* FIXME? On Windows, this concatenation will potentially create 349 an invalid path if [link] contains components like "." and "..". 350 These components will not be processed by Windows if [p] has 351 prefix \\?\ or //?/ or if the resulting path is later used as 352 input to a syscall via [Fs] module (then the said prefix could be 353 added automatically). 354 https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file#win32-file-namespaces 355 356 The solution is perhaps to replace the entire [followlinks] 357 function with realpath(3) on POSIX platforms. The respective 358 function in Windows seems to be GetFinalPathNameByHandle, which 359 is available since Windows Vista. 360 [Unix.realpath] first appeared in OCaml 4.13. 361 362 However, realpath(3) does not have exactly the same semantics as 363 the current [followlinks] function. [followlinks] will go as far 364 as it can and gives the last successful intermediary path as the 365 result when an error happens. realpath(3) will give you all or 366 nothing. 367 368 [chdir] hack from [canonizeFspath] above seems to be the current 369 best compromise. *) 370 Filename.concat (winSafeDirname p) link 371 |> fun l -> 372 if Sys.win32 then 373 let Fspath l' = canonizeFspath (Some l) in 374 System.extendedPath l' 375 else l 376 else link in 377 followlinks (n+1) linkabs 378 with 379 | Unix.Unix_error _ | Util.Fatal _ -> p 380 in 381 followlinks 0 abspath in 382 if isRootDirLocalString realpath then 383 raise (Util.Transient(Printf.sprintf 384 "The path %s is a root directory" abspath)); 385 let p = Filename.basename realpath in 386 debug 387 (fun() -> 388 Util.msg "Os.findWorkingDir(%s,%s) = (%s,%s)\n" 389 (toString fspath) 390 (Path.toString path) 391 (winSafeDirname realpath) 392 p); 393 (localString2fspath (winSafeDirname realpath), Path.fromString p) 394 395 let quotes (Fspath f) = Uutil.quotes f 396 let compare (Fspath f1) (Fspath f2) = compare f1 f2