fileinfo.ml (11118B)
1 (* Unison file synchronizer: src/fileinfo.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 let debugV = Util.debug "fileinfo+" 20 21 let allowSymlinks = 22 Prefs.createBoolWithDefault "links" 23 ~category:(`Advanced `Sync) 24 "allow the synchronization of symbolic links (true/false/default)" 25 ("When set to {\\tt true}, this flag causes Unison to synchronize \ 26 symbolic links. When the flag is set to {\\tt false}, symbolic \ 27 links will be ignored during update detection. \ 28 Ordinarily, when the flag is set to {\\tt default}, symbolic \ 29 links are synchronized except when one of the hosts is running \ 30 Windows. On a Windows client, Unison makes an attempt to detect \ 31 if symbolic links are supported and allowed by user privileges. \ 32 You may have to get elevated privileges to create symbolic links. \ 33 When the flag is set to {\\tt default} and symbolic links can't be \ 34 synchronized then an error is produced during update detection.") 35 36 let symlinksAllowed = 37 Prefs.createBool "links-aux" true 38 ~category:(`Internal `Pseudo) 39 "*Pseudo-preference for internal use only" "" 40 41 let init b = 42 Prefs.set symlinksAllowed 43 (Prefs.read allowSymlinks = `True || 44 (Prefs.read allowSymlinks = `Default && 45 (not b || System.hasSymlink ()))) 46 47 type typ = [ `ABSENT | `FILE | `DIRECTORY | `SYMLINK ] 48 49 let mtyp = Umarshal.(sum4 unit unit unit unit 50 (function 51 | `ABSENT -> I41 () 52 | `FILE -> I42 () 53 | `DIRECTORY -> I43 () 54 | `SYMLINK -> I44 ()) 55 (function 56 | I41 () -> `ABSENT 57 | I42 () -> `FILE 58 | I43 () -> `DIRECTORY 59 | I44 () -> `SYMLINK)) 60 61 let type2string = function 62 `ABSENT -> "nonexistent" 63 | `FILE -> "file" 64 | `DIRECTORY -> "dir" 65 | `SYMLINK -> "symlink" 66 67 (* IMPORTANT! 68 This is the 2.51-compatible version of type [Fileinfo.t]. It must always 69 remain exactly the same as the type [Fileinfo.t] in version 2.51.5. This 70 means that if any of the types it is composed of changes then for each 71 changed type also a 2.51-compatible version must be created. *) 72 type t251 = { typ : typ; inode : int; desc : Props.t251; osX : Osx.info} 73 74 type ('a, 'b) info = { typ : typ; inode : int; desc : 'a; osX : Osx.info } 75 constraint 'a = _ Props.props 76 type t = (Props.t, [`WithRess]) info 77 type basic = (Props.basic, [`NoRess]) info 78 type bress = (Props.basic, [`WithRess]) info 79 80 let minfo propsm = Umarshal.(prod4 mtyp int propsm Osx.minfo 81 (fun {typ; inode; desc; osX} -> typ, inode, desc, osX) 82 (fun (typ, inode, desc, osX) -> {typ; inode; desc; osX})) 83 84 let m = minfo Props.m 85 let mbasic = minfo Props.mbasic 86 87 let to_compat251 (x : basic) : t251 = 88 { typ = x.typ; 89 inode = x.inode; 90 desc = Props.to_compat251 x.desc; 91 osX = x.osX } 92 93 let of_compat251 (x : t251) : basic = 94 { typ = x.typ; 95 inode = x.inode; 96 desc = Props.of_compat251 x.desc; 97 osX = x.osX } 98 99 (* Stat function that pays attention to pref for following links *) 100 let statFn fromRoot fspath path = 101 let fullpath = Fspath.concat fspath path in 102 let stats = Fs.lstat fullpath in 103 if stats.Unix.LargeFile.st_kind = Unix.S_LNK 104 && fromRoot 105 && Path.followLink path 106 then begin 107 Fswatch.followLink path; 108 try Fs.stat fullpath 109 with Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) -> 110 raise (Util.Transient (Printf.sprintf 111 "Path %s is marked 'follow' but its target is missing" 112 (Fspath.toPrintString fullpath))) 113 end else 114 stats 115 116 (* Warning! Do not change this string without some backwards compatibility 117 code in place. This string is not only meant for humans, it is also 118 processed by code. *) 119 let symlinkErr = " is a symbolic link" 120 let symlinkErrLen = String.length symlinkErr 121 122 let shouldIgnore s = 123 Prefs.read allowSymlinks = `False && 124 let l = String.length s in 125 if l > symlinkErrLen then 126 String.sub s (l - symlinkErrLen) symlinkErrLen = symlinkErr 127 else 128 false 129 130 let getAux fromRoot fspath path getProps = 131 Util.convertUnixErrorsToTransient 132 "querying file information" 133 (fun () -> 134 try 135 let stats = statFn fromRoot fspath path in 136 debugV (fun () -> 137 Util.msg "%s: %b %f %f\n" 138 (Fspath.toDebugString (Fspath.concat fspath path)) 139 fromRoot stats.Unix.LargeFile.st_ctime stats.Unix.LargeFile.st_mtime); 140 let typ = 141 match stats.Unix.LargeFile.st_kind with 142 Unix.S_REG -> Util.debug "fileinfo+" (fun () -> Util.msg "get: FILE\n"); `FILE 143 | Unix.S_DIR -> `DIRECTORY 144 | Unix.S_LNK -> 145 if not fromRoot || Prefs.read symlinksAllowed then 146 `SYMLINK 147 else 148 raise 149 (Util.Transient 150 ("path " ^ 151 (Fspath.toPrintString (Fspath.concat fspath path)) ^ 152 symlinkErr)) 153 | _ -> 154 raise (Util.Transient 155 ("path " ^ 156 (Fspath.toPrintString (Fspath.concat fspath path)) ^ 157 " has unknown file type")) 158 in 159 let osxInfos = Osx.getFileInfos fspath path typ in 160 { typ = typ; 161 inode = (* The inode number is truncated so that 162 it fits in a 31 bit ocaml integer *) 163 stats.Unix.LargeFile.st_ino land 0x3FFFFFFF; 164 desc = getProps fspath path stats osxInfos; 165 osX = osxInfos } 166 with 167 Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) -> 168 { typ = `ABSENT; 169 inode = 0; 170 desc = Props.dummy; 171 osX = Osx.getFileInfos fspath path `ABSENT }) 172 173 let getType fromRoot fspath path = 174 (getAux fromRoot fspath path (fun _ _ _ _ -> Props.dummy)).typ 175 176 let getBasic fromRoot fspath path = 177 getAux fromRoot fspath path (fun _ _ st _ -> Props.get' st) 178 179 let getBasicWithRess fromRoot fspath path = 180 getAux fromRoot fspath path (fun _ _ st i -> Props.getWithRess st i) 181 182 let get ?(archProps = Props.dummy) fromRoot fspath path = 183 let getProps fspath path stats typ = 184 Props.get ~archProps fspath path stats typ in 185 getAux fromRoot fspath path getProps 186 187 let basic x = 188 { typ = x.typ; 189 inode = x.inode; 190 desc = x.desc; 191 osX = x.osX } 192 193 let check fspath path props = 194 Util.convertUnixErrorsToTransient 195 "checking file information" 196 (fun () -> Props.check fspath path (statFn false fspath path) props) 197 198 let set fspath path action newDesc = 199 let (kind, p) = 200 match action with 201 `Set defDesc -> 202 (* Set the permissions and maybe the other properties *) 203 (* BCP [Nov 2008]: Jerome, in a message to unison-hackers on 204 Oct 5, 2005, suggested that this would be better as 205 `Set, Props.override (get false fspath path).desc newDesc 206 but this does not seem right to me (bcp): if the file was just 207 created, then its permissions are something like 0x600, whereas 208 the default permissions will set the world read bit, etc. *) 209 `Set, Props.override defDesc newDesc 210 | `Copy oldPath -> 211 (* Set the permissions (using the permissions of the file at *) 212 (* [oldPath] as a default) and maybe the other properties *) 213 `Set, Props.override (get false fspath oldPath).desc newDesc 214 | `Update oldDesc -> 215 (* Update the different properties (only if necessary) *) 216 `Update, 217 Props.override 218 (get false fspath path).desc (Props.diff oldDesc newDesc) 219 in 220 Props.set fspath path kind p; 221 check fspath path p 222 223 (* IMPORTANT! 224 This is the 2.51-compatible version of type [Fileinfo.stamp]. It must 225 always remain exactly the same as the type [Fileinfo.stamp] in version 226 2.51.5. *) 227 type stamp251 = 228 InodeStamp of int (* inode number, for Unix systems *) 229 | CtimeStamp of float (* creation time, for windows systems *) 230 231 type stamp = 232 | InodeStamp of int (* inode number, for Unix systems *) 233 | NoStamp 234 | RescanStamp (* stamp indicating file should be rescanned 235 (perhaps because previous transfer failed) *) 236 237 let mstamp = Umarshal.(sum3 int unit unit 238 (function 239 | InodeStamp a -> I31 a 240 | NoStamp -> I32 () 241 | RescanStamp -> I33 ()) 242 (function 243 | I31 a -> InodeStamp a 244 | I32 () -> NoStamp 245 | I33 () -> RescanStamp)) 246 247 let stamp_to_compat251 (st : stamp) : stamp251 = 248 match st with 249 | InodeStamp i -> InodeStamp i 250 | NoStamp -> CtimeStamp 0.0 251 | RescanStamp -> InodeStamp (-1) 252 253 let stamp_of_compat251 (st : stamp251) : stamp = 254 match st with 255 | InodeStamp i -> if i <> -1 then InodeStamp i else RescanStamp 256 | CtimeStamp _ -> NoStamp 257 258 let ignoreInodeNumbers = 259 Prefs.createBool "ignoreinodenumbers" false 260 ~category:(`Advanced `Syncprocess) 261 "ignore inode number changes when detecting updates" 262 ("When set to true, this preference makes Unison not take advantage \ 263 of inode numbers during fast update detection. \ 264 This switch should be used with care, as it \ 265 is less safe than the standard update detection method, but it \ 266 can be useful with filesystems which do not support inode numbers.") 267 let _ = Prefs.alias ignoreInodeNumbers "pretendwin" 268 269 let stamp info = 270 if Prefs.read ignoreInodeNumbers then NoStamp else 271 if Fs.hasInodeNumbers () then InodeStamp info.inode else NoStamp 272 273 let ressStamp info = Osx.stamp info.osX 274 275 let unchanged fspath path info = 276 (* The call to [Util.time] must be before the call to [get] *) 277 let t0 = Util.time () in 278 let info' = get ~archProps:info.desc true fspath path in 279 let dataUnchanged = 280 Props.same_time info.desc info'.desc 281 && 282 stamp info = stamp info' 283 && 284 if Props.time info'.desc = t0 then begin 285 Unix.sleep 1; 286 false 287 end else 288 true 289 in 290 (info', dataUnchanged, 291 Osx.ressUnchanged info.osX.Osx.ressInfo info'.osX.Osx.ressInfo 292 (Some t0) dataUnchanged)