os.ml (14043B)
1 (* Unison file synchronizer: src/os.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 (* This file attempts to isolate operating system specific details from the *) 20 (* rest of the program. *) 21 22 let debug = Util.debug "os" 23 24 (* Assumption: Prefs are not loaded on server, so clientHostName is always *) 25 (* set to myCanonicalHostName. *) 26 27 let localCanonicalHostName = 28 try System.getenv "UNISONLOCALHOSTNAME" 29 with Not_found -> Unix.gethostname() 30 31 let clientHostName : string Prefs.t = 32 Prefs.createString "clientHostName" localCanonicalHostName 33 ~category:(`Advanced `Remote) 34 "set host name of client" 35 ("When specified, the host name of the client will not be guessed " ^ 36 "and the provided host name will be used to find the archive.") 37 38 let serverHostName = localCanonicalHostName 39 40 let myCanonicalHostName () = 41 if !Trace.runningasserver then serverHostName else Prefs.read clientHostName 42 43 let tempFilePrefix = ".unison." 44 let tempFileSuffixFixed = ".unison.tmp" 45 let tempFileSuffix = ref tempFileSuffixFixed 46 let includeInTempNames s = 47 (* BCP: Added this in Jan 08. If (as I believe) it never fails, then this tricky 48 stuff can be deleted. *) 49 assert (s<>""); 50 tempFileSuffix := 51 if s = "" then tempFileSuffixFixed 52 else "." ^ s ^ tempFileSuffixFixed 53 54 let isTempFile file = 55 Util.endswith file tempFileSuffixFixed && 56 Util.startswith file tempFilePrefix 57 58 (*****************************************************************************) 59 (* QUERYING THE FILESYSTEM *) 60 (*****************************************************************************) 61 62 let exists fspath path = 63 Fileinfo.getType false fspath path <> `ABSENT 64 65 let readLink fspath path = 66 Util.convertUnixErrorsToTransient 67 "reading symbolic link" 68 (fun () -> 69 let abspath = Fspath.concat fspath path in 70 let l = Fs.readlink abspath in 71 if Sys.win32 || Sys.cygwin then 72 Fileutil.backslashes2forwardslashes l 73 else 74 l 75 ) 76 77 let rec isAppleDoubleFile file = 78 Prefs.read Osx.rsrc && 79 String.length file > 2 && file.[0] = '.' && file.[1] = '_' 80 81 (* Assumes that (fspath, path) is a directory, and returns the list of *) 82 (* children, except for '.' and '..'. *) 83 let allChildrenOf fspath path = 84 Util.convertUnixErrorsToTransient 85 "scanning directory" 86 (fun () -> 87 let rec loop children directory = 88 let newFile = try directory.Fs.readdir () with End_of_file -> "" in 89 if newFile = "" then children else 90 let newChildren = 91 if newFile = "." || newFile = ".." then 92 children 93 else 94 Name.fromString newFile :: children in 95 loop newChildren directory 96 in 97 let absolutePath = Fspath.concat fspath path in 98 let directory = 99 try 100 Some (Fs.opendir absolutePath) 101 with Unix.Unix_error (Unix.ENOENT, _, _) -> 102 (* FIX (in Ocaml): under Windows, when a directory is empty 103 (not even "." and ".."), FindFirstFile fails with 104 ERROR_FILE_NOT_FOUND while ocaml expects the error 105 ERROR_NO_MORE_FILES *) 106 None 107 in 108 match directory with 109 Some directory -> 110 begin try 111 let result = loop [] directory in 112 directory.Fs.closedir (); 113 result 114 with Unix.Unix_error _ as e -> 115 begin try 116 directory.Fs.closedir () 117 with Unix.Unix_error _ -> () end; 118 raise e 119 end 120 | None -> 121 []) 122 123 (* Assumes that (fspath, path) is a directory, and returns the list of *) 124 (* children, except for temporary files and AppleDouble files. *) 125 let rec childrenOf fspath path = 126 List.filter 127 (fun filename -> 128 let file = Name.toString filename in 129 if isAppleDoubleFile file then 130 false 131 (* does it belong to here ? *) 132 (* else if Util.endswith file backupFileSuffix then begin *) 133 (* let newPath = Path.child path filename in *) 134 (* removeBackupIfUnwanted fspath newPath; *) 135 (* false *) 136 (* end *) 137 else if isTempFile file then begin 138 if Util.endswith file !tempFileSuffix then begin 139 let p = Path.child path filename in 140 let i = Fileinfo.getBasic false fspath p in 141 let secondsinthirtydays = 2592000.0 in 142 if Props.time i.Fileinfo.desc +. secondsinthirtydays < Util.time() 143 then begin 144 debug (fun()-> Util.msg "deleting old temp file %s\n" 145 (Fspath.toDebugString (Fspath.concat fspath p))); 146 delete fspath p 147 end else 148 debug (fun()-> Util.msg 149 "keeping temp file %s since it is less than 30 days old\n" 150 (Fspath.toDebugString (Fspath.concat fspath p))); 151 end; 152 false 153 end else 154 true) 155 (allChildrenOf fspath path) 156 157 (*****************************************************************************) 158 (* ACTIONS ON FILESYSTEM *) 159 (*****************************************************************************) 160 161 (* Deletes a file or a directory, but checks before if there is something *) 162 and delete fspath path = 163 Util.convertUnixErrorsToTransient 164 "deleting" 165 (fun () -> 166 let absolutePath = Fspath.concat fspath path in 167 match Fileinfo.getType false fspath path with 168 `DIRECTORY -> 169 begin try 170 Fs.chmod absolutePath 0o700 171 with Unix.Unix_error _ -> () end; 172 Safelist.iter 173 (fun child -> delete fspath (Path.child path child)) 174 (allChildrenOf fspath path); 175 Fs.rmdir absolutePath 176 | `FILE -> 177 if not Sys.unix then begin 178 try 179 Fs.chmod absolutePath 0o600; 180 with Unix.Unix_error _ -> () 181 end; 182 Fs.unlink absolutePath; 183 if Prefs.read Osx.rsrc then begin 184 let pathDouble = Fspath.appleDouble absolutePath in 185 if Fs.file_exists pathDouble then 186 Fs.unlink pathDouble 187 end 188 | `SYMLINK -> 189 (* Note that chmod would not do the right thing on links *) 190 Fs.unlink absolutePath 191 | `ABSENT -> 192 ()) 193 194 let rename fname sourcefspath sourcepath targetfspath targetpath = 195 let source = Fspath.concat sourcefspath sourcepath in 196 let source' = Fspath.toPrintString source in 197 let target = Fspath.concat targetfspath targetpath in 198 let target' = Fspath.toPrintString target in 199 if source = target then 200 raise (Util.Transient ("Rename ("^fname^"): identical source and target " ^ source')); 201 Util.convertUnixErrorsToTransient ("renaming " ^ source' ^ " to " ^ target') 202 (fun () -> 203 debug (fun() -> Util.msg "rename %s to %s\n" source' target'); 204 Fs.rename source target; 205 if Prefs.read Osx.rsrc then begin 206 let sourceDouble = Fspath.appleDouble source in 207 let targetDouble = Fspath.appleDouble target in 208 if Fs.file_exists sourceDouble then 209 Fs.rename sourceDouble targetDouble 210 else if Fs.file_exists targetDouble then 211 Fs.unlink targetDouble 212 end) 213 214 let symlink = 215 if Fs.hasSymlink () then 216 fun fspath path l -> 217 Util.convertUnixErrorsToTransient 218 "writing symbolic link" 219 (fun () -> 220 let abspath = Fspath.concat fspath path in 221 Fs.symlink l abspath) 222 else 223 fun fspath path l -> 224 raise (Util.Transient 225 (Format.sprintf 226 "Cannot create symlink \"%s\": \ 227 symlinks are not supported on this system%s" 228 (Fspath.toPrintString (Fspath.concat fspath path)) 229 (if Sys.win32 || Sys.cygwin then 230 " or elevated privileges may be required" 231 else "") 232 )) 233 234 (* Create a new directory, using the permissions from the given props *) 235 let createDir fspath path perms = 236 Util.convertUnixErrorsToTransient 237 "creating directory" 238 (fun () -> 239 let absolutePath = Fspath.concat fspath path in 240 Fs.mkdir absolutePath perms) 241 242 (*****************************************************************************) 243 (* FINGERPRINTS *) 244 (*****************************************************************************) 245 246 type fullfingerprint = Fingerprint.t * Fingerprint.t 247 248 let mfullfingerprint = Umarshal.(prod2 Fingerprint.m Fingerprint.m id id) 249 250 let fingerprint fspath path typ = 251 (Fingerprint.file fspath path, 252 Osx.ressFingerprint fspath path typ) 253 254 let pseudoFingerprint path size = 255 (Fingerprint.pseudo path size, Fingerprint.dummy) 256 257 let isPseudoFingerprint (fp,rfp) = 258 Fingerprint.ispseudo fp 259 260 (* FIX: not completely safe under Unix *) 261 (* (with networked file system such as NFS) *) 262 let safeFingerprint fspath path info optFp = 263 let rec retryLoop count info optFp optRessFp = 264 if count = 0 then 265 raise (Util.Transient 266 (Printf.sprintf 267 "Failed to fingerprint file \"%s\": \ 268 the file keeps on changing" 269 (Fspath.toPrintString (Fspath.concat fspath path)))) 270 else 271 let fp = 272 match optFp with 273 None -> Fingerprint.file fspath path 274 | Some fp -> fp 275 in 276 let ressFp = 277 match optRessFp with 278 None -> Osx.ressFingerprint fspath path info.Fileinfo.typ 279 | Some ress -> ress 280 in 281 let (info', dataUnchanged, ressUnchanged) = 282 Fileinfo.unchanged fspath path info in 283 if dataUnchanged && ressUnchanged then 284 (info', (fp, ressFp)) 285 else 286 retryLoop (count - 1) info' 287 (if dataUnchanged then Some fp else None) 288 (if ressUnchanged then Some ressFp else None) 289 in 290 retryLoop 10 info (* Maximum retries: 10 times *) 291 (match optFp with None -> None | Some (d, _) -> Some d) 292 None 293 294 let fullfingerprint_to_string (fp,rfp) = 295 Printf.sprintf "(%s,%s)" (Fingerprint.toString fp) (Fingerprint.toString rfp) 296 297 let reasonForFingerprintMismatch (fpdata,fpress) (fpdata',fpress') = 298 if fpdata = fpdata' then "resource fork" 299 else if fpress = fpress' then "file contents" 300 else "both file contents and resource fork" 301 302 let fullfingerprint_dummy = (Fingerprint.dummy,Fingerprint.dummy) 303 304 let fullfingerprintHash (fp, rfp) = 305 Fingerprint.hash fp + 31 * Fingerprint.hash rfp 306 307 let fullfingerprintEqual (fp, rfp) (fp', rfp') = 308 Fingerprint.equal fp fp' && Fingerprint.equal rfp rfp' 309 310 311 (*****************************************************************************) 312 (* UNISON DIRECTORY *) 313 (*****************************************************************************) 314 315 (* Make sure archive directory exists *) 316 let createUnisonDir() = 317 try ignore (System.stat Util.unisonDir) 318 with Unix.Unix_error(_) -> 319 Util.convertUnixErrorsToFatal 320 (Printf.sprintf "creating unison directory %s" 321 Util.unisonDir) 322 (fun () -> 323 ignore (System.mkdir Util.unisonDir 0o700)) 324 325 (*****************************************************************************) 326 (* TEMPORARY FILES *) 327 (*****************************************************************************) 328 329 (* Truncate a filename to at most [l] bytes, making sure of not 330 truncating an UTF-8 character. Assumption: [String.length s > l] *) 331 let rec truncate_filename s l = 332 if l > 0 && Char.code s.[l] land 0xC0 = 0x80 then 333 truncate_filename s (l - 1) 334 else 335 String.sub s 0 l 336 337 (* We need to be careful not to use longer temp-file names than the 338 file system permits. eCryptfs has the lowest file name length 339 limit we know of, at 143 bytes. *) 340 let maxFileNameLength = 143 341 342 (* Generates an unused fspath for a temporary file. *) 343 let genTempPath fresh fspath path prefix suffix = 344 let rec f i = 345 let s = 346 if i=0 then suffix 347 else Printf.sprintf "..%03d.%s" i suffix in 348 let tempPath = 349 match Path.deconstructRev path with 350 None -> 351 assert false 352 | Some (name, parentPath) -> 353 let name = Name.toString name in 354 let nameLen = String.length name in 355 let prefixLen = String.length prefix in 356 let suffixLen = String.length s in 357 let maxLen = maxFileNameLength - prefixLen - suffixLen in 358 let name = 359 if nameLen <= maxLen then name else 360 let nameDigest = Digest.to_hex (Digest.string name) in 361 let nameDigestLen = String.length nameDigest in 362 let maxLen = maxLen - nameDigestLen in 363 assert (maxLen>0); 364 (truncate_filename name maxLen ^ nameDigest) 365 in 366 Path.child parentPath (Name.fromString (prefix ^ name ^ s)) 367 in 368 if fresh && exists fspath tempPath then f (i + 1) else tempPath 369 in f 0 370 371 let tempPath ?(fresh=true) fspath path = 372 genTempPath fresh fspath path tempFilePrefix !tempFileSuffix