osx.ml (20379B)
1 (* Unison file synchronizer: src/osx.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 See 20 http://www.opensource.apple.com/source/copyfile/copyfile-42/copyfile.c 21 *) 22 23 let debug = Trace.debug "osx" 24 25 (****) 26 27 external isMacOSXPred : unit -> bool = "isMacOSX" 28 29 let isMacOSX = isMacOSXPred () 30 31 (****) 32 33 let rsrcSync = 34 Prefs.createBoolWithDefault "rsrc" 35 ~category:(`Advanced `Sync) 36 "synchronize resource forks (true/false/default)" 37 "When set to {\\tt true}, this flag causes Unison to synchronize \ 38 resource forks and HFS meta-data. On filesystems that do not \ 39 natively support resource forks, this data is stored in \ 40 Carbon-compatible .\\_ AppleDouble files. When the flag is set \ 41 to {\\tt false}, Unison will not synchronize these data. \ 42 Ordinarily, the flag is set to {\\tt default}, and these data are 43 automatically synchronized if either host is running OSX. In \ 44 rare circumstances it is useful to set the flag manually." 45 46 (* Defining this variable as a preference ensures that it will be propagated 47 to the other host during initialization *) 48 let rsrc = 49 Prefs.createBool "rsrc-aux" false 50 ~category:(`Internal `Pseudo) 51 "*synchronize resource forks and HFS meta-data" "" 52 53 let init b = 54 Prefs.set rsrc 55 (Prefs.read rsrcSync = `True || 56 (Prefs.read rsrcSync = `Default && b)) 57 58 (****) 59 60 let doubleMagic = "\000\005\022\007" 61 let doubleVersion = "\000\002\000\000" 62 let doubleFiller = String.make 16 '\000' 63 let resource_fork_empty_tag = "This resource fork intentionally left blank " 64 let finfoLength = 32L 65 let emptyFinderInfo () = Bytes.make 32 '\000' 66 let empty_resource_fork = 67 "\000\000\001\000" ^ 68 "\000\000\001\000" ^ 69 "\000\000\000\000" ^ 70 "\000\000\000\030" ^ 71 resource_fork_empty_tag ^ 72 String.make (66+128) '\000' ^ 73 "\000\000\001\000" ^ 74 "\000\000\001\000" ^ 75 "\000\000\000\000" ^ 76 "\000\000\000\030" ^ 77 "\000\000\000\000" ^ 78 "\000\000\000\000" ^ 79 "\000\028\000\030" ^ 80 "\255\255" 81 let empty_attribute_chunk () = 82 "\000\000" ^ (* pad *) 83 "ATTR" ^ (* magic *) 84 "\000\000\000\000" ^ (* debug tag *) 85 "\000\000\014\226" ^ (* total size *) 86 "\000\000\000\156" ^ (* data_start *) 87 "\000\000\000\000" ^ (* data_length *) 88 "\000\000\000\000" ^ (* reserved *) 89 "\000\000\000\000" ^ 90 "\000\000\000\000" ^ 91 "\000\000" ^ (* flags *) 92 "\000\000" ^ (* num_attrs *) 93 String.make 3690 '\000' 94 95 let getInt2 buf ofs = (Char.code buf.[ofs]) * 256 + Char.code buf.[ofs + 1] 96 97 let getInt4 buf ofs = 98 let get i = Int64.of_int (Char.code buf.[ofs + i]) in 99 let combine x y = Int64.logor (Int64.shift_left x 8) y in 100 combine (combine (combine (get 0) (get 1)) (get 2)) (get 3) 101 102 let getID buf ofs = 103 let get i = Char.code buf.[ofs + i] in 104 if get ofs <> 0 || get (ofs + 1) <> 0 || get (ofs + 2) <> 0 then 105 `UNKNOWN 106 else 107 match get (ofs + 3) with 108 2 -> `RSRC 109 | 9 -> `FINFO 110 | _ -> `UNKNOWN 111 112 let setInt4 v = 113 let s = Bytes.create 4 in 114 let set i = 115 Bytes.set s i 116 (Char.chr (Int64.to_int (Int64.logand 255L 117 (Int64.shift_right v (24 - 8 * i))))) in 118 set 0; set 1; set 2; set 3; 119 s 120 121 let fail dataFspath dataPath doubleFspath msg = 122 debug (fun () -> Util.msg "called 'fail'"); 123 raise (Util.Transient 124 (Format.sprintf 125 "The AppleDouble Header file '%s' \ 126 associated to data file %s is malformed: %s" 127 (Fspath.toPrintString doubleFspath) 128 (Fspath.toPrintString (Fspath.concat dataFspath dataPath)) msg)) 129 130 let readDouble dataFspath dataPath doubleFspath inch len = 131 let buf = Bytes.create len in 132 begin try 133 really_input inch buf 0 len 134 with End_of_file -> 135 fail dataFspath dataPath doubleFspath "truncated" 136 end; 137 Bytes.to_string buf 138 139 let readDoubleFromOffset dataFspath dataPath doubleFspath inch offset len = 140 LargeFile.seek_in inch offset; 141 readDouble dataFspath dataPath doubleFspath inch len 142 143 let writeDoubleFromOffset outch offset str = 144 LargeFile.seek_out outch offset; 145 output_string outch str 146 147 let protect f g = 148 try 149 f () 150 with Sys_error _ | Unix.Unix_error _ | Util.Transient _ as e -> 151 begin try g () with Sys_error _ | Unix.Unix_error _ -> () end; 152 raise e 153 154 let openDouble dataFspath dataPath = 155 let doubleFspath = Fspath.appleDouble (Fspath.concat dataFspath dataPath) in 156 let inch = 157 try Fs.open_in_bin doubleFspath with Sys_error _ -> raise Not_found in 158 protect (fun () -> 159 Util.convertUnixErrorsToTransient "opening AppleDouble file" (fun () -> 160 let header = readDouble dataFspath dataPath doubleFspath inch 26 in 161 if String.sub header 0 4 <> doubleMagic then 162 fail dataFspath dataPath doubleFspath "bad magic number"; 163 if String.sub header 4 4 <> doubleVersion then 164 fail dataFspath dataPath doubleFspath "bad version"; 165 let numEntries = getInt2 header 24 in 166 let entries = ref [] in 167 for i = 1 to numEntries do 168 let entry = readDouble dataFspath dataPath doubleFspath inch 12 in 169 let id = getID entry 0 in 170 let ofs = getInt4 entry 4 in 171 let len = getInt4 entry 8 in 172 entries := (id, (ofs, len)) :: !entries 173 done; 174 (doubleFspath, inch, !entries))) 175 (fun () -> close_in_noerr inch) 176 177 (****) 178 179 type 'a ressInfo = 180 NoRess 181 | HfsRess of Uutil.Filesize.t 182 | AppleDoubleRess of int * float * float * Uutil.Filesize.t * 'a 183 184 let mressInfo m = Umarshal.(sum3 unit Uutil.Filesize.m 185 (prod5 int float float Uutil.Filesize.m m id id) 186 (function 187 | NoRess -> I31 () 188 | HfsRess a -> I32 a 189 | AppleDoubleRess (a, b, c, d, e) -> I33 (a, b, c, d, e)) 190 (function 191 | I31 () -> NoRess 192 | I32 a -> HfsRess a 193 | I33 (a, b, c, d, e) -> AppleDoubleRess (a, b, c, d, e))) 194 195 type ressStamp = unit ressInfo 196 197 let mressStamp = mressInfo Umarshal.unit 198 199 let ressStampToString r = 200 match r with 201 NoRess -> 202 "NoRess" 203 | HfsRess len -> 204 Format.sprintf "Hfs(%s)" (Uutil.Filesize.toString len) 205 | AppleDoubleRess (ino, mtime, ctime, len, _) -> 206 Format.sprintf "Hfs(%d,%f,%f,%s)" 207 ino mtime ctime (Uutil.Filesize.toString len) 208 209 type info = 210 { ressInfo : (Fspath.t * int64) ressInfo; 211 finfo : string } 212 213 let minfo = Umarshal.(prod2 (mressInfo (prod2 Fspath.m int64 id id)) string 214 (fun {ressInfo; finfo} -> ressInfo, finfo) 215 (fun (ressInfo, finfo) -> {ressInfo; finfo})) 216 217 external getFileInfosInternal : 218 string -> bool -> string * int64 = "getFileInfos" 219 external setFileInfosInternal : 220 string -> string -> unit = "setFileInfos" 221 222 let defaultInfos typ = 223 match typ with 224 `FILE -> { ressInfo = NoRess; finfo = "F" } 225 | `DIRECTORY -> { ressInfo = NoRess; finfo = "D" } 226 | _ -> { ressInfo = NoRess; finfo = "" } 227 228 (* BCP: dead code 229 let noTypeCreator = String.make 10 '\000' *) 230 231 (* Remove trailing zeroes *) 232 let trim s = 233 let rec trim_rec s pos = 234 if pos > 0 && s.[pos - 1] = '\000' then 235 trim_rec s (pos - 1) 236 else 237 String.sub s 0 pos 238 in 239 trim_rec s (String.length s) 240 241 let extractInfo typ info = 242 let flags = Bytes.of_string (String.sub info 8 2) in 243 let xflags = String.sub info 24 2 in 244 let typeCreator = String.sub info 0 8 in 245 (* Ignore hasBeenInited flag *) 246 Bytes.set flags 0 (Char.chr (Char.code (Bytes.get flags 0) land 0xfe)); 247 (* If the extended flags should be ignored, clear them *) 248 let xflags = 249 if Char.code xflags.[0] land 0x80 <> 0 then "\000\000" else xflags 250 in 251 let info = 252 match typ with 253 `FILE -> "F" ^ typeCreator ^ Bytes.to_string flags ^ xflags 254 | `DIRECTORY -> "D" ^ Bytes.to_string flags ^ xflags 255 in 256 trim info 257 258 let getFileInfos dataFspath dataPath typ = 259 if not (Prefs.read rsrc) then defaultInfos typ else 260 match typ with 261 (`FILE | `DIRECTORY) as typ -> 262 Util.convertUnixErrorsToTransient "getting file information" (fun () -> 263 try 264 let (fInfo, rsrcLength) = 265 getFileInfosInternal 266 (Fspath.toString (Fspath.concat dataFspath dataPath)) 267 (typ = `FILE) 268 in 269 { ressInfo = 270 if rsrcLength = 0L then NoRess 271 else HfsRess (Uutil.Filesize.ofInt64 rsrcLength); 272 finfo = extractInfo typ fInfo } 273 with Unix.Unix_error ((Unix.EOPNOTSUPP | Unix.ENOSYS), _, _) -> 274 (* Not a HFS volume. Look for an AppleDouble file *) 275 try 276 let (workingDir, realPath) = 277 try Fspath.findWorkingDir dataFspath dataPath with 278 | Util.Transient _ -> raise Not_found in 279 let (doubleFspath, inch, entries) = 280 openDouble workingDir realPath in 281 let (rsrcOffset, rsrcLength) = 282 try 283 let (offset, len) = Safelist.assoc `RSRC entries in 284 (* We need to check that the resource fork is not a 285 dummy one included for compatibility reasons *) 286 if len = 286L && 287 protect (fun () -> 288 LargeFile.seek_in inch (Int64.add offset 16L); 289 let len = String.length resource_fork_empty_tag in 290 let buf = Bytes.create len in 291 really_input inch buf 0 len; 292 Bytes.to_string buf = resource_fork_empty_tag) 293 (fun () -> close_in_noerr inch) 294 then 295 (0L, 0L) 296 else 297 (offset, len) 298 with Not_found -> 299 (0L, 0L) 300 in 301 debug (fun () -> 302 Util.msg 303 "AppleDouble for file %s / %s: resource fork length: %d\n" 304 (Fspath.toDebugString dataFspath) (Path.toString dataPath) 305 (Int64.to_int rsrcLength)); 306 let finfo = 307 protect (fun () -> 308 try 309 let (ofs, len) = Safelist.assoc `FINFO entries in 310 if len < finfoLength then 311 fail dataFspath dataPath doubleFspath "bad finder info"; 312 readDoubleFromOffset 313 dataFspath dataPath doubleFspath inch ofs 32 314 with Not_found -> 315 String.make 32 '\000') 316 (fun () -> close_in_noerr inch) 317 in 318 close_in inch; 319 let stats = 320 Util.convertUnixErrorsToTransient "stating AppleDouble file" 321 (fun () -> Fs.stat doubleFspath) in 322 { ressInfo = 323 if rsrcLength = 0L then NoRess else 324 AppleDoubleRess 325 (begin 326 if Sys.win32 || Sys.cygwin then 0 327 else (* The inode number is truncated so that 328 it fits in a 31 bit ocaml integer *) 329 stats.Unix.LargeFile.st_ino land 0x3FFFFFFF 330 end, 331 stats.Unix.LargeFile.st_mtime, 332 0., 333 Uutil.Filesize.ofInt64 rsrcLength, 334 (doubleFspath, rsrcOffset)); 335 finfo = extractInfo typ finfo } 336 with Not_found -> 337 defaultInfos typ) 338 | _ -> 339 defaultInfos typ 340 341 let zeroes = String.make 13 '\000' 342 343 let insertInfo fullInfo info = 344 let info = info ^ zeroes in 345 let isFile = info.[0] = 'F' in 346 let offset = if isFile then 9 else 1 in 347 (* Type and creator *) 348 if isFile then String.blit info 1 fullInfo 0 8; 349 (* Finder flags *) 350 String.blit info offset fullInfo 8 2; 351 (* Extended finder flags *) 352 String.blit info (offset + 2) fullInfo 24 2; 353 Bytes.to_string fullInfo 354 355 let setFileInfos dataFspath dataPath finfo = 356 assert (finfo <> ""); 357 Util.convertUnixErrorsToTransient "setting file information" (fun () -> 358 try 359 let p = Fspath.toString (Fspath.concat dataFspath dataPath) in 360 let (fullFinfo, _) = getFileInfosInternal p false in 361 setFileInfosInternal p (insertInfo (Bytes.of_string fullFinfo) finfo) 362 with Unix.Unix_error ((EOPNOTSUPP | ENOSYS | EUNKNOWNERR 93), _, _) -> 363 (* ENOATTR (93) is returned on msdos/exfat fs since macOS 13 *) 364 (* Not an HFS volume. Look for an AppleDouble file *) 365 let (workingDir, realPath) = Fspath.findWorkingDir dataFspath dataPath in 366 begin try 367 let (doubleFspath, inch, entries) = openDouble workingDir realPath in 368 begin try 369 let (ofs, len) = Safelist.assoc `FINFO entries in 370 if len < finfoLength then begin 371 close_in_noerr inch; 372 fail dataFspath dataPath doubleFspath "bad finder info" 373 end; 374 let fullFinfo = 375 protect 376 (fun () -> 377 let res = 378 readDoubleFromOffset 379 dataFspath dataPath doubleFspath inch ofs 32 in 380 close_in inch; 381 res) 382 (fun () -> close_in_noerr inch) 383 |> Bytes.of_string 384 in 385 let outch = 386 Fs.open_out_gen [Open_wronly; Open_binary] 0o600 doubleFspath in 387 protect 388 (fun () -> 389 writeDoubleFromOffset outch ofs (insertInfo fullFinfo finfo); 390 close_out outch) 391 (fun () -> 392 close_out_noerr outch); 393 with Not_found -> 394 close_in_noerr inch; 395 raise (Util.Transient 396 (Format.sprintf 397 "Unable to set the file type and creator: \n\ 398 The AppleDouble file '%s' has no fileinfo entry." 399 (Fspath.toPrintString doubleFspath))) 400 end 401 with Not_found -> 402 (* No AppleDouble file, create one if needed. *) 403 if finfo <> "F" && finfo <> "D" then begin 404 let doubleFspath = 405 Fspath.appleDouble (Fspath.concat workingDir realPath) in 406 let outch = 407 Fs.open_out_gen 408 [Open_wronly; Open_creat; Open_excl; Open_binary] 0o600 409 doubleFspath 410 in 411 (* Apparently, for compatibility with various old versions 412 of Mac OS X that did not follow the AppleDouble specification, 413 we have to include a dummy resource fork... 414 We also put an empty extended attribute section at the 415 end of the finder info section, mimicking the Mac OS X 416 kernel behavior. *) 417 protect (fun () -> 418 output_string outch doubleMagic; 419 output_string outch doubleVersion; 420 output_string outch doubleFiller; 421 output_string outch "\000\002"; (* Two entries *) 422 output_string outch "\000\000\000\009"; (* Finder info *) 423 output_string outch "\000\000\000\050"; (* offset *) 424 output_string outch "\000\000\014\176"; (* length *) 425 output_string outch "\000\000\000\002"; (* Resource fork *) 426 output_string outch "\000\000\014\226"; (* offset *) 427 output_string outch "\000\000\001\030"; (* length *) 428 output_string outch (insertInfo (emptyFinderInfo ()) finfo); 429 output_string outch (empty_attribute_chunk ()); 430 (* extended attributes *) 431 output_string outch empty_resource_fork; 432 close_out outch) 433 (fun () -> close_out_noerr outch) 434 end 435 end) 436 437 let ressUnchanged info info' t0 dataUnchanged = 438 match info, info' with 439 NoRess, NoRess -> 440 true 441 | HfsRess len, HfsRess len' -> 442 dataUnchanged && len = len' 443 | AppleDoubleRess (ino, mt, ct, _, _), 444 AppleDoubleRess (ino', mt', ct', _, _) -> 445 ino = ino' && mt = mt' && ct = ct' && 446 if Some mt' <> t0 then 447 true 448 else begin 449 begin try 450 Unix.sleep 1 451 with Unix.Unix_error _ -> () end; 452 false 453 end 454 | _ -> 455 false 456 457 (****) 458 459 let name1 = Name.fromString "..namedfork" 460 let name2 = Name.fromString "rsrc" 461 let ressPath p = Path.child (Path.child p name1) name2 462 463 let stamp info = 464 match info.ressInfo with 465 NoRess -> 466 NoRess 467 | (HfsRess len) as s -> 468 s 469 | AppleDoubleRess (inode, mtime, ctime, len, _) -> 470 AppleDoubleRess (inode, mtime, ctime, len, ()) 471 472 let ressFingerprint fspath path typ = 473 (* This function used to get ready-made info passed in. (Re-)getting the 474 info here may consume one or a few additional syscalls. This is not 475 thought to be a problem unless there are hundreds of thousands of files 476 with resource forks. That is really unlikely. *) 477 let info = getFileInfos fspath path typ in 478 match info.ressInfo with 479 NoRess -> 480 Fingerprint.dummy 481 | HfsRess _ -> 482 Fingerprint.file fspath (ressPath path) 483 | AppleDoubleRess (_, _, _, len, (path, offset)) -> 484 debug (fun () -> 485 Util.msg "resource fork fingerprint: path %s, offset %d, len %d" 486 (Fspath.toString path) 487 (Int64.to_int offset) (Uutil.Filesize.toInt len)); 488 Fingerprint.subfile path offset len 489 490 let ressLength ress = 491 match ress with 492 NoRess -> Uutil.Filesize.zero 493 | HfsRess len -> len 494 | AppleDoubleRess (_, _, _, len, _) -> len 495 496 let ressDummy = NoRess 497 498 (****) 499 500 let openRessIn fspath path = 501 Util.convertUnixErrorsToTransient "reading resource fork" (fun () -> 502 try 503 Unix.in_channel_of_descr 504 (Fs.openfile 505 (Fspath.concat fspath (ressPath path)) 506 [Unix.O_RDONLY; O_CLOEXEC] 0o444) 507 with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> 508 let (doublePath, inch, entries) = openDouble fspath path in 509 try 510 let (rsrcOffset, rsrcLength) = Safelist.assoc `RSRC entries in 511 protect (fun () -> LargeFile.seek_in inch rsrcOffset) 512 (fun () -> close_in_noerr inch); 513 inch 514 with Not_found -> 515 close_in_noerr inch; 516 raise (Util.Transient "No resource fork found")) 517 518 let openRessOut fspath path length = 519 Util.convertUnixErrorsToTransient "writing resource fork" (fun () -> 520 try 521 let p = Fspath.concat fspath (ressPath path) in 522 debug (fun () -> Util.msg "openRessOut %s\n" (Fspath.toString p)); 523 Unix.out_channel_of_descr 524 (Fs.openfile p [Unix.O_WRONLY; O_CREAT; O_CLOEXEC] 0o600) 525 with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> 526 debug (fun () -> Util.msg "Opening AppleDouble file for resource fork\n"); 527 let path = Fspath.appleDouble (Fspath.concat fspath path) in 528 let outch = 529 Fs.open_out_gen 530 [Open_wronly; Open_creat; Open_excl; Open_binary] 0o600 path 531 in 532 protect (fun () -> 533 output_string outch doubleMagic; 534 output_string outch doubleVersion; 535 output_string outch doubleFiller; 536 output_string outch "\000\002"; (* Two entries *) 537 output_string outch "\000\000\000\009"; (* Finder info *) 538 output_string outch "\000\000\000\050"; (* offset *) 539 output_string outch "\000\000\014\176"; (* length *) 540 output_string outch "\000\000\000\002"; (* Resource fork *) 541 output_string outch "\000\000\014\226"; (* offset *) 542 (* FIX: should check for overflow! *) 543 output_bytes outch (setInt4 (Uutil.Filesize.toInt64 length)); 544 (* length *) 545 output_bytes outch (emptyFinderInfo ()); 546 output_string outch (empty_attribute_chunk ()); 547 (* extended attributes *) 548 flush outch) 549 (fun () -> close_out_noerr outch); 550 outch)