common.ml (15242B)
1 (* Unison file synchronizer: src/common.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 type hostname = string 20 21 (* Canonized roots *) 22 type host = 23 Local 24 | Remote of hostname 25 26 type root = host * Fspath.t 27 28 type 'a oneperpath = ONEPERPATH of 'a list 29 30 (* ------------------------------------------------------------------------- *) 31 (* Printing *) 32 (* ------------------------------------------------------------------------- *) 33 34 let root2hostname root = 35 match root with 36 (Local, _) -> "local" 37 | (Remote host, _) -> host 38 39 let root2string root = 40 match root with 41 (Local, fspath) -> Fspath.toPrintString fspath 42 | (Remote host, fspath) -> "//"^host^"/"^(Fspath.toPrintString fspath) 43 44 (* ------------------------------------------------------------------------- *) 45 (* Root comparison *) 46 (* ------------------------------------------------------------------------- *) 47 48 let compareRoots x y = 49 match x,y with 50 (Local,fspath1), (Local,fspath2) -> 51 (* FIX: This is a path comparison, should it take case 52 sensitivity into account ? *) 53 Fspath.compare fspath1 fspath2 54 | (Local,_), (Remote _,_) -> -1 55 | (Remote _,_), (Local,_) -> 1 56 | (Remote host1, fspath1), (Remote host2, fspath2) -> 57 let result = 58 (* FIX: Should this ALWAYS be a case insensitive compare? *) 59 compare host1 host2 in 60 if result = 0 then 61 (* FIX: This is a path comparison, should it take case 62 sensitivity into account ? *) 63 Fspath.compare fspath1 fspath2 64 else 65 result 66 67 let sortRoots rootList = Safelist.sort compareRoots rootList 68 69 (* ---------------------------------------------------------------------- *) 70 71 (* IMPORTANT! 72 This is the 2.51-compatible version of type [Common.prevState]. It must 73 always remain exactly the same as the type [Common.prevState] in version 74 2.51.5. This means that if any of the types it is composed of changes then 75 for each changed type also a 2.51-compatible version must be created. *) 76 type prevState251 = 77 Previous of Fileinfo.typ * Props.t251 * Os.fullfingerprint * Osx.ressStamp 78 | New 79 80 type prevState = 81 Previous of Fileinfo.typ * Props.t * Os.fullfingerprint * Osx.ressStamp 82 | New 83 84 let mprevState = Umarshal.(sum2 85 (prod4 Fileinfo.mtyp Props.m Os.mfullfingerprint Osx.mressStamp id id) 86 unit 87 (function 88 | Previous (a, b, c, d) -> I21 (a, b, c, d) 89 | New -> I22 ()) 90 (function 91 | I21 (a, b, c, d) -> Previous (a, b, c, d) 92 | I22 () -> New)) 93 94 (* IMPORTANT! 95 This is the 2.51-compatible version of type [Common.contentschange]. It 96 must always remain exactly the same as the type [Common.contentschange] 97 in version 2.51.5. This means that if any of the types it is composed of 98 changes then for each changed type also a 2.51-compatible version must be 99 created. *) 100 type contentschange251 = 101 ContentsSame 102 | ContentsUpdated of Os.fullfingerprint * Fileinfo.stamp251 * Osx.ressStamp 103 104 type contentschange = 105 ContentsSame 106 | ContentsUpdated of Os.fullfingerprint * Fileinfo.stamp * Osx.ressStamp 107 108 let mcontentschange = Umarshal.(sum2 unit (prod3 Os.mfullfingerprint Fileinfo.mstamp Osx.mressStamp id id) 109 (function 110 | ContentsSame -> I21 () 111 | ContentsUpdated (a, b, c) -> I22 (a, b, c)) 112 (function 113 | I21 () -> ContentsSame 114 | I22 (a, b, c) -> ContentsUpdated (a, b, c))) 115 116 type permchange = PropsSame | PropsUpdated 117 118 let mpermchange = Umarshal.(sum2 unit unit 119 (function 120 | PropsSame -> I21 () 121 | PropsUpdated -> I22 ()) 122 (function 123 | I21 () -> PropsSame 124 | I22 () -> PropsUpdated)) 125 126 (* IMPORTANT! 127 These are the 2.51-compatible versions of types [Common.updateItem] and 128 [Common.updateContent]. They must always remain exactly the same as the 129 types [Common.updateItem] and [Common.updateContent] in version 2.51.5. 130 This means that if any of the types they are composed of changes then 131 for each changed type also a 2.51-compatible version must be created. *) 132 type updateItem251 = 133 NoUpdates (* Path not changed *) 134 | Updates (* Path changed in this replica *) 135 of updateContent251 (* - new state *) 136 * prevState251 (* - summary of old state *) 137 | Error (* Error while detecting updates *) 138 of string (* - description of error *) 139 140 and updateContent251 = 141 Absent (* Path refers to nothing *) 142 | File (* Path refers to an ordinary file *) 143 of Props.t251 (* - summary of current state *) 144 * contentschange251 (* - hint to transport agent *) 145 | Dir (* Path refers to a directory *) 146 of Props.t251 (* - summary of current state *) 147 * (Name.t * updateItem251) list(* - children; 148 MUST KEEP SORTED for recon *) 149 * permchange (* - did permissions change? *) 150 * bool (* - is the directory now empty? *) 151 | Symlink (* Path refers to a symbolic link *) 152 of string (* - link text *) 153 154 type updateItem = 155 NoUpdates (* Path not changed *) 156 | Updates (* Path changed in this replica *) 157 of updateContent (* - new state *) 158 * prevState (* - summary of old state *) 159 | Error (* Error while detecting updates *) 160 of string (* - description of error *) 161 162 and updateContent = 163 Absent (* Path refers to nothing *) 164 | File (* Path refers to an ordinary file *) 165 of Props.t (* - summary of current state *) 166 * contentschange (* - hint to transport agent *) 167 | Dir (* Path refers to a directory *) 168 of Props.t (* - summary of current state *) 169 * (Name.t * updateItem) list (* - children; 170 MUST KEEP SORTED for recon *) 171 * permchange (* - did permissions change? *) 172 * bool (* - is the directory now empty? *) 173 | Symlink (* Path refers to a symbolic link *) 174 of string (* - link text *) 175 176 let mupdateItem_rec mupdateContent = 177 Umarshal.(sum3 unit (prod2 mupdateContent mprevState id id) string 178 (function 179 | NoUpdates -> I31 () 180 | Updates (a, b) -> I32 (a, b) 181 | Error a -> I33 a) 182 (function 183 | I31 () -> NoUpdates 184 | I32 (a, b) -> Updates (a, b) 185 | I33 a -> Error a)) 186 187 let mupdateContent_rec mupdateItem = 188 Umarshal.(sum4 189 unit 190 (prod2 Props.m mcontentschange id id) 191 (prod4 Props.m (list (prod2 Name.m mupdateItem id id)) mpermchange bool id id) 192 string 193 (function 194 | Absent -> I41 () 195 | File (a, b) -> I42 (a, b) 196 | Dir (a, b, c, d) -> I43 (a, b, c, d) 197 | Symlink a -> I44 a) 198 (function 199 | I41 () -> Absent 200 | I42 (a, b) -> File (a, b) 201 | I43 (a, b, c, d) -> Dir (a, b, c, d) 202 | I44 a -> Symlink a)) 203 204 let mupdateContent, mupdateItem = 205 Umarshal.rec2 mupdateItem_rec mupdateContent_rec 206 207 (* Compatibility conversion functions *) 208 209 let prev_to_compat251 (prev : prevState) : prevState251 = 210 match prev with 211 | Previous (typ, props, fp, ress) -> 212 Previous (typ, Props.to_compat251 props, fp, ress) 213 | New -> New 214 215 let prev_of_compat251 (prev : prevState251) : prevState = 216 match prev with 217 | Previous (typ, props, fp, ress) -> 218 Previous (typ, Props.of_compat251 props, fp, ress) 219 | New -> New 220 221 let change_to_compat251 (c : contentschange) : contentschange251 = 222 match c with 223 | ContentsSame -> ContentsSame 224 | ContentsUpdated (fp, stamp, ress) -> 225 ContentsUpdated (fp, Fileinfo.stamp_to_compat251 stamp, ress) 226 227 let change_of_compat251 (c : contentschange251) : contentschange = 228 match c with 229 | ContentsSame -> ContentsSame 230 | ContentsUpdated (fp, stamp, ress) -> 231 ContentsUpdated (fp, Fileinfo.stamp_of_compat251 stamp, ress) 232 233 let rec ui_to_compat251 (ui : updateItem) : updateItem251 = 234 match ui with 235 | NoUpdates -> NoUpdates 236 | Updates (uc, prev) -> Updates (uc_to_compat251 uc, prev_to_compat251 prev) 237 | Error s -> Error s 238 239 and ui_of_compat251 (ui : updateItem251) : updateItem = 240 match ui with 241 | NoUpdates -> NoUpdates 242 | Updates (uc, prev) -> Updates (uc_of_compat251 uc, prev_of_compat251 prev) 243 | Error s -> Error s 244 245 and children_to_compat251 l = 246 Safelist.map (fun (n, ui) -> (n, ui_to_compat251 ui)) l 247 248 and children_of_compat251 l = 249 Safelist.map (fun (n, ui) -> (n, ui_of_compat251 ui)) l 250 251 and uc_to_compat251 (uc : updateContent) : updateContent251 = 252 match uc with 253 | Absent -> Absent 254 | File (props, change) -> 255 File (Props.to_compat251 props, change_to_compat251 change) 256 | Dir (props, ch, perm, empty) -> 257 Dir (Props.to_compat251 props, children_to_compat251 ch, perm, empty) 258 | Symlink s -> Symlink s 259 260 and uc_of_compat251 (uc : updateContent251) : updateContent = 261 match uc with 262 | Absent -> Absent 263 | File (props, change) -> 264 File (Props.of_compat251 props, change_of_compat251 change) 265 | Dir (props, ch, perm, empty) -> 266 Dir (Props.of_compat251 props, children_of_compat251 ch, perm, empty) 267 | Symlink s -> Symlink s 268 269 (* ------------------------------------------------------------------------- *) 270 271 type status = 272 [ `Deleted 273 | `Modified 274 | `PropsChanged 275 | `Created 276 | `Unchanged ] 277 278 type replicaContent = 279 { typ : Fileinfo.typ; 280 status : status; 281 desc : Props.t; (* Properties (for the UI) *) 282 ui : updateItem; 283 size : int * Uutil.Filesize.t; (* Number of items and size *) 284 props : Props.t list } (* Parent properties *) 285 286 type direction = 287 Conflict of string (* The string is the reason of the conflict *) 288 | Merge 289 | Replica1ToReplica2 290 | Replica2ToReplica1 291 292 let direction2string = function 293 Conflict _ -> "conflict" 294 | Merge -> "merge" 295 | Replica1ToReplica2 -> "replica1 to replica2" 296 | Replica2ToReplica1 -> "replica2 to replica1" 297 298 let isConflict = function 299 Conflict _ -> true 300 | _ -> false 301 302 type difference = 303 { rc1 : replicaContent; 304 rc2 : replicaContent; 305 errors1 : string list; 306 errors2 : string list; 307 mutable direction : direction; 308 default_direction : direction } 309 310 type replicas = 311 Problem of string (* There was a problem during update detection *) 312 | Different of difference (* Replicas differ *) 313 314 type reconItem = {path1 : Path.t; path2 : Path.t; replicas : replicas} 315 316 let ucLength = function 317 File(desc,_) -> Props.length desc 318 | Dir(desc,_,_,_) -> Props.length desc 319 | _ -> Uutil.Filesize.zero 320 321 let uiLength = function 322 Updates(uc,_) -> ucLength uc 323 | _ -> Uutil.Filesize.zero 324 325 let riAction rc rc' = 326 match rc.status, rc'.status with 327 `Deleted, _ -> 328 `Delete 329 | (`Unchanged | `PropsChanged), (`Unchanged | `PropsChanged) -> 330 `SetProps 331 | _ -> 332 `Copy 333 334 let rcLength rc rc' = 335 if riAction rc rc' = `SetProps then 336 Uutil.Filesize.zero 337 else 338 snd rc.size 339 340 let riLength ri = 341 match ri.replicas with 342 Different {rc1 = {status= `Unchanged | `PropsChanged}; 343 rc2 = {status= `Unchanged | `PropsChanged}} -> 344 Uutil.Filesize.zero (* No contents propagated *) 345 | Different {rc1 = rc1; rc2 = rc2; direction = dir} -> 346 begin match dir with 347 Replica1ToReplica2 -> rcLength rc1 rc2 348 | Replica2ToReplica1 -> rcLength rc2 rc1 349 | Conflict _ -> Uutil.Filesize.zero 350 | Merge -> Uutil.Filesize.zero (* underestimate :-*) 351 end 352 | _ -> 353 Uutil.Filesize.zero 354 355 let fileInfos ui1 ui2 = 356 match ui1, ui2 with 357 (Updates (File (desc1, ContentsUpdated (fp1, _, ress1)), 358 Previous (`FILE, desc2, fp2, ress2)), 359 NoUpdates) 360 | (Updates (File (desc1, ContentsUpdated (fp1, _, ress1)), 361 Previous (`FILE, desc2, fp2, ress2)), 362 Updates (File (_, ContentsSame), _)) 363 | (NoUpdates, 364 Updates (File (desc2, ContentsUpdated (fp2, _, ress2)), 365 Previous (`FILE, desc1, fp1, ress1))) 366 | (Updates (File (_, ContentsSame), _), 367 Updates (File (desc2, ContentsUpdated (fp2, _, ress2)), 368 Previous (`FILE, desc1, fp1, ress1))) 369 | (Updates (File (desc1, ContentsUpdated (fp1, _, ress1)), _), 370 Updates (File (desc2, ContentsUpdated (fp2, _, ress2)), _)) -> 371 (desc1, fp1, ress1, desc2, fp2, ress2) 372 | _ -> 373 raise (Util.Transient "Can't diff") 374 375 let problematic ri = 376 match ri.replicas with 377 Problem _ -> true 378 | Different diff -> isConflict diff.direction 379 380 let partiallyProblematic ri = 381 match ri.replicas with 382 Problem _ -> 383 true 384 | Different diff -> 385 isConflict diff.direction || diff.errors1 <> [] || diff.errors2 <> [] 386 387 let isDeletion ri = 388 match ri.replicas with 389 Different {rc1 = rc1; rc2 = rc2; direction = rDir} -> 390 (match rDir, rc1.typ, rc2.typ with 391 Replica1ToReplica2, `ABSENT, _ -> true 392 | Replica2ToReplica1, _, `ABSENT -> true 393 | _ -> false) 394 | _ -> false 395 396 let rcType rc = Fileinfo.type2string rc.typ 397 398 let riFileType ri = 399 match ri.replicas with 400 Different {rc1 = rc1; rc2 = rc2; default_direction = dir} -> 401 begin match dir with 402 Replica2ToReplica1 -> rcType rc2 403 | _ -> rcType rc1 404 end 405 | _ -> "nonexistent"