copy.ml (55098B)
1 (* Unison file synchronizer: src/copy.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 let (>>=) = Lwt.bind 19 20 let debug = Trace.debug "copy" 21 22 (****) 23 24 let protect f g = 25 try 26 f () 27 with e -> 28 begin try g () with Sys_error _ | Unix.Unix_error _ -> () end; 29 raise e 30 31 let lwt_protect f g = 32 Lwt.catch f 33 (fun e -> 34 begin try g () with Sys_error _ | Unix.Unix_error _ -> () end; 35 Lwt.fail e) 36 37 (****) 38 39 (* If newFpOpt = Some newfp, check that the current source contents 40 matches newfp. Otherwise, check whether the source file has been 41 modified during synchronization. *) 42 let checkForChangesToSourceLocal 43 fspathFrom pathFrom archDesc archFp archStamp archRess newFpOpt paranoid = 44 (* Retrieve attributes of current source file *) 45 let sourceInfo = Fileinfo.getBasicWithRess true fspathFrom pathFrom in 46 let sourceType = sourceInfo.Fileinfo.typ in 47 match newFpOpt with 48 None -> 49 (* no newfp provided: so we need to compare the archive with the 50 current source *) 51 let clearlyChanged = 52 sourceType <> `FILE 53 || Props.length sourceInfo.Fileinfo.desc <> Props.length archDesc 54 || Osx.ressLength sourceInfo.Fileinfo.osX.Osx.ressInfo <> 55 Osx.ressLength archRess in 56 let dataClearlyUnchanged = 57 not clearlyChanged 58 && Props.same_time sourceInfo.Fileinfo.desc archDesc 59 && not (Fpcache.excelFile pathFrom) 60 && match archStamp with 61 Some (Fileinfo.InodeStamp inode) -> sourceInfo.Fileinfo.inode = inode 62 | Some (Fileinfo.NoStamp) -> true 63 | Some (Fileinfo.RescanStamp) -> false 64 | None -> false in 65 let ressClearlyUnchanged = 66 not clearlyChanged 67 && Osx.ressUnchanged archRess sourceInfo.Fileinfo.osX.Osx.ressInfo 68 None dataClearlyUnchanged in 69 if dataClearlyUnchanged && ressClearlyUnchanged then begin 70 if paranoid && not (Os.isPseudoFingerprint archFp) then begin 71 let newFp = Os.fingerprint fspathFrom pathFrom sourceType in 72 if archFp <> newFp then begin 73 Update.markPossiblyUpdated fspathFrom pathFrom; 74 raise (Util.Transient (Printf.sprintf 75 "The source file %s\n\ 76 has been modified but the fast update detection mechanism\n\ 77 failed to detect it. Try running once with the fastcheck\n\ 78 option set to 'no'." 79 (Fspath.toPrintString (Fspath.concat fspathFrom pathFrom)))) 80 end 81 end 82 end else if 83 clearlyChanged 84 || archFp <> Os.fingerprint fspathFrom pathFrom sourceType 85 then 86 raise (Util.Transient (Printf.sprintf 87 "The source file %s\nhas been modified during synchronization. \ 88 Transfer aborted." 89 (Fspath.toPrintString (Fspath.concat fspathFrom pathFrom)))) 90 | Some newfp -> 91 (* newfp provided means that the archive contains a pseudo-fingerprint... *) 92 assert (Os.isPseudoFingerprint archFp); 93 (* ... so we can't compare the archive with the source; instead we 94 need to compare the current source to the new fingerprint: *) 95 if newfp <> Os.fingerprint fspathFrom pathFrom sourceType then 96 raise (Util.Transient (Printf.sprintf 97 "Current source file %s\n not same as transferred file. \ 98 Transfer aborted." 99 (Fspath.toPrintString (Fspath.concat fspathFrom pathFrom)))) 100 101 let mcheckForChangesToSource = 102 Umarshal.(prod2 103 (prod4 Path.mlocal Props.m Os.mfullfingerprint (option Fileinfo.mstamp) id id) 104 (prod3 Osx.mressStamp (option Os.mfullfingerprint) bool id id) 105 id id) 106 107 let archStamp_to_compat251 = function 108 | Some stamp -> Some (Fileinfo.stamp_to_compat251 stamp) 109 | None -> None 110 111 let archStamp_of_compat251 = function 112 | Some stamp -> Some (Fileinfo.stamp_of_compat251 stamp) 113 | None -> None 114 115 let convV0 = Remote.makeConvV0FunArg 116 (fun (fspathFrom, 117 ((pathFrom, archDesc, archFp, archStamp), (archRess, newFpOpt, paranoid))) -> 118 (fspathFrom, 119 (pathFrom, Props.to_compat251 archDesc, archFp, 120 archStamp_to_compat251 archStamp, archRess, newFpOpt, paranoid))) 121 (fun (fspathFrom, 122 (pathFrom, archDesc, archFp, archStamp, archRess, newFpOpt, paranoid)) -> 123 (fspathFrom, 124 ((pathFrom, Props.of_compat251 archDesc, archFp, 125 archStamp_of_compat251 archStamp), (archRess, newFpOpt, paranoid)))) 126 127 let checkForChangesToSourceOnRoot = 128 Remote.registerRootCmd 129 "checkForChangesToSource" ~convV0 130 mcheckForChangesToSource Umarshal.unit 131 (fun (fspathFrom, 132 ((pathFrom, archDesc, archFp, archStamp), (archRess, newFpOpt, paranoid))) -> 133 checkForChangesToSourceLocal 134 fspathFrom pathFrom archDesc archFp archStamp archRess newFpOpt paranoid; 135 Lwt.return ()) 136 137 let checkForChangesToSource 138 root pathFrom archDesc archFp archStamp archRess newFpOpt paranoid = 139 checkForChangesToSourceOnRoot 140 root ((pathFrom, archDesc, archFp, archStamp), (archRess, newFpOpt, paranoid)) 141 142 (****) 143 144 let fileIsTransferred fspathTo pathTo desc fp ress = 145 let info = Fileinfo.getBasicWithRess false fspathTo pathTo in 146 (Fileinfo.basic info, 147 info.Fileinfo.typ = `FILE 148 && 149 Props.length info.Fileinfo.desc = Props.length desc 150 && 151 Osx.ressLength info.Fileinfo.osX.Osx.ressInfo = 152 Osx.ressLength ress 153 && 154 let fp' = Os.fingerprint fspathTo pathTo info.Fileinfo.typ in 155 fp' = fp) 156 157 (* We slice the files in 1GB chunks because that's the limit for 158 Fingerprint.subfile on 32 bit architectures *) 159 let fingerprintLimit = Uutil.Filesize.ofInt64 1072693248L 160 161 let rec fingerprintPrefix fspath path offset len accu = 162 if len = Uutil.Filesize.zero then accu else begin 163 let l = min len fingerprintLimit in 164 let fp = Fingerprint.subfile (Fspath.concat fspath path) offset l in 165 fingerprintPrefix fspath path 166 (Int64.add offset (Uutil.Filesize.toInt64 l)) (Uutil.Filesize.sub len l) 167 (fp :: accu) 168 end 169 170 let fingerprintPrefixRemotely = 171 Remote.registerServerCmd 172 "fingerprintSubfile" 173 Umarshal.(prod3 Fspath.m Path.mlocal Uutil.Filesize.m id id) 174 Umarshal.(list Fingerprint.m) 175 (fun _ (fspath, path, len) -> 176 Lwt.return (fingerprintPrefix fspath path 0L len [])) 177 178 let appendThreshold = Uutil.Filesize.ofInt (1024 * 1024) 179 180 let validFilePrefix connFrom fspathFrom pathFrom fspathTo pathTo info desc = 181 let len = Props.length info.Fileinfo.desc in 182 if 183 info.Fileinfo.typ = `FILE && 184 len >= appendThreshold && len < Props.length desc 185 then begin 186 Lwt.try_bind 187 (fun () -> 188 fingerprintPrefixRemotely connFrom (fspathFrom, pathFrom, len)) 189 (fun fpFrom -> 190 let fpTo = fingerprintPrefix fspathTo pathTo 0L len [] in 191 Lwt.return (if fpFrom = fpTo then Some len else None)) 192 (fun _ -> 193 Lwt.return None) 194 end else 195 Lwt.return None 196 197 (* IMPORTANT! 198 This is the 2.51-compatible version of type [transferStatus]. It must always 199 remain exactly the same as the type [transferStatus] in version 2.51.5. This 200 means that if any of the types it is composed of changes then for each 201 changed type also a 2.51-compatible version must be created. *) 202 type transferStatus251 = 203 TransferSucceeded of Fileinfo.t251 204 | TransferNeedsDoubleCheckAgainstCurrentSource of Fileinfo.t251 * Os.fullfingerprint 205 | TransferFailed of string 206 207 type transferStatus = 208 TransferSucceeded of Fileinfo.basic 209 | TransferNeedsDoubleCheckAgainstCurrentSource of Fileinfo.basic * Os.fullfingerprint 210 | TransferFailed of string 211 212 let mtransferStatus = Umarshal.(sum3 213 Fileinfo.mbasic 214 (prod2 Fileinfo.mbasic Os.mfullfingerprint id id) 215 string 216 (function 217 | TransferSucceeded a -> I31 a 218 | TransferNeedsDoubleCheckAgainstCurrentSource (a, b) -> I32 (a, b) 219 | TransferFailed a -> I33 a) 220 (function 221 | I31 a -> TransferSucceeded a 222 | I32 (a, b) -> TransferNeedsDoubleCheckAgainstCurrentSource (a, b) 223 | I33 a -> TransferFailed a)) 224 225 let transferStatus_to_compat251 (st : transferStatus) : transferStatus251 = 226 match st with 227 | TransferSucceeded info -> TransferSucceeded (Fileinfo.to_compat251 info) 228 | TransferNeedsDoubleCheckAgainstCurrentSource (info, fp) -> 229 TransferNeedsDoubleCheckAgainstCurrentSource (Fileinfo.to_compat251 info, fp) 230 | TransferFailed s -> TransferFailed s 231 232 let transferStatus_of_compat251 (st : transferStatus251) : transferStatus = 233 match st with 234 | TransferSucceeded info -> TransferSucceeded (Fileinfo.of_compat251 info) 235 | TransferNeedsDoubleCheckAgainstCurrentSource (info, fp) -> 236 TransferNeedsDoubleCheckAgainstCurrentSource (Fileinfo.of_compat251 info, fp) 237 | TransferFailed s -> TransferFailed s 238 239 (* Paranoid check: recompute the transferred file's fingerprint to match it 240 with the archive's. If the old 241 fingerprint was a pseudo-fingerprint, we can't tell just from looking at the 242 new file and the archive information, so we return 243 TransferProbablySucceeded in this case, along with the new fingerprint 244 that we can check in checkForChangesToSource when we've 245 calculated the current source fingerprint. 246 *) 247 let paranoidCheck fspathTo pathTo realPathTo desc fp ress = 248 let info = Fileinfo.getBasic false fspathTo pathTo in 249 let fp' = Os.fingerprint fspathTo pathTo info.Fileinfo.typ in 250 if Os.isPseudoFingerprint fp then begin 251 Lwt.return (TransferNeedsDoubleCheckAgainstCurrentSource (info,fp')) 252 end else if fp' <> fp then begin 253 debug (fun() -> Util.msg "Fingerprints differ: %s vs %s\n" 254 (Os.fullfingerprint_to_string fp) 255 (Os.fullfingerprint_to_string fp')); 256 Lwt.return (TransferFailed (Os.reasonForFingerprintMismatch fp fp')) 257 end else 258 Lwt.return (TransferSucceeded info) 259 260 let saveTempFileLocal (fspathTo, (pathTo, realPathTo, reason)) = 261 debug (fun() -> Util.msg "Failed (%s): Saving old temp file %s\n" 262 reason (Path.toString pathTo)); 263 let savepath = 264 Os.tempPath ~fresh:true fspathTo 265 (match Path.deconstructRev realPathTo with 266 Some (nm, _) -> Path.addSuffixToFinalName 267 (Path.child Path.empty nm) "-bad" 268 | None -> Path.fromString "bad") 269 in 270 (* BCP: 12/17: Added a try around this call so that, if we're in the middle of failing 271 when we do this, we don't fail again and confuse the user about the reason for the 272 failure! *) 273 begin try Os.rename "save temp" fspathTo pathTo fspathTo savepath with Util.Transient _ -> () end; 274 Lwt.fail 275 (Util.Transient 276 (Printf.sprintf 277 "The file %s was incorrectly transferred (fingerprint mismatch in %s) \ 278 -- temp file saved as %s" 279 (Path.toString pathTo) 280 reason 281 (Fspath.toDebugString (Fspath.concat fspathTo savepath)))) 282 283 let saveTempFileOnRoot = 284 Remote.registerRootCmd "saveTempFile" 285 Umarshal.(prod3 Path.mlocal Path.mlocal string id id) Umarshal.unit 286 saveTempFileLocal 287 288 (****) 289 290 let removeOldTempFile fspathTo pathTo = 291 if Os.exists fspathTo pathTo then begin 292 debug (fun() -> Util.msg "Removing old %s / %s\n" 293 (Fspath.toDebugString fspathTo) (Path.toString pathTo)); 294 Os.delete fspathTo pathTo 295 end 296 297 (* There is an issue that not all threads are immediately cancelled when there 298 is a connection error. A waiting thread (in this case probably a thread in 299 one of the Lwt regions) may have been started and could open an fd but may 300 never be able to complete. [protect], [lwt_protect] and any other cleanup 301 code may never be triggered in this scenario because the thread just stops 302 (as eventually the connection cleanup kicks in and all threads are stopped). 303 As a hacky(?) solution, keep track of all open fds and close them when the 304 connection breaks. *) 305 let inFdResource = Remote.resourceWithConnCleanup close_in close_in_noerr 306 let outFdResource = Remote.resourceWithConnCleanup close_out close_out_noerr 307 308 let openFileIn' fspath path kind = 309 match kind with 310 `DATA -> 311 Fs.open_in_bin (Fspath.concat fspath path) 312 | `DATA_APPEND len -> 313 let ch = Fs.open_in_bin (Fspath.concat fspath path) in 314 LargeFile.seek_in ch (Uutil.Filesize.toInt64 len); 315 ch 316 | `RESS -> 317 Osx.openRessIn fspath path 318 319 let openFileIn fspath path kind = 320 inFdResource.register (openFileIn' fspath path kind) 321 322 let closeFileIn = inFdResource.release 323 324 let closeFileInNoErr = inFdResource.release_noerr 325 326 let openFileOut' fspath path kind len = 327 match kind with 328 `DATA -> 329 let fullpath = Fspath.concat fspath path in 330 let flags = [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_CLOEXEC] in 331 let perm = if Prefs.read Props.dontChmod then Props.perms Props.fileDefault else 0o600 in 332 begin match Sys.win32 with 333 | true -> 334 Fs.open_out_gen 335 [Open_wronly; Open_creat; Open_excl; Open_binary] perm fullpath 336 | false -> 337 let fd = 338 try 339 Fs.openfile fullpath (Unix.O_EXCL :: flags) perm 340 with 341 Unix.Unix_error 342 ((Unix.EOPNOTSUPP | Unix.EUNKNOWNERR 524), _, _) -> 343 (* O_EXCL not supported under a Netware NFS-mounted filesystem. 344 Solaris and Linux report different errors. *) 345 Fs.openfile fullpath (Unix.O_TRUNC :: flags) perm 346 in 347 Unix.out_channel_of_descr fd 348 end 349 | `DATA_APPEND len -> 350 let fullpath = Fspath.concat fspath path in 351 let perm = if Prefs.read Props.dontChmod then Props.perms Props.fileDefault else 0o600 in 352 let ch = Fs.open_out_gen [Open_wronly; Open_binary] perm fullpath in 353 if not (Prefs.read Props.dontChmod) then Fs.chmod fullpath perm; 354 LargeFile.seek_out ch (Uutil.Filesize.toInt64 len); 355 ch 356 | `RESS -> 357 Osx.openRessOut fspath path len 358 359 let openFileOut fspath path kind len = 360 outFdResource.register (openFileOut' fspath path kind len) 361 362 let closeFileOut = outFdResource.release 363 364 let closeFileOutNoErr = outFdResource.release_noerr 365 366 let setFileinfo fspathTo pathTo realPathTo update desc = 367 match update with 368 `Update _ -> Fileinfo.set fspathTo pathTo (`Copy realPathTo) desc 369 | `Copy -> Fileinfo.set fspathTo pathTo (`Set Props.fileDefault) desc 370 371 (****) 372 373 (* This unfortunate complexity is here to reduce network round-trips 374 and calls to [Update.translatePath], primarily in [Files.setProp]. *) 375 let mxpath = Umarshal.(sum2 Path.mlocal Path.m) 376 (function `Local p -> I21 p | `Global p -> I22 p) 377 (function I21 p -> `Local p | I22 p -> `Global p) 378 379 let loadPropsExtDataLocal (fspath, path, desc) = 380 let localPath = match path with 381 | `Local p -> p 382 | `Global p -> Update.translatePathLocal fspath p in 383 (Some localPath, Props.loadExtData fspath localPath desc) 384 385 let loadPropsExtDataOnServer = Remote.registerServerCmd "propsExtData" 386 Umarshal.(prod3 Fspath.m mxpath Props.m id id) 387 Umarshal.(prod2 (option Path.mlocal) Props.mx id id) 388 (fun connFrom args -> Lwt.return (loadPropsExtDataLocal args)) 389 390 let propsWithExtDataLocal fspath path desc = 391 try (None, Props.withExtData desc) 392 with Not_found -> loadPropsExtDataLocal (fspath, path, desc) 393 394 let propsWithExtDataConn connFrom fspath path desc = 395 try Lwt.return (None, Props.withExtData desc) 396 with Not_found -> loadPropsExtDataOnServer connFrom (fspath, path, desc) 397 398 let propsExtDataOnRoot root path desc = 399 match root with 400 | (Common.Local, fspath) -> 401 Lwt.return (propsWithExtDataLocal fspath path desc) 402 | (Remote _, fspath) -> 403 propsWithExtDataConn (Remote.connectionOfRoot root) fspath path desc 404 405 let propsWithExtData connFrom fspath path desc = 406 propsWithExtDataConn connFrom fspath (`Local path) desc >>= fun x -> 407 Lwt.return (snd x) 408 409 let readPropsExtData root path desc = 410 propsExtDataOnRoot root (`Local path) desc >>= fun x -> 411 Lwt.return (snd x) 412 413 let readPropsExtDataG root path desc = 414 propsExtDataOnRoot root (`Global path) desc 415 416 (****) 417 418 let copy_size l = 419 let def = 10_485_760L in (* 10 MiB, to get periodic progress feedback *) 420 Int64.to_int @@ 421 if Int64.compare l def > 0 then def else l 422 423 let rec copyFileAux src dst src_offs len notify = 424 let open Uutil in 425 if len > Filesize.zero then begin 426 let n = Fs.copy_file src dst (Filesize.toInt64 src_offs) 427 (copy_size (Filesize.toInt64 len)) in 428 let n' = Filesize.ofInt n in 429 let () = notify n' in 430 if n > 0 then 431 copyFileAux src dst (Filesize.add src_offs n') (Filesize.sub len n') notify 432 end 433 434 let copyFileRange src dst src_offs len fallback notify = 435 let bytesCopied = ref Uutil.Filesize.zero in 436 let copied n = 437 bytesCopied := Uutil.Filesize.add !bytesCopied n; 438 notify n 439 in 440 try 441 copyFileAux src dst src_offs len copied 442 with 443 | Unix.Unix_error ((EINVAL | ENOSYS | EBADF | EXDEV 444 | ESPIPE | ENOTSOCK | EOPNOTSUPP) as err, _, _) 445 | Unix.Unix_error (EUNKNOWNERR -50 (* ERROR_NOT_SUPPORTED *) as err, _, _) 446 | Unix.Unix_error (EUNKNOWNERR -1 as err, _, _) 447 (* The errors above are not expected in the middle of a copy; these 448 indicate that [copy_file] is not supported at all (by the OS or 449 by the filesystem, or for these specific files) and nothing 450 has been copied so far, which makes fallback straight-forward. 451 However, this can't be relied upon. While expected extremely rarely, 452 failure after partial success is to be expected and fallback routine 453 must be able to handle this; so all errors are handled the same. *) 454 | Unix.Unix_error (err, _, _) -> 455 debug (fun () -> Util.msg 456 "Falling back to regular copy: copyFileRange failed [%s]%s\n" 457 (Unix.error_message err) 458 (if !bytesCopied = Uutil.Filesize.zero then "" else 459 " (copied " ^ (Uutil.Filesize.toString !bytesCopied) ^ ")")); 460 fallback !bytesCopied 461 462 let copyFile inCh outCh kind len fallback notify = 463 (* Flush the buffered output channel just in case since we're going to 464 manipulate the channel's underlying fd directly. *) 465 flush outCh; 466 let src = Unix.descr_of_in_channel inCh 467 and dst = Unix.descr_of_out_channel outCh in 468 if kind = `DATA && Fs.clone_file src dst then 469 notify len 470 else 471 let tryCopyFileRange src dst src_offs len fallback notify = 472 let fallback' copied = 473 (* Fallback to read-write loop expects that seek positions in input 474 and output fds have not changed. By invariant, if [copyFileRange] 475 succeeded partially then the seek position of output fd was updated 476 accordingly. To not break fallback, the seek position of input fd 477 must be updated by the same amount. *) 478 let open Uutil in 479 if copied <> Filesize.zero then begin 480 let pos = 481 Int64.add (Filesize.toInt64 src_offs) (Filesize.toInt64 copied) in 482 LargeFile.seek_in inCh pos 483 end; 484 fallback () 485 in 486 copyFileRange src dst src_offs len fallback' notify 487 in 488 match kind with 489 | `DATA -> tryCopyFileRange src dst Uutil.Filesize.zero len fallback notify 490 | `DATA_APPEND offs -> tryCopyFileRange src dst offs len fallback notify 491 | `RESS -> fallback () 492 493 let copyByPath fspathFrom pathFrom fspathTo pathTo = 494 Fs.clone_path 495 (Fspath.concat fspathFrom pathFrom) 496 (Fspath.concat fspathTo pathTo) 497 498 (* The fds opened in this function normally shouldn't be tracked for extra 499 cleanup at connection close because this is sequential non-Lwt code. Yet, 500 there is a risk that code called by [Uutil.showProgress] may include Lwt 501 code. For this reason only, it is better to include the fds in this 502 function in the fd cleanup scheme (done automatically by [openFile*] and 503 [closeFile*] functions). *) 504 let copyContents fspathFrom pathFrom fspathTo pathTo fileKind fileLength ido = 505 let use_id f = match ido with Some id -> f id | None -> () in 506 if fileKind = `DATA && copyByPath fspathFrom pathFrom fspathTo pathTo then 507 use_id (fun id -> Uutil.showProgress id fileLength "l") 508 else 509 (* Open fds only if copying by path did not work *) 510 let inFd = openFileIn fspathFrom pathFrom fileKind in 511 protect 512 (fun () -> 513 let outFd = openFileOut fspathTo pathTo fileKind fileLength in 514 protect 515 (fun () -> 516 let showProgress l = 517 use_id (fun id -> 518 (* (Util.msg "Copied file %s (%d bytes)\n" (Path.toString pathFrom) l); *) 519 if fileKind <> `RESS then Abort.checkAll (); 520 Uutil.showProgress id l "l") 521 in 522 let fallback () = Uutil.readWriteBounded inFd outFd fileLength 523 (fun l -> showProgress (Uutil.Filesize.ofInt l)) in 524 copyFile inFd outFd fileKind fileLength fallback showProgress; 525 closeFileIn inFd; 526 closeFileOut outFd; 527 (* ignore (Sys.command ("ls -l " ^ (Fspath.toString (Fspath.concat fspathTo pathTo)))) *) 528 ) 529 (fun () -> closeFileOutNoErr outFd)) 530 (fun () -> closeFileInNoErr inFd) 531 532 let localFileContents fspathFrom pathFrom fspathTo pathTo desc ressLength ido = 533 Util.convertUnixErrorsToTransient 534 "copying locally" 535 (fun () -> 536 debug (fun () -> 537 Util.msg "Copy.localFile %s / %s to %s / %s\n" 538 (Fspath.toDebugString fspathFrom) (Path.toString pathFrom) 539 (Fspath.toDebugString fspathTo) (Path.toString pathTo)); 540 removeOldTempFile fspathTo pathTo; 541 copyContents 542 fspathFrom pathFrom fspathTo pathTo `DATA (Props.length desc) ido; 543 if ressLength > Uutil.Filesize.zero then 544 copyContents 545 fspathFrom pathFrom fspathTo pathTo `RESS ressLength ido) 546 547 let localFile 548 fspathFrom pathFrom fspathTo pathTo realPathTo update desc ressLength ido = 549 Util.convertUnixErrorsToTransient "copying locally" (fun () -> 550 localFileContents fspathFrom pathFrom fspathTo pathTo desc ressLength ido; 551 let (_, desc) = propsWithExtDataLocal fspathFrom (`Local pathFrom) desc in 552 setFileinfo fspathTo pathTo realPathTo update desc) 553 554 (****) 555 556 let tryCopyMovedFile connFrom fspathFrom pathFrom fspathTo pathTo realPathTo 557 update desc fp ress id = 558 if not (Prefs.read Xferhint.xferbycopying) then Lwt.return None else 559 Util.convertUnixErrorsToTransient "tryCopyMovedFile" (fun() -> 560 debug (fun () -> Util.msg "tryCopyMovedFile: -> %s /%s/\n" 561 (Path.toString pathTo) (Os.fullfingerprint_to_string fp)); 562 match Xferhint.lookup fp with 563 None -> 564 Lwt.return None 565 | Some (candidateFspath, candidatePath, hintHandle) -> 566 debug (fun () -> 567 Util.msg 568 "tryCopyMovedFile: found match at %s,%s. Try local copying\n" 569 (Fspath.toDebugString candidateFspath) 570 (Path.toString candidatePath)); 571 try 572 (* If candidateFspath is the replica root, the argument 573 [true] is correct. Otherwise, we don't expect to point 574 to a symlink, and therefore we still get the correct 575 result. *) 576 let info = Fileinfo.getBasic true candidateFspath candidatePath in 577 if 578 info.Fileinfo.typ <> `ABSENT && 579 Props.length info.Fileinfo.desc = Props.length desc 580 then begin 581 localFileContents candidateFspath candidatePath fspathTo pathTo desc 582 (Osx.ressLength ress) (Some id); 583 propsWithExtData connFrom fspathFrom pathFrom desc >>= fun desc -> 584 setFileinfo fspathTo pathTo realPathTo update desc; 585 let (info, isTransferred) = 586 fileIsTransferred fspathTo pathTo desc fp ress in 587 if isTransferred then begin 588 debug (fun () -> Util.msg "tryCopyMoveFile: success.\n"); 589 let msg = 590 Printf.sprintf 591 "Shortcut: copied %s/%s from local file %s/%s\n" 592 (Fspath.toPrintString fspathTo) 593 (Path.toString realPathTo) 594 (Fspath.toPrintString candidateFspath) 595 (Path.toString candidatePath) 596 in 597 Lwt.return (Some (info, msg)) 598 end else begin 599 debug (fun () -> 600 Util.msg "tryCopyMoveFile: candidate file %s modified!\n" 601 (Path.toString candidatePath)); 602 Xferhint.deleteEntry hintHandle; 603 Lwt.return None 604 end 605 end else begin 606 debug (fun () -> 607 Util.msg "tryCopyMoveFile: candidate file %s disappeared!\n" 608 (Path.toString candidatePath)); 609 Xferhint.deleteEntry hintHandle; 610 Lwt.return None 611 end 612 with 613 Util.Transient s -> 614 debug (fun () -> 615 Util.msg 616 "tryCopyMovedFile: local copy from %s didn't work [%s]\n" 617 (Path.toString candidatePath) s); 618 Xferhint.deleteEntry hintHandle; 619 Lwt.return None) 620 621 (****) 622 623 (* The file transfer functions here depend on an external module 624 'transfer' that implements a generic transmission and the rsync 625 algorithm for optimizing the file transfer in the case where a 626 similar file already exists on the target. *) 627 628 let rsyncActivated = 629 Prefs.createBool "rsync" true 630 ~category:(`Advanced `Remote) 631 "activate the rsync transfer mode" 632 ("Unison uses the 'rsync algorithm' for 'diffs-only' transfer " 633 ^ "of updates to large files. Setting this flag to false makes Unison " 634 ^ "use whole-file transfers instead. Under normal circumstances, " 635 ^ "there is no reason to do this, but if you are having trouble with " 636 ^ "repeated 'rsync failure' errors, setting it to " 637 ^ "false should permit you to synchronize the offending files.") 638 639 let decompressor = ref Remote.MsgIdMap.empty 640 641 let resetDecompressorState () = 642 decompressor := Remote.MsgIdMap.empty 643 let () = Remote.at_conn_close resetDecompressorState 644 645 let processTransferInstruction conn (file_id, ti) = 646 Util.convertUnixErrorsToTransient 647 "processing a transfer instruction" 648 (fun () -> 649 ignore ((fst (Remote.MsgIdMap.find file_id !decompressor)) ti)) 650 651 let marshalTransferInstruction = 652 (fun _ (file_id, (data, pos, len)) rem -> 653 (Remote.encodeInt file_id :: (data, pos, len) :: rem, 654 len + Remote.intSize)), 655 (fun _ buf pos -> 656 let len = Bytearray.length buf - pos - Remote.intSize in 657 (Remote.decodeInt buf pos, (buf, pos + Remote.intSize, len))) 658 659 let streamTransferInstruction = 660 Remote.registerStreamCmd 661 "processTransferInstruction" marshalTransferInstruction 662 processTransferInstruction 663 664 let showPrefixProgress id kind = 665 match kind with 666 `DATA_APPEND len -> Uutil.showProgress id len "r" 667 | _ -> () 668 669 let compress conn 670 ((biOpt, fspathFrom, pathFrom, fileKind), (sizeFrom, id, file_id)) = 671 Lwt.catch 672 (fun () -> 673 streamTransferInstruction conn 674 (fun processTransferInstructionRemotely -> 675 (* We abort the file transfer on error if it has not 676 already started *) 677 if fileKind <> `RESS then Abort.check id; 678 let infd = openFileIn fspathFrom pathFrom fileKind in 679 lwt_protect 680 (fun () -> 681 showPrefixProgress id fileKind; 682 let showProgress count = 683 if fileKind <> `RESS then Abort.checkAll (); 684 Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in 685 let compr = 686 match biOpt with 687 None -> 688 Transfer.send infd sizeFrom showProgress 689 | Some bi -> 690 Transfer.Rsync.rsyncCompress 691 bi infd sizeFrom showProgress 692 in 693 compr 694 (fun ti -> processTransferInstructionRemotely (file_id, ti)) 695 >>= fun () -> 696 closeFileIn infd; 697 Lwt.return ()) 698 (fun () -> 699 closeFileInNoErr infd))) 700 (fun e -> 701 (* We cannot wrap the code above with the handler below, 702 as the code is executed asynchronously. *) 703 Util.convertUnixErrorsToTransient "transferring file contents" 704 (fun () -> raise e)) 705 706 let mdata = Umarshal.(sum3 unit Uutil.Filesize.m unit 707 (function 708 | `DATA -> I31 () 709 | `DATA_APPEND a -> I32 a 710 | `RESS -> I33 ()) 711 (function 712 | I31 () -> `DATA 713 | I32 a -> `DATA_APPEND a 714 | I33 () -> `RESS)) 715 716 let mcompress = Umarshal.(prod2 717 (prod4 (option Transfer.Rsync.mrsync_block_info) Fspath.m Path.mlocal mdata id id) 718 (prod3 Uutil.Filesize.m Uutil.File.m int id id) 719 id id) 720 721 let convV0 = Remote.makeConvV0FunArg 722 (fun ((biOpt, fspathFrom, pathFrom, fileKind), (sizeFrom, id, file_id)) -> 723 (biOpt, fspathFrom, pathFrom, fileKind, sizeFrom, id, file_id)) 724 (fun (biOpt, fspathFrom, pathFrom, fileKind, sizeFrom, id, file_id) -> 725 ((biOpt, fspathFrom, pathFrom, fileKind), (sizeFrom, id, file_id))) 726 727 let compressRemotely = 728 Remote.registerServerCmd "compress" ~convV0 mcompress Umarshal.unit compress 729 730 let close_all infd outfd = 731 Util.convertUnixErrorsToTransient 732 "closing files" 733 (fun () -> 734 begin match !infd with 735 Some fd -> closeFileIn fd; infd := None 736 | None -> () 737 end; 738 begin match !outfd with 739 Some fd -> closeFileOut fd; outfd := None 740 | None -> () 741 end) 742 743 let close_all_no_error infd outfd = 744 begin match !infd with 745 Some fd -> closeFileInNoErr fd 746 | None -> () 747 end; 748 begin match !outfd with 749 Some fd -> closeFileOutNoErr fd 750 | None -> () 751 end 752 753 (* Lazy creation of the destination file *) 754 let destinationFd fspath path kind len outfd id = 755 match !outfd with 756 None -> 757 (* We abort the file transfer on error if it has not 758 already started *) 759 if kind <> `RESS then Abort.check id; 760 let fd = openFileOut fspath path kind len in 761 showPrefixProgress id kind; 762 outfd := Some fd; 763 fd 764 | Some fd -> 765 fd 766 767 (* Lazy opening of the reference file (for rsync algorithm) *) 768 let referenceFd fspath path kind infd = 769 match !infd with 770 None -> 771 let fd = openFileIn fspath path kind in 772 infd := Some fd; 773 fd 774 | Some fd -> 775 fd 776 777 let rsyncReg = Remote.lwtRegionWithConnCleanup (40 * 1024) 778 779 let rsyncThrottle useRsync srcFileSize destFileSize f = 780 if not useRsync then f () else 781 let l = Transfer.Rsync.memoryFootprint srcFileSize destFileSize in 782 Lwt_util.run_in_region !rsyncReg l f 783 784 let transferFileContents 785 connFrom fspathFrom pathFrom fspathTo pathTo realPathTo update 786 fileKind srcFileSize id = 787 (* We delay the opening of the files so that there are not too many 788 temporary files remaining after a crash, and that they are not 789 too many files simultaneously opened. *) 790 let outfd = ref None in 791 let infd = ref None in 792 let showProgress count = 793 if fileKind <> `RESS then Abort.checkAll (); 794 Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in 795 796 let destFileSize = 797 match update with 798 `Copy -> 799 Uutil.Filesize.zero 800 | `Update (destFileDataSize, destFileRessSize) -> 801 match fileKind with 802 `DATA | `DATA_APPEND _ -> destFileDataSize 803 | `RESS -> destFileRessSize 804 in 805 let useRsync = 806 Prefs.read rsyncActivated 807 && 808 Transfer.Rsync.aboveRsyncThreshold destFileSize 809 && 810 Transfer.Rsync.aboveRsyncThreshold srcFileSize 811 in 812 rsyncThrottle useRsync srcFileSize destFileSize (fun () -> 813 let (bi, decompr) = 814 if useRsync then 815 Util.convertUnixErrorsToTransient 816 "preprocessing file" 817 (fun () -> 818 let ifd = referenceFd fspathTo realPathTo fileKind infd in 819 let (bi, blockSize) = 820 protect 821 (fun () -> Transfer.Rsync.rsyncPreprocess 822 ifd srcFileSize destFileSize) 823 (fun () -> closeFileInNoErr ifd) 824 in 825 close_all infd outfd; 826 (Some bi, 827 (* Rsync decompressor *) 828 fun ti -> 829 let ifd = referenceFd fspathTo realPathTo fileKind infd in 830 let fd = 831 destinationFd 832 fspathTo pathTo fileKind srcFileSize outfd id in 833 let eof = 834 Transfer.Rsync.rsyncDecompress blockSize ifd fd showProgress ti 835 ~copyFn:(fun in_offs len ~fallback -> 836 (* Flush the buffered output channel just in case since 837 we manipulate the channel's underlying fd directly. *) 838 flush fd; 839 copyFileRange 840 (Unix.descr_of_in_channel ifd) 841 (Unix.descr_of_out_channel fd) 842 in_offs len fallback (fun _ -> ())) 843 in 844 if eof then close_all infd outfd)) 845 else 846 (None, 847 (* Simple generic decompressor *) 848 fun ti -> 849 let fd = 850 destinationFd fspathTo pathTo fileKind srcFileSize outfd id in 851 let eof = Transfer.receive fd showProgress ti in 852 if eof then close_all infd outfd) 853 in 854 let file_id = Remote.newMsgId () in 855 Lwt.catch 856 (fun () -> 857 debug (fun () -> Util.msg "Starting the actual transfer\n"); 858 decompressor := Remote.MsgIdMap.add file_id (decompr, (infd, outfd)) !decompressor; 859 compressRemotely connFrom 860 ((bi, fspathFrom, pathFrom, fileKind), (srcFileSize, id, file_id)) 861 >>= fun () -> 862 decompressor := 863 Remote.MsgIdMap.remove file_id !decompressor; (* For GC *) 864 close_all infd outfd; 865 (* JV: FIX: the file descriptors are already closed... *) 866 Lwt.return ()) 867 (fun e -> 868 decompressor := 869 Remote.MsgIdMap.remove file_id !decompressor; (* For GC *) 870 close_all_no_error infd outfd; 871 Lwt.fail e)) 872 873 (****) 874 875 let transferResourceForkAndSetFileinfo 876 connFrom fspathFrom pathFrom fspathTo pathTo realPathTo 877 update desc fp ress id = 878 (* Resource fork *) 879 debug (fun() -> Util.msg "transferResourceForkAndSetFileinfo %s\n" 880 (Path.toString pathTo)); 881 let ressLength = Osx.ressLength ress in 882 begin if ressLength > Uutil.Filesize.zero then begin 883 debug (fun() -> Util.msg "starting resource fork transfer for %s\n" 884 (Path.toString pathTo)); 885 transferFileContents 886 connFrom fspathFrom pathFrom fspathTo pathTo realPathTo update 887 `RESS ressLength id 888 end else 889 Lwt.return () 890 end >>= fun () -> 891 propsWithExtData connFrom fspathFrom pathFrom desc >>= fun desc -> 892 setFileinfo fspathTo pathTo realPathTo update desc; 893 debug (fun() -> Util.msg "Resource fork transferred for %s; doing last paranoid check\n" 894 (Path.toString realPathTo)); 895 paranoidCheck fspathTo pathTo realPathTo desc fp ress 896 897 let reallyTransferFile 898 connFrom fspathFrom pathFrom fspathTo pathTo realPathTo 899 update desc fp ress id tempInfo = 900 debug (fun() -> Util.msg "reallyTransferFile(%s,%s) -> (%s,%s,%s,%s)\n" 901 (Fspath.toDebugString fspathFrom) (Path.toString pathFrom) 902 (Fspath.toDebugString fspathTo) (Path.toString pathTo) 903 (Path.toString realPathTo) (Props.toString desc)); 904 validFilePrefix connFrom fspathFrom pathFrom fspathTo pathTo tempInfo desc 905 >>= fun prefixLen -> 906 begin match prefixLen with 907 None -> 908 removeOldTempFile fspathTo pathTo 909 | Some len -> 910 debug 911 (fun() -> 912 Util.msg "Keeping %s bytes previously transferred for file %s\n" 913 (Uutil.Filesize.toString len) (Path.toString pathFrom)) 914 end; 915 (* Data fork *) 916 transferFileContents 917 connFrom fspathFrom pathFrom fspathTo pathTo realPathTo update 918 (match prefixLen with None -> `DATA | Some l -> `DATA_APPEND l) 919 (Props.length desc) id >>= fun () -> 920 transferResourceForkAndSetFileinfo 921 connFrom fspathFrom pathFrom fspathTo pathTo realPathTo 922 update desc fp ress id 923 924 (****) 925 926 let filesBeingTransferred = Hashtbl.create 17 927 928 let resetFileTransferState () = 929 (* The waiting threads should be collected by GC *) 930 Hashtbl.clear filesBeingTransferred 931 let () = Remote.at_conn_close resetFileTransferState 932 933 let wakeupNextTransfer fp = 934 match 935 try 936 Some (Queue.take (Hashtbl.find filesBeingTransferred fp)) 937 with Queue.Empty -> 938 None 939 with 940 None -> 941 Hashtbl.remove filesBeingTransferred fp 942 | Some next -> 943 Lwt.wakeup next () 944 945 let executeTransfer fp f = 946 Lwt.try_bind f 947 (fun res -> wakeupNextTransfer fp; Lwt.return res) 948 (fun e -> wakeupNextTransfer fp; Lwt.fail e) 949 950 (* Keep track of which file contents are being transferred, and delay 951 the transfer of a file with the same contents as another file being 952 currently transferred. This way, the second transfer can be 953 skipped and replaced by a local copy. *) 954 let rec registerFileTransfer pathTo fp f = 955 if not (Prefs.read Xferhint.xferbycopying) then f () else 956 match 957 try Some (Hashtbl.find filesBeingTransferred fp) with Not_found -> None 958 with 959 None -> 960 let q = Queue.create () in 961 Hashtbl.add filesBeingTransferred fp q; 962 executeTransfer fp f 963 | Some q -> 964 debug (fun () -> Util.msg "delaying transfer of file %s\n" 965 (Path.toString pathTo)); 966 let res = Lwt.wait () in 967 Queue.push res q; 968 res >>= fun () -> 969 executeTransfer fp f 970 971 (****) 972 973 let copyprog = 974 Prefs.createString "copyprog" "rsync --partial --inplace --compress" 975 ~category:(`Advanced `General) 976 ~deprecated:true 977 "external program for copying large files" 978 ("A string giving the name of an " 979 ^ "external program that can be used to copy large files efficiently " 980 ^ "(plus command-line switches telling it to copy files in-place). " 981 ^ "The default setting invokes {\\tt rsync} with appropriate " 982 ^ "options---most users should not need to change it.") 983 984 let copyprogrest = 985 Prefs.createString 986 "copyprogrest" "rsync --partial --append-verify --compress" 987 ~category:(`Advanced `General) 988 ~deprecated:true 989 "variant of copyprog for resuming partial transfers" 990 ("A variant of {\\tt copyprog} that names an external program " 991 ^ "that should be used to continue the transfer of a large file " 992 ^ "that has already been partially transferred. Typically, " 993 ^ "{\\tt copyprogrest} will just be {\\tt copyprog} " 994 ^ "with one extra option (e.g., {\\tt --partial}, for rsync). " 995 ^ "The default setting invokes {\\tt rsync} with appropriate " 996 ^ "options---most users should not need to change it.") 997 998 let copythreshold = 999 Prefs.createInt "copythreshold" (-1) 1000 ~category:(`Advanced `General) 1001 ~deprecated:true 1002 "use copyprog on files bigger than this (if >=0, in Kb)" 1003 ("A number indicating above what filesize (in kilobytes) Unison should " 1004 ^ "use the external " 1005 ^ "copying utility specified by {\\tt copyprog}. Specifying 0 will cause " 1006 ^ "{\\em all} copies to use the external program; " 1007 ^ "a negative number will prevent any files from using it. " 1008 ^ "The default is -1. " 1009 ^ "See \\sectionref{speeding}{Making Unison Faster on Large Files} " 1010 ^ "for more information.") 1011 1012 (* Pref copyquoterem removed since 2.53.3 *) 1013 let () = Prefs.markRemoved "copyquoterem" 1014 1015 let copymax = 1016 Prefs.createInt "copymax" 1 1017 ~category:(`Advanced `General) 1018 ~deprecated:true 1019 "maximum number of simultaneous copyprog transfers" 1020 ("A number indicating how many instances of the external copying utility \ 1021 Unison is allowed to run simultaneously (default to 1).") 1022 1023 let formatConnectionInfo root = 1024 match root with 1025 Common.Local, _ -> "" 1026 | Common.Remote h, _ -> 1027 (* Find the (unique) nonlocal root *) 1028 match 1029 Safelist.find (function Clroot.ConnectLocal _ -> false | _ -> true) 1030 (Globals.parsedClRawRoots ()) 1031 with 1032 Clroot.ConnectByShell (_,rawhost,uo,_,_) -> 1033 let rawhost = if String.contains rawhost ':' then "[" ^ rawhost ^ "]" else rawhost in 1034 (match uo with None -> "" | Some u -> u ^ "@") 1035 ^ rawhost ^ ":" 1036 (* Note that we don't do anything with the port -- hopefully 1037 this will not affect many people. If we did want to include it, 1038 we'd have to fiddle with the rsync parameters in a slightly 1039 deeper way. *) 1040 | Clroot.ConnectBySocket (h',_,_) -> 1041 h ^ ":" 1042 | Clroot.ConnectLocal _ -> assert false 1043 1044 let shouldUseExternalCopyprog update desc = 1045 Prefs.read copyprog <> "" 1046 && Prefs.read copythreshold >= 0 1047 && Props.length desc >= Uutil.Filesize.ofInt64 (Int64.of_int 1) 1048 && Props.length desc >= 1049 Uutil.Filesize.ofInt64 1050 (Int64.mul (Int64.of_int 1000) 1051 (Int64.of_int (Prefs.read copythreshold))) 1052 && update = `Copy 1053 1054 let prepareExternalTransfer fspathTo pathTo = 1055 let info = Fileinfo.getBasic false fspathTo pathTo in 1056 match info.Fileinfo.typ with 1057 `FILE when Props.length info.Fileinfo.desc > Uutil.Filesize.zero -> 1058 let perms = Props.perms info.Fileinfo.desc in 1059 let perms' = perms lor 0o600 in 1060 begin try 1061 Fs.chmod (Fspath.concat fspathTo pathTo) perms' 1062 with Unix.Unix_error _ -> () end; 1063 true 1064 | `ABSENT -> 1065 false 1066 | t -> 1067 debug (fun() -> Util.msg "Removing existing %s / %s\n" 1068 (Fspath.toDebugString fspathTo) (Path.toString pathTo)); 1069 Os.delete fspathTo pathTo; 1070 false 1071 1072 let finishExternalTransferLocal connFrom 1073 ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo), 1074 (update, desc, fp, ress, id)) = 1075 let info = Fileinfo.getBasic false fspathTo pathTo in 1076 if 1077 info.Fileinfo.typ <> `FILE || 1078 Props.length info.Fileinfo.desc <> Props.length desc 1079 then 1080 raise (Util.Transient (Printf.sprintf 1081 "External copy program did not create target file (or bad length): %s" 1082 (Path.toString pathTo))); 1083 transferResourceForkAndSetFileinfo 1084 connFrom fspathFrom pathFrom fspathTo pathTo realPathTo 1085 update desc fp ress id >>= fun res -> 1086 Xferhint.insertEntry fspathTo pathTo fp; 1087 Lwt.return res 1088 1089 let convV0 = Remote.makeConvV0Funs 1090 (fun ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo), 1091 (update, desc, fp, ress, id)) -> 1092 (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo, 1093 update, Props.to_compat251 desc, fp, ress, id)) 1094 (fun (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo, 1095 update, desc, fp, ress, id) -> 1096 ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo), 1097 (update, Props.of_compat251 desc, fp, ress, id))) 1098 transferStatus_to_compat251 1099 transferStatus_of_compat251 1100 1101 let mcopyOrUpdate = Umarshal.(sum2 unit (prod2 Uutil.Filesize.m Uutil.Filesize.m id id) 1102 (function 1103 | `Copy -> I21 () 1104 | `Update (a, b) -> I22 (a, b)) 1105 (function 1106 | I21 () -> `Copy 1107 | I22 (a, b) -> `Update (a, b))) 1108 1109 let mfinishExternalTransfer = Umarshal.(prod2 1110 (prod5 Fspath.m Path.mlocal Fspath.m Path.mlocal Path.mlocal id id) 1111 (prod5 mcopyOrUpdate Props.m Os.mfullfingerprint Osx.mressStamp Uutil.File.m id id) 1112 id id) 1113 1114 let finishExternalTransferOnRoot = 1115 Remote.registerRootCmdWithConnection 1116 "finishExternalTransfer" ~convV0 1117 mfinishExternalTransfer mtransferStatus finishExternalTransferLocal 1118 1119 let copyprogReg = Remote.lwtRegionWithConnCleanup 1 1120 1121 let transferFileUsingExternalCopyprog 1122 rootFrom pathFrom rootTo fspathTo pathTo realPathTo 1123 update desc fp ress id useExistingTarget = 1124 Uutil.showProgress id Uutil.Filesize.zero "ext"; 1125 let progWithArgs = 1126 if useExistingTarget then 1127 Prefs.read copyprogrest 1128 else 1129 Prefs.read copyprog 1130 in 1131 let fromSpec = 1132 (formatConnectionInfo rootFrom) 1133 ^ (Fspath.toString (Fspath.concat (snd rootFrom) pathFrom)) in 1134 let toSpec = 1135 (formatConnectionInfo rootTo) 1136 ^ (Fspath.toString (Fspath.concat fspathTo pathTo)) in 1137 Trace.log (progWithArgs ^ " " ^ fromSpec ^ " " ^ toSpec ^ "\n"); 1138 Lwt_util.resize_region !copyprogReg (Prefs.read copymax); 1139 let args = Str.split (Str.regexp "[ \t]+") progWithArgs in 1140 let prog = match args with [] -> assert false | h :: _ -> h in 1141 Lwt_util.run_in_region !copyprogReg 1 1142 (fun () -> External.runExternalProgramArgs prog 1143 (Array.of_list (args @ [fromSpec; toSpec]))) >>= fun (_, log) -> 1144 debug (fun() -> 1145 let l = Util.trimWhitespace log in 1146 Util.msg "transferFileUsingExternalCopyprog %s: returned...\n%s%s" 1147 (Path.toString pathFrom) 1148 l (if l="" then "" else "\n")); 1149 Uutil.showProgress id (Props.length desc) "ext"; 1150 finishExternalTransferOnRoot rootTo rootFrom 1151 ((snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo), 1152 (update, desc, fp, ress, id)) 1153 1154 (****) 1155 1156 let transferFileLocal connFrom 1157 ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo), 1158 (update, desc, fp, ress, id)) = 1159 let (tempInfo, isTransferred) = 1160 fileIsTransferred fspathTo pathTo desc fp ress in 1161 if isTransferred then begin 1162 (* File is already fully transferred (from some interrupted 1163 previous transfer). So just make sure permissions are right. *) 1164 let msg = 1165 Printf.sprintf 1166 "%s/%s has already been transferred\n" 1167 (Fspath.toDebugString fspathTo) (Path.toString realPathTo) in 1168 let len = Uutil.Filesize.add (Props.length desc) (Osx.ressLength ress) in 1169 Uutil.showProgress id len "alr"; 1170 propsWithExtData connFrom fspathFrom pathFrom desc >>= fun desc -> 1171 setFileinfo fspathTo pathTo realPathTo update desc; 1172 Xferhint.insertEntry fspathTo pathTo fp; 1173 Lwt.return (`DONE (TransferSucceeded tempInfo, Some msg)) 1174 end else 1175 registerFileTransfer pathTo fp 1176 (fun () -> 1177 tryCopyMovedFile connFrom fspathFrom pathFrom 1178 fspathTo pathTo realPathTo update desc fp ress id >>= function 1179 | Some (info, msg) -> 1180 (* Transfer was performed by copying *) 1181 Xferhint.insertEntry fspathTo pathTo fp; 1182 Lwt.return (`DONE (TransferSucceeded info, Some msg)) 1183 | None -> 1184 debug (fun() -> Util.msg "tryCopyMovedFile didn't work, so now we actually transfer\n"); 1185 if shouldUseExternalCopyprog update desc then 1186 Lwt.return (`EXTERNAL (prepareExternalTransfer fspathTo pathTo)) 1187 else begin 1188 reallyTransferFile 1189 connFrom fspathFrom pathFrom fspathTo pathTo realPathTo 1190 update desc fp ress id tempInfo >>= fun status -> 1191 Xferhint.insertEntry fspathTo pathTo fp; 1192 Lwt.return (`DONE (status, None)) 1193 end) 1194 1195 let convV0 = Remote.makeConvV0Funs 1196 (fun ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo), 1197 (update, desc, fp, ress, id)) -> 1198 (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo, 1199 update, Props.to_compat251 desc, fp, ress, id)) 1200 (fun (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo, 1201 update, desc, fp, ress, id) -> 1202 ((fspathFrom, pathFrom, fspathTo, pathTo, realPathTo), 1203 (update, Props.of_compat251 desc, fp, ress, id))) 1204 (function 1205 | `DONE (a, b) -> `DONE (transferStatus_to_compat251 a, b) 1206 | `EXTERNAL a -> `EXTERNAL a) 1207 (function 1208 | `DONE (a, b) -> `DONE (transferStatus_of_compat251 a, b) 1209 | `EXTERNAL a -> `EXTERNAL a) 1210 1211 let mtransferFile = Umarshal.(sum2 (prod2 mtransferStatus (option string) id id) bool 1212 (function 1213 | `DONE (a, b) -> I21 (a, b) 1214 | `EXTERNAL a -> I22 a) 1215 (function 1216 | I21 (a, b) -> `DONE (a, b) 1217 | I22 a -> `EXTERNAL a)) 1218 1219 let transferFileOnRoot = 1220 Remote.registerRootCmdWithConnection "transferFile" ~convV0 1221 mfinishExternalTransfer mtransferFile transferFileLocal 1222 1223 (* We limit the size of the output buffers to about 512 KB 1224 (we cannot go above the limit below plus 64) *) 1225 let transferFileReg = Remote.lwtRegionWithConnCleanup 440 1226 1227 let bufferSize sz = 1228 (* Token queue *) 1229 min 64 ((truncate (Uutil.Filesize.toFloat sz) + 1023) / 1024) 1230 + 1231 (* Read buffer *) 1232 8 1233 1234 let transferFile 1235 rootFrom pathFrom rootTo fspathTo pathTo realPathTo 1236 update desc fp ress id = 1237 let f () = 1238 Abort.check id; 1239 transferFileOnRoot rootTo rootFrom 1240 ((snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo), 1241 (update, desc, fp, ress, id)) >>= fun status -> 1242 match status with 1243 `DONE (status, msg) -> 1244 begin match msg with 1245 Some msg -> 1246 (* If the file was already present or transferred by copying 1247 on the server, we need to update the amount of data 1248 transferred so far here. *) 1249 if fst rootTo <> Common.Local then begin 1250 let len = 1251 Uutil.Filesize.add (Props.length desc) (Osx.ressLength ress) 1252 in 1253 Uutil.showProgress id len "rem" 1254 end; 1255 Trace.log msg 1256 | None -> 1257 () 1258 end; 1259 Lwt.return status 1260 | `EXTERNAL useExistingTarget -> 1261 transferFileUsingExternalCopyprog 1262 rootFrom pathFrom rootTo fspathTo pathTo realPathTo 1263 update desc fp ress id useExistingTarget 1264 in 1265 (* When streaming, we only transfer one file at a time, so we don't 1266 need to limit the number of concurrent transfers *) 1267 if Prefs.read Remote.streamingActivated then 1268 f () 1269 else 1270 let bufSz = bufferSize (max (Props.length desc) (Osx.ressLength ress)) in 1271 Lwt_util.run_in_region !transferFileReg bufSz f 1272 1273 (****) 1274 1275 let file rootFrom pathFrom rootTo fspathTo pathTo realPathTo 1276 update desc fp stamp ress id = 1277 debug (fun() -> Util.msg "copyRegFile(%s,%s) -> (%s,%s,%s,%s,%s)\n" 1278 (Common.root2string rootFrom) (Path.toString pathFrom) 1279 (Common.root2string rootTo) (Path.toString realPathTo) 1280 (Fspath.toDebugString fspathTo) (Path.toString pathTo) 1281 (Props.toString desc)); 1282 let timer = Trace.startTimer "Transmitting file" in 1283 begin match rootFrom, rootTo with 1284 (Common.Local, fspathFrom), (Common.Local, realFspathTo) -> 1285 localFile 1286 fspathFrom pathFrom fspathTo pathTo realPathTo 1287 update desc (Osx.ressLength ress) (Some id); 1288 paranoidCheck fspathTo pathTo realPathTo desc fp ress 1289 | _ -> 1290 transferFile 1291 rootFrom pathFrom rootTo fspathTo pathTo realPathTo 1292 update desc fp ress id 1293 end >>= fun status -> 1294 Trace.showTimer timer; 1295 match status with 1296 TransferSucceeded info -> 1297 checkForChangesToSource rootFrom pathFrom desc fp stamp ress None false 1298 >>= fun () -> 1299 Lwt.return info 1300 | TransferNeedsDoubleCheckAgainstCurrentSource (info,newfp) -> 1301 debug (fun() -> Util.msg 1302 "Archive data for %s is a pseudo-fingerprint: double-checking...\n" 1303 (Path.toString realPathTo)); 1304 1305 checkForChangesToSource rootFrom pathFrom 1306 desc fp stamp ress (Some newfp) false 1307 >>= (fun () -> 1308 Lwt.return info) 1309 | TransferFailed reason -> 1310 debug (fun() -> Util.msg "TRANSFER FAILED (%s) for %s (real path: %s)\n" 1311 reason (Path.toString pathTo) (Path.toString realPathTo)); 1312 (* Maybe we failed because the source file was modified. 1313 We check this before reporting a failure *) 1314 checkForChangesToSource rootFrom pathFrom desc fp stamp ress None true 1315 >>= fun () -> 1316 (* This function never returns (it is supposed to fail) *) 1317 saveTempFileOnRoot rootTo (pathTo, realPathTo, reason) >>= fun () -> 1318 assert false 1319 1320 (****) 1321 1322 let recursively fspathFrom pathFrom fspathTo pathTo = 1323 let rec copy pFrom pTo = 1324 let info = Fileinfo.get true fspathFrom pFrom in 1325 match info.Fileinfo.typ with 1326 | `SYMLINK -> 1327 debug (fun () -> Util.msg " Copying link %s / %s to %s / %s\n" 1328 (Fspath.toDebugString fspathFrom) (Path.toString pFrom) 1329 (Fspath.toDebugString fspathTo) (Path.toString pTo)); 1330 Os.symlink fspathTo pTo (Os.readLink fspathFrom pFrom) 1331 | `FILE -> 1332 debug (fun () -> Util.msg " Copying file %s / %s to %s / %s\n" 1333 (Fspath.toDebugString fspathFrom) (Path.toString pFrom) 1334 (Fspath.toDebugString fspathTo) (Path.toString pTo)); 1335 localFile fspathFrom pFrom fspathTo pTo pTo 1336 `Copy info.Fileinfo.desc 1337 (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) None 1338 | `DIRECTORY -> 1339 debug (fun () -> Util.msg " Copying directory %s / %s to %s / %s\n" 1340 (Fspath.toDebugString fspathFrom) (Path.toString pFrom) 1341 (Fspath.toDebugString fspathTo) (Path.toString pTo)); 1342 Os.createDir fspathTo pTo (Props.perms info.Fileinfo.desc); 1343 let ch = Os.childrenOf fspathFrom pFrom in 1344 Safelist.iter 1345 (fun n -> copy (Path.child pFrom n) (Path.child pTo n)) ch 1346 | `ABSENT -> 1347 (* BCP 4/16: Was "assert false", but this causes unison to 1348 crash when (1) the copyonconflict preference is used, (2) 1349 there is a conflict between a deletion and a change, and 1350 (3) the change is propagated on top of the deletion. Seems 1351 better to silently ignore the copy request. *) 1352 () 1353 in 1354 debug (fun () -> Util.msg " Copying recursively %s / %s\n" 1355 (Fspath.toDebugString fspathFrom) (Path.toString pathFrom)); 1356 copy pathFrom pathTo; 1357 debug (fun () -> Util.msg " Finished copying %s / %s\n" 1358 (Fspath.toDebugString fspathFrom) (Path.toString pathTo))