File: files.ml

package info (click to toggle)
unison 2.40.65-2
  • links: PTS, VCS
  • area: main
  • in suites: wheezy
  • size: 12,220 kB
  • sloc: ml: 29,298; objc: 6,745; ansic: 1,384; makefile: 523; sh: 80
file content (1041 lines) | stat: -rw-r--r-- 45,977 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
(* Unison file synchronizer: src/files.ml *)
(* Copyright 1999-2009, Benjamin C. Pierce 

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)


open Common
open Lwt
open Fileinfo
  
let debug = Trace.debug "files"
let debugverbose = Trace.debug "files+"
    
(* ------------------------------------------------------------ *)
    
let commitLogName = Util.fileInHomeDir "DANGER.README"
    
let writeCommitLog source target tempname =
  let sourcename = Fspath.toDebugString source in
  let targetname = Fspath.toDebugString target in
  debug (fun() -> Util.msg "Writing commit log: renaming %s to %s via %s\n"
    sourcename targetname tempname);
  Util.convertUnixErrorsToFatal
    "writing commit log"
    (fun () ->
       let c =
         System.open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_excl]
           0o600 commitLogName in
       Printf.fprintf c "Warning: the last run of %s terminated abnormally "
         Uutil.myName;
       Printf.fprintf c "while moving\n   %s\nto\n   %s\nvia\n   %s\n\n"
         sourcename targetname tempname;
       Printf.fprintf c "Please check the state of these files immediately\n";
       Printf.fprintf c "(and delete this notice when you've done so).\n";
       close_out c)

let clearCommitLog () =
  debug (fun() -> (Util.msg "Deleting commit log\n"));
  Util.convertUnixErrorsToFatal
    "clearing commit log"
      (fun () -> System.unlink commitLogName)
    
let processCommitLog () =
  if System.file_exists commitLogName then begin
    raise(Util.Fatal(
          Printf.sprintf
            "Warning: the previous run of %s terminated in a dangerous state.
            Please consult the file %s, delete it, and try again."
                Uutil.myName
                (System.fspathToPrintString commitLogName)))
  end else
    Lwt.return ()
      
let processCommitLogOnHost =
  Remote.registerHostCmd "processCommitLog" processCommitLog
    
let processCommitLogs() =
  Lwt_unix.run
    (Globals.allHostsIter (fun h -> processCommitLogOnHost h ()))

(* ------------------------------------------------------------ *)

let deleteLocal (fspathTo, (pathTo, ui)) =
  debug (fun () ->
     Util.msg "deleteLocal [%s] (None, %s)\n"
       (Fspath.toDebugString fspathTo) (Path.toString pathTo));
  let localPathTo = Update.translatePathLocal fspathTo pathTo in
  (* Make sure the target is unchanged first *)
  (* (There is an unavoidable race condition here.) *)
  let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in
  Stasher.backup fspathTo localPathTo `AndRemove prevArch;
  (* Archive update must be done last *)
  Update.replaceArchiveLocal fspathTo localPathTo Update.NoArchive;
  Lwt.return ()

let deleteOnRoot = Remote.registerRootCmd "delete" deleteLocal

let delete rootFrom pathFrom rootTo pathTo ui =
  deleteOnRoot rootTo (pathTo, ui) >>= fun _ ->
  Update.replaceArchive rootFrom pathFrom Update.NoArchive

(* ------------------------------------------------------------ *)

let fileUpdated ui =
  match ui with
    Updates (File (_, ContentsUpdated _), _) -> true
  | _                                        -> false

let setPropLocal (fspath, (path, ui, newDesc, oldDesc)) =
  (* [ui] provides the modtime while [newDesc] provides the other
     file properties *)
  let localPath = Update.translatePathLocal fspath path in
  let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in
  Fileinfo.set workingDir realPath (`Update oldDesc) newDesc;
  if fileUpdated ui then Stasher.stashCurrentVersion fspath localPath None;
  (* Archive update must be done last *)
  Update.updateProps fspath localPath (Some newDesc) ui;
  Lwt.return ()

let setPropOnRoot = Remote.registerRootCmd "setProp" setPropLocal

let updatePropsOnRoot =
  Remote.registerRootCmd
   "updateProps"
     (fun (fspath, (path, propOpt, ui)) ->
        let localPath = Update.translatePathLocal fspath path in
        (* Archive update must be done first *)
        Update.updateProps fspath localPath propOpt ui;
        if fileUpdated ui then
          Stasher.stashCurrentVersion fspath localPath None;
        Lwt.return ())

let updateProps root path propOpt ui =
  updatePropsOnRoot root (path, propOpt, ui)

(* FIX: we should check there has been no update before performing the
   change *)
let setProp rootFrom pathFrom rootTo pathTo newDesc oldDesc uiFrom uiTo =
  debug (fun() ->
    Util.msg
      "setProp %s %s %s\n   %s %s %s\n"
      (root2string rootFrom) (Path.toString pathFrom)
      (Props.toString newDesc)
      (root2string rootTo) (Path.toString pathTo)
      (Props.toString oldDesc));
  setPropOnRoot rootTo (pathTo, uiTo, newDesc, oldDesc) >>= fun _ ->
  updateProps rootFrom pathFrom None uiFrom

(* ------------------------------------------------------------ *)

let mkdirOnRoot =
  Remote.registerRootCmd
    "mkdir"
    (fun (fspath,(workingDir,path)) ->
       let info = Fileinfo.get false workingDir path in
       if info.Fileinfo.typ = `DIRECTORY then begin
         begin try
           (* Make sure the directory is writable *)
           Fs.chmod (Fspath.concat workingDir path)
             (Props.perms info.Fileinfo.desc lor 0o700)
         with Unix.Unix_error _ -> () end;
         Lwt.return (true, info.Fileinfo.desc)
       end else begin
         if info.Fileinfo.typ <> `ABSENT then
           Os.delete workingDir path;
         Os.createDir workingDir path Props.dirDefault;
         Lwt.return (false, (Fileinfo.get false workingDir path).Fileinfo.desc)
       end)

let setDirPropOnRoot =
  Remote.registerRootCmd
    "setDirProp"
    (fun (_, (workingDir, path, initialDesc, newDesc)) ->
      Fileinfo.set workingDir path (`Set initialDesc) newDesc;
      Lwt.return ())

let makeSymlink =
  Remote.registerRootCmd
    "makeSymlink"
    (fun (fspath, (workingDir, path, l)) ->
       if Os.exists workingDir path then
         Os.delete workingDir path;
       Os.symlink workingDir path l;
       Lwt.return ())

(* ------------------------------------------------------------ *)

let performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch =
  debug (fun () -> Util.msg "Renaming %s to %s in %s; root is %s\n"
      (Path.toString pathFrom)
      (Path.toString pathTo)
      (Fspath.toDebugString workingDir)
      (Fspath.toDebugString fspathTo));
  let source = Fspath.concat workingDir pathFrom in
  let target = Fspath.concat workingDir pathTo in
  Util.convertUnixErrorsToTransient
    (Printf.sprintf "renaming %s to %s"
       (Fspath.toDebugString source) (Fspath.toDebugString target))
    (fun () ->
      debugverbose (fun() ->
        Util.msg "calling Fileinfo.get from renameLocal\n");
      let filetypeFrom =
        (Fileinfo.get false source Path.empty).Fileinfo.typ in
      debugverbose (fun() ->
        Util.msg "back from Fileinfo.get from renameLocal\n");
      if filetypeFrom = `ABSENT then raise (Util.Transient (Printf.sprintf
           "Error while renaming %s to %s -- source file has disappeared!"
	   (Fspath.toPrintString source) (Fspath.toPrintString target)));
      let filetypeTo = (Fileinfo.get false target Path.empty).Fileinfo.typ in

       (* Windows and Unix operate differently if the target path of a
          rename already exists: in Windows an exception is raised, in
          Unix the file is clobbered.  In both Windows and Unix, if
          the target is an existing **directory**, an exception will
          be raised.  We want to avoid doing the move first, if possible,
          because this opens a "window of danger" during which the contents of
          the path is nothing. *)
      let moveFirst =
        match (filetypeFrom, filetypeTo) with
        | (_, `ABSENT)            -> false
        | ((`FILE | `SYMLINK),
           (`FILE | `SYMLINK))    -> Util.osType <> `Unix
        | _                       -> true (* Safe default *) in
      if moveFirst then begin
        debug (fun() -> Util.msg "rename: moveFirst=true\n");
        let tmpPath = Os.tempPath workingDir pathTo in
        let temp = Fspath.concat workingDir tmpPath in
        let temp' = Fspath.toDebugString temp in

        debug (fun() ->
          Util.msg "moving %s to %s\n" (Fspath.toDebugString target) temp');
        Stasher.backup fspathTo localPathTo `ByCopying prevArch;
        writeCommitLog source target temp';
        Util.finalize (fun() ->
          (* If the first rename fails, the log can be removed: the
             filesystem is in a consistent state *)
          Os.rename "renameLocal(1)" target Path.empty temp Path.empty;
          (* If the next renaming fails, we will be left with
             DANGER.README file which will make any other
             (similar) renaming fail in a cryptic way.  So it
             seems better to abort early by converting Unix errors
             to Fatal ones (rather than Transient). *)
          Util.convertUnixErrorsToFatal "renaming with commit log"
            (fun () ->
              debug (fun() -> Util.msg "rename %s to %s\n"
                       (Fspath.toDebugString source)
                       (Fspath.toDebugString target));
              Os.rename "renameLocal(2)"
                source Path.empty target Path.empty))
          (fun _ -> clearCommitLog());
        (* It is ok to leave a temporary file.  So, the log can be
           cleared before deleting it. *)
        Os.delete temp Path.empty
      end else begin
        debug (fun() -> Util.msg "rename: moveFirst=false\n");
        Stasher.backup fspathTo localPathTo `ByCopying prevArch;
        Os.rename "renameLocal(3)" source Path.empty target Path.empty;
        debug (fun() ->
	  if filetypeFrom = `FILE then
            Util.msg
              "Contents of %s after renaming = %s\n"
              (Fspath.toDebugString target)
    	      (Fingerprint.toString (Fingerprint.file target Path.empty)));
      end)

(* FIX: maybe we should rename the destination before making any check ? *)
(* JV (6/09): the window is small again...
   FIX: When this code was originally written, we assumed that the
   checkNoUpdates would happen immediately before the rename, so that
   the window of danger where other processes could invalidate the thing we
   just checked was very small.  But now that transport is multi-threaded,
   this window of danger could get very long because other transfers are
   saturating the link.  It would be better, I think, to introduce a real
   2PC protocol here, so that both sides would (locally and almost-atomically)
   check that their assumptions had not been violated and then switch the
   temp file into place, but remain able to roll back if something fails
   either locally or on the other side. *)
let renameLocal
      (fspathTo, (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt)) =
  (* Make sure the target is unchanged, then do the rename.
     (Note that there is an unavoidable race condition here...) *)
  let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in
  performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch;
  begin match archOpt with
    Some archTo -> Stasher.stashCurrentVersion fspathTo localPathTo None;
                   Update.iterFiles fspathTo localPathTo archTo
                     Xferhint.insertEntry;
                   (* Archive update must be done last *)
                   Update.replaceArchiveLocal fspathTo localPathTo archTo
  | None        -> ()
  end;
  Lwt.return ()

let renameOnHost = Remote.registerRootCmd "rename" renameLocal

let rename root localPath workingDir pathOld pathNew ui archOpt =
  debug (fun() ->
    Util.msg "rename(root=%s, pathOld=%s, pathNew=%s)\n"
      (root2string root)
      (Path.toString pathOld) (Path.toString pathNew));
  renameOnHost root (localPath, workingDir, pathOld, pathNew, ui, archOpt)

(* ------------------------------------------------------------ *)

(* Calculate the target working directory and paths for the copy.
      workingDir  is an fspath naming the directory on the target
                  host where the copied file will actually live.
                  (In the case where pathTo names a symbolic link, this
                  will be the parent directory of the file that the
                  symlink points to, not the symlink itself.  Note that
                  this fspath may be outside of the replica, or even
                  on a different volume.)
      realPathTo  is the name of the target file relative to workingDir.
                  (If pathTo names a symlink, this will be the name of
                  the file pointed to by the symlink, not the name of the
                  link itself.)
      tempPathTo  is a temporary file name in the workingDir.  The file (or
                  directory structure) will first be copied here, then
                  "almost atomically" moved onto realPathTo. *)

let setupTargetPathsLocal (fspath, path) =
  let localPath = Update.translatePathLocal fspath path in
  let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in
  let tempPath = Os.tempPath ~fresh:false workingDir realPath in
  Lwt.return (workingDir, realPath, tempPath, localPath)

let setupTargetPaths =
  Remote.registerRootCmd "setupTargetPaths" setupTargetPathsLocal

let rec createDirectories fspath localPath props =
  match props with
    [] ->
      ()
  | desc :: rem ->
      match Path.deconstructRev localPath with
        None ->
          assert false
      | Some (_, parentPath) ->
          createDirectories fspath parentPath rem;
          try
            let absolutePath = Fspath.concat fspath parentPath in
             Fs.mkdir absolutePath (Props.perms desc)
            (* The directory may have already been created
               if there are several paths with the same prefix *)
          with Unix.Unix_error (Unix.EEXIST, _, _) -> ()

let setupTargetPathsAndCreateParentDirectoryLocal (fspath, (path, props)) =
  let localPath = Update.translatePathLocal fspath path in
  Util.convertUnixErrorsToTransient
    "creating parent directories"
    (fun () -> createDirectories fspath localPath props);
  let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in
  let tempPath = Os.tempPath ~fresh:false workingDir realPath in
  Lwt.return (workingDir, realPath, tempPath, localPath)

let setupTargetPathsAndCreateParentDirectory =
  Remote.registerRootCmd "setupTargetPathsAndCreateParentDirectory"
    setupTargetPathsAndCreateParentDirectoryLocal

(* ------------------------------------------------------------ *)

let updateSourceArchiveLocal (fspathFrom, (localPathFrom, uiFrom, errPaths)) =
  (* Archive update must be done first (before Stasher call) *)
  let newArch = Update.updateArchive fspathFrom localPathFrom uiFrom in
  (* We update the archive with what we were expected to copy *)
  Update.replaceArchiveLocal fspathFrom localPathFrom newArch;
  (* Then, we remove all pieces of which the copy failed *)
  List.iter
    (fun p ->
       debug (fun () ->
         Util.msg "Copy under %s/%s was aborted\n"
           (Fspath.toDebugString fspathFrom) (Path.toString p));
       Update.replaceArchiveLocal fspathFrom p Update.NoArchive)
    errPaths;
  Stasher.stashCurrentVersion fspathFrom localPathFrom None;
  Lwt.return ()

let updateSourceArchive =
  Remote.registerRootCmd "updateSourceArchive" updateSourceArchiveLocal

(* ------------------------------------------------------------ *)

let deleteSpuriousChild fspathTo pathTo nm =
  (* FIX: maybe we should turn them into Unison temporary files? *)
  let path = (Path.child pathTo nm) in
  debug (fun() -> Util.msg "Deleting spurious file %s/%s\n"
                    (Fspath.toDebugString fspathTo) (Path.toString path));
  Os.delete fspathTo path

let rec deleteSpuriousChildrenRec fspathTo pathTo archChildren children =
  match archChildren, children with
    archNm :: archRem, nm :: rem ->
      let c = Name.compare archNm nm in
      if c < 0 then
        deleteSpuriousChildrenRec fspathTo pathTo archRem children
      else if c = 0 then
        deleteSpuriousChildrenRec fspathTo pathTo archChildren rem
      else begin
        deleteSpuriousChild fspathTo pathTo nm;
        deleteSpuriousChildrenRec fspathTo pathTo archChildren rem
      end
  | [], nm :: rem ->
      deleteSpuriousChild fspathTo pathTo nm;
      deleteSpuriousChildrenRec fspathTo pathTo [] rem
  | _, [] ->
      ()

let deleteSpuriousChildrenLocal (_, (fspathTo, pathTo, archChildren)) =
  deleteSpuriousChildrenRec
    fspathTo pathTo archChildren
    (List.sort Name.compare (Os.childrenOf fspathTo pathTo));
  Lwt.return ()

let deleteSpuriousChildren =
  Remote.registerRootCmd "deleteSpuriousChildren" deleteSpuriousChildrenLocal

let rec normalizePropsRec propsFrom propsTo =
  match propsFrom, propsTo with
    d :: r, d' :: r' -> normalizePropsRec r r'
  | _, []            -> propsFrom
  | [], _ :: _       -> assert false

let normalizeProps propsFrom propsTo =
  normalizePropsRec (Safelist.rev propsFrom) (Safelist.rev propsTo)

(* ------------------------------------------------------------ *)

let copyReg = Lwt_util.make_region 50

let copy
      update
      rootFrom pathFrom   (* copy from here... *)
      uiFrom              (* (and then check that this updateItem still
                             describes the current state of the src replica) *)
      propsFrom           (* the properties of the parent directories, in
                             case we need to propagate them *)
      rootTo pathTo       (* ...to here *)
      uiTo                (* (but, before committing the copy, check that
                             this updateItem still describes the current
                             state of the target replica) *)
      propsTo             (* the properties of the parent directories *)
      id =                (* for progress display *)
  debug (fun() ->
    Util.msg
      "copy %s %s ---> %s %s \n"
      (root2string rootFrom) (Path.toString pathFrom)
      (root2string rootTo) (Path.toString pathTo));
  (* Calculate target paths *)
  setupTargetPathsAndCreateParentDirectory rootTo
    (pathTo, normalizeProps propsFrom propsTo)
     >>= fun (workingDir, realPathTo, tempPathTo, localPathTo) ->
  (* When in Unicode case-insensitive mode, we want to create files
     with NFC normal-form filenames. *)
  let realPathTo =
    match update with
      `Update _ ->
        realPathTo
    | `Copy ->
        match Path.deconstructRev realPathTo with
          None ->
            assert false
        | Some (name, parentPath) ->
            Path.child parentPath (Name.normalize name)
  in
  (* Calculate source path *)
  Update.translatePath rootFrom pathFrom >>= fun localPathFrom ->
  let errors = ref [] in
  (* Inner loop for recursive copy... *)
  let rec copyRec pFrom      (* Path to copy from *)
                  pTo        (* (Temp) path to copy to *)
                  realPTo    (* Path where this file will ultimately be placed
                                (needed by rsync, which uses the old contents
                                of this file to optimize transfer) *)
                  f =        (* Source archive subtree for this path *)
    debug (fun() ->
      Util.msg "copyRec %s --> %s  (really to %s)\n"
        (Path.toString pFrom) (Path.toString pTo)
        (Path.toString realPTo));
    Lwt.catch
      (fun () ->
         match f with
           Update.ArchiveFile (desc, dig, stamp, ress) ->
             Lwt_util.run_in_region copyReg 1 (fun () ->
               Abort.check id;
               let stmp =
                 if Update.useFastChecking () then Some stamp else None in
               Copy.file
                 rootFrom pFrom rootTo workingDir pTo realPTo
                 update desc dig stmp ress id
                 >>= fun info ->
               let ress' = Osx.stamp info.Fileinfo.osX in
               Lwt.return
                 (Update.ArchiveFile (Props.override info.Fileinfo.desc desc,
                                      dig, Fileinfo.stamp info, ress'),
                  []))
         | Update.ArchiveSymlink l ->
             Lwt_util.run_in_region copyReg 1 (fun () ->
               debug (fun() -> Util.msg "Making symlink %s/%s -> %s\n"
                                 (root2string rootTo) (Path.toString pTo) l);
               Abort.check id;
               makeSymlink rootTo (workingDir, pTo, l) >>= fun () ->
               Lwt.return (f, []))
         | Update.ArchiveDir (desc, children) ->
             Lwt_util.run_in_region copyReg 1 (fun () ->
               debug (fun() -> Util.msg "Creating directory %s/%s\n"
                 (root2string rootTo) (Path.toString pTo));
               mkdirOnRoot rootTo (workingDir, pTo))
                 >>= fun (dirAlreadyExisting, initialDesc) ->
             Abort.check id;
             (* We start a thread for each child *)
             let childThreads =
               Update.NameMap.mapi
                 (fun name child ->
                    let nameTo = Name.normalize name in
                    copyRec (Path.child pFrom name)
                            (Path.child pTo nameTo)
                            (Path.child realPTo nameTo)
                            child)
                 children
             in
             (* We collect the thread results *)
             Update.NameMap.fold
               (fun nm childThr remThr ->
                  childThr >>= fun (arch, paths) ->
                  remThr >>= fun (children, pathl, error) ->
                  let childErr = arch = Update.NoArchive in
                  let children =
                    if childErr then children else
                    Update.NameMap.add nm arch children
                  in
                  Lwt.return (children, paths :: pathl, error || childErr))
               childThreads
               (Lwt.return (Update.NameMap.empty, [], false))
               >>= fun (newChildren, pathl, childError) ->
             begin if dirAlreadyExisting || childError then
               let childNames =
                 Update.NameMap.fold (fun nm _ l -> nm :: l) newChildren [] in
               deleteSpuriousChildren rootTo (workingDir, pTo, childNames)
             else
               Lwt.return ()
             end >>= fun () ->
             Lwt_util.run_in_region copyReg 1 (fun () ->
               (* We use the actual file permissions so as to preserve
                  inherited bits *)
               setDirPropOnRoot rootTo
                 (workingDir, pTo, initialDesc, desc)) >>= fun () ->
             Lwt.return (Update.ArchiveDir (desc, newChildren),
                         List.flatten pathl)
         | Update.NoArchive ->
             assert false)
      (fun e ->
         match e with
           Util.Transient _ ->
             if not (Abort.testException e) then begin
               Abort.file id;
               errors := e :: !errors
             end;
             Lwt.return (Update.NoArchive, [pFrom])
         | _ ->
             Lwt.fail e)
  in
  (* Compute locally what we need to propagate *)
  let rootLocal = List.hd (Globals.rootsInCanonicalOrder ()) in
  let localArch =
    Update.updateArchive (snd rootLocal) localPathFrom uiFrom in
  copyRec localPathFrom tempPathTo realPathTo localArch
    >>= fun (archTo, errPaths) ->
  if archTo = Update.NoArchive then
    (* We were not able to transfer anything *)
    Lwt.fail (List.hd !errors)
  else begin
    (* Rename the files to their final location and then update the
       archive on the destination replica *)
    rename rootTo localPathTo workingDir tempPathTo realPathTo uiTo
      (Some archTo) >>= fun () ->
    (* Update the archive on the source replica
       FIX: we could reuse localArch if rootFrom is the same as rootLocal *)
    updateSourceArchive rootFrom (localPathFrom, uiFrom, errPaths) >>= fun () ->
    (* Return the first error, if any *)
    match Safelist.rev !errors with
      e :: _ -> Lwt.fail e
    | []     -> Lwt.return ()
  end

(* ------------------------------------------------------------ *)

let (>>=) = Lwt.bind

let diffCmd =
  Prefs.createString "diff" "diff -u CURRENT2 CURRENT1"
    "!set command for showing differences between files"
    ("This preference can be used to control the name and command-line "
     ^ "arguments of the system "
     ^ "utility used to generate displays of file differences.  The default "
     ^ "is `\\verb|diff -u CURRENT2 CURRENT1|'.  If the value of this preference contains the substrings "
     ^ "CURRENT1 and CURRENT2, these will be replaced by the names of the files to be "
     ^ "diffed.  If not, the two filenames will be appended to the command.  In both "
     ^ "cases, the filenames are suitably quoted.")

let tempName s = Os.tempFilePrefix ^ s

let rec diff root1 path1 ui1 root2 path2 ui2 showDiff id =
  debug (fun () ->
    Util.msg
      "diff %s %s %s %s ...\n"
      (root2string root1) (Path.toString path1)
      (root2string root2) (Path.toString path2));
  let displayDiff fspath1 fspath2 =
    let cmd =
      if Util.findsubstring "CURRENT1" (Prefs.read diffCmd) = None then
          (Prefs.read diffCmd)
        ^ " " ^ (Fspath.quotes fspath1)
        ^ " " ^ (Fspath.quotes fspath2)
      else
        Util.replacesubstrings (Prefs.read diffCmd)
          ["CURRENT1", Fspath.quotes fspath1;
           "CURRENT2", Fspath.quotes fspath2] in
    let c = System.open_process_in
      (if Util.osType = `Win32 && not Util.isCygwin then
        (* BCP: Proposed by Karl M. to deal with the standard windows 
           command processor's weird treatment of spaces and quotes: *)
        "\"" ^ cmd ^ "\""
       else
         cmd) in
    showDiff cmd (External.readChannelTillEof c);
    ignore (System.close_process_in c) in
  let (desc1, fp1, ress1, desc2, fp2, ress2) = Common.fileInfos ui1 ui2 in
  match root1,root2 with
    (Local,fspath1),(Local,fspath2) ->
      Util.convertUnixErrorsToTransient
        "diffing files"
        (fun () ->
           let path1 = Update.translatePathLocal fspath1 path1 in
           let path2 = Update.translatePathLocal fspath2 path2 in
           displayDiff
             (Fspath.concat fspath1 path1) (Fspath.concat fspath2 path2))
  | (Local,fspath1),(Remote host2,fspath2) ->
      Util.convertUnixErrorsToTransient
        "diffing files"
        (fun () ->
           let path1 = Update.translatePathLocal fspath1 path1 in
           let (workingDir, realPath) = Fspath.findWorkingDir fspath1 path1 in
           let tmppath =
             Path.addSuffixToFinalName realPath (tempName "diff-") in
           Os.delete workingDir tmppath;
           Lwt_unix.run
             (Update.translatePath root2 path2 >>= (fun path2 ->
              Copy.file root2 path2 root1 workingDir tmppath realPath
                `Copy (Props.setLength Props.fileSafe (Props.length desc2))
                 fp2 None ress2 id) >>= fun info ->
              Lwt.return ());
           displayDiff
	     (Fspath.concat workingDir realPath)
             (Fspath.concat workingDir tmppath);
           Os.delete workingDir tmppath)
  | (Remote host1,fspath1),(Local,fspath2) ->
      Util.convertUnixErrorsToTransient
        "diffing files"
        (fun () ->
           let path2 = Update.translatePathLocal fspath2 path2 in
           let (workingDir, realPath) = Fspath.findWorkingDir fspath2 path2 in
           let tmppath =
             Path.addSuffixToFinalName realPath "#unisondiff-" in
           Lwt_unix.run
             (Update.translatePath root1 path1 >>= (fun path1 ->
              (* Note that we don't need the resource fork *)
              Copy.file root1 path1 root2 workingDir tmppath realPath
                `Copy (Props.setLength Props.fileSafe (Props.length desc1))
                 fp1 None ress1 id >>= fun info ->
              Lwt.return ()));
           displayDiff
             (Fspath.concat workingDir tmppath)
	     (Fspath.concat workingDir realPath);
           Os.delete workingDir tmppath)
  | (Remote host1,fspath1),(Remote host2,fspath2) ->
      assert false


(**********************************************************************)

(* Taken from ocamltk/jpf/fileselect.ml *)
let get_files_in_directory dir =
  let dirh = System.opendir dir in
  let files = ref [] in
  begin try
    while true do files := dirh.System.readdir () :: !files done
  with End_of_file ->
    dirh.System.closedir ()
  end;
  Sort.list (<) !files

let ls dir pattern =
  Util.convertUnixErrorsToTransient
    "listing files"
    (fun () ->
       let files = get_files_in_directory dir in
       let re = Rx.glob pattern in
       let rec filter l =
         match l with
           [] ->
             []
         | hd :: tl ->
             if Rx.match_string re hd then hd :: filter tl else filter tl
       in
       filter files)


(***********************************************************************
                  CALL OUT TO EXTERNAL MERGE PROGRAM
************************************************************************)

let formatMergeCmd p f1 f2 backup out1 out2 outarch =
  if not (Globals.shouldMerge p) then
    raise (Util.Transient ("'merge' preference not set for "^(Path.toString p)));
  let raw =
    try Globals.mergeCmdForPath p
    with Not_found ->
      raise (Util.Transient ("'merge' preference does not provide a command "
                             ^ "template for " ^ (Path.toString p)))
  in
  let cooked = raw in
  let cooked = Util.replacesubstring cooked "CURRENT1" f1 in
  let cooked = Util.replacesubstring cooked "CURRENT2" f2 in
  let cooked =
    match backup with
      None -> begin
	let cooked = Util.replacesubstring cooked "CURRENTARCHOPT" "" in
	match Util.findsubstring "CURRENTARCH" cooked with
	  None -> cooked
	| Some _ -> raise (Util.Transient
                      ("No archive found, but the 'merge' command "
                       ^ "template expects one.  (Consider enabling "
                       ^ "'backupcurrent' for this file or using CURRENTARCHOPT "
                       ^ "instead of CURRENTARCH.)"))
      end
    | Some(s) ->
	let cooked = Util.replacesubstring cooked "CURRENTARCHOPT" s in
	let cooked = Util.replacesubstring cooked "CURRENTARCH"    s in
        cooked in
  let cooked = Util.replacesubstring cooked "NEW1"     out1 in
  let cooked = Util.replacesubstring cooked "NEW2"     out2 in
  let cooked = Util.replacesubstring cooked "NEWARCH"  outarch in
  let cooked = Util.replacesubstring cooked "NEW" out1 in
  let cooked = Util.replacesubstring cooked "PATH" (Path.toString p) in
  cooked
    
let copyBack fspathFrom pathFrom rootTo pathTo propsTo uiTo id =
  setupTargetPaths rootTo pathTo
    >>= (fun (workingDirForCopy, realPathTo, tempPathTo, localPathTo) ->
  let info = Fileinfo.get false fspathFrom pathFrom in
  let fp = Os.fingerprint fspathFrom pathFrom info in
  let stamp = Osx.stamp info.Fileinfo.osX in
  let newprops = Props.setLength propsTo (Props.length info.Fileinfo.desc) in
  Copy.file
    (Local, fspathFrom) pathFrom rootTo workingDirForCopy tempPathTo realPathTo
    `Copy newprops fp None stamp id >>= fun info ->
  rename rootTo localPathTo workingDirForCopy tempPathTo realPathTo
    uiTo None)
    
let keeptempfilesaftermerge =   
  Prefs.createBool
    "keeptempfilesaftermerge" false "*" ""

let showStatus = function
  | Unix.WEXITED i -> Printf.sprintf "exited (%d)" i
  | Unix.WSIGNALED i -> Printf.sprintf "killed with signal %d" i
  | Unix.WSTOPPED i -> Printf.sprintf "stopped with signal %d" i

let merge root1 path1 ui1 root2 path2 ui2 id showMergeFn =
  debug (fun () -> Util.msg "merge path %s between roots %s and %s\n"
      (Path.toString path1) (root2string root1) (root2string root2));

  (* The following assumes root1 is always local: switch them if needed to make this so *)
  let (root1,path1,ui1,root2,path2,ui2) = 
    match root1 with
      (Local,fspath1) -> (root1,path1,ui1,root2,path2,ui2)
    | _ -> (root2,path2,ui2,root1,path1,ui1) in

  let (localPath1, (workingDirForMerge, basep), fspath1) =
    match root1 with
      (Local,fspath1) ->
        let localPath1 = Update.translatePathLocal fspath1 path1 in
        (localPath1, Fspath.findWorkingDir fspath1 localPath1, fspath1)
    | _ -> assert false in
  
  (* We're going to be doing a lot of copying, so let's define a shorthand
     that fixes most of the arguments to Copy.localfile *)
  let copy l =
    Safelist.iter
      (fun (src,trg) ->
        debug (fun () -> Util.msg "Copying %s to %s\n" (Path.toString src) (Path.toString trg));
        Os.delete workingDirForMerge trg;
        let info = Fileinfo.get false workingDirForMerge src in
        Copy.localFile
          workingDirForMerge src
          workingDirForMerge trg trg
          `Copy info.Fileinfo.desc
          (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) (Some id))
      l in
  
  let working1 = Path.addPrefixToFinalName basep (tempName "merge1-") in
  let working2 = Path.addPrefixToFinalName basep (tempName "merge2-") in
  let workingarch = Path.addPrefixToFinalName basep (tempName "mergearch-") in
  let new1 = Path.addPrefixToFinalName basep (tempName "mergenew1-") in
  let new2 = Path.addPrefixToFinalName basep (tempName "mergenew2-") in
  let newarch = Path.addPrefixToFinalName basep (tempName "mergenewarch-") in
  
  let (desc1, fp1, ress1, desc2, fp2, ress2) = Common.fileInfos ui1 ui2 in
  
  Util.convertUnixErrorsToTransient "merging files" (fun () ->
    (* Install finalizer (below) in case we unwind the stack *)
    Util.finalize (fun () ->
      
    (* Make local copies of the two replicas *)
      Os.delete workingDirForMerge working1;
      Os.delete workingDirForMerge working2;
      Os.delete workingDirForMerge workingarch;
      Lwt_unix.run
	(Copy.file
           root1 localPath1 root1 workingDirForMerge working1 basep
           `Copy desc1 fp1 None ress1 id >>= fun info ->
         Lwt.return ());
      Lwt_unix.run
	(Update.translatePath root2 path2 >>= (fun path2 ->
	  Copy.file
	    root2 path2 root1 workingDirForMerge working2 basep
	    `Copy desc2 fp2 None ress2 id) >>= fun info ->
         Lwt.return ());
      
      (* retrieve the archive for this file, if any *)
      let arch =
	match ui1, ui2 with
	| Updates (_, Previous (_,_,dig,_)), Updates (_, Previous (_,_,dig2,_)) ->
	    if dig = dig2 then
	      Stasher.getRecentVersion fspath1 localPath1 dig 
	    else
	      assert false
	| NoUpdates, Updates(_, Previous (_,_,dig,_))
	| Updates(_, Previous (_,_,dig,_)), NoUpdates -> 
	    Stasher.getRecentVersion fspath1 localPath1 dig
	| Updates (_, New), Updates(_, New) 
	| Updates (_, New), NoUpdates
	| NoUpdates, Updates (_, New) ->
	    debug (fun () -> Util.msg "File is new, no current version will be searched");
	    None
	| _ -> assert false    in
      
      (* Make a local copy of the archive file (in case the merge program  
         overwrites it and the program crashes before the call to the Stasher). *)
      begin
        match arch with 
	  Some fspath ->
	    let info = Fileinfo.get false fspath Path.empty in
	    Copy.localFile 
	      fspath Path.empty 
	      workingDirForMerge workingarch workingarch
	      `Copy 
	      info.Fileinfo.desc
	      (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo)
	      None
	| None ->
	    ()
      end;
	    
      (* run the merge command *)
      Os.delete workingDirForMerge new1;
      Os.delete workingDirForMerge new2;
      Os.delete workingDirForMerge newarch;
      let info1 = Fileinfo.get false workingDirForMerge working1 in
      (* FIX: Why split out the parts of the pair?  Why is it not abstract anyway??? *)
      let dig1 = Os.fingerprint workingDirForMerge working1 info1 in
      let info2 = Fileinfo.get false workingDirForMerge working2 in
      let dig2 = Os.fingerprint workingDirForMerge working2 info2 in
      let cmd = formatMergeCmd
          path1
          (Fspath.quotes (Fspath.concat workingDirForMerge working1))
          (Fspath.quotes (Fspath.concat workingDirForMerge working2))
          (match arch with None -> None | Some f -> Some(Fspath.quotes f))
          (Fspath.quotes (Fspath.concat workingDirForMerge new1))
          (Fspath.quotes (Fspath.concat workingDirForMerge new2))
          (Fspath.quotes (Fspath.concat workingDirForMerge newarch)) in
      Trace.log (Printf.sprintf "Merge command: %s\n" cmd);
      
      let returnValue, mergeResultLog =
        Lwt_unix.run (External.runExternalProgram cmd) in
      
      Trace.log (Printf.sprintf "Merge result (%s):\n%s\n"
                   (showStatus returnValue) mergeResultLog);
      debug (fun () -> Util.msg "Merge result = %s\n"
                   (showStatus returnValue));

      (* This query to the user probably belongs below, after we've gone through all the
         logic that might raise exceptions in various conditions.  But it has the side effect of
         *displaying* the results of the merge (or putting them in a "details" area), so we don't
         want to skip doing it if we raise one of these exceptions.  Better might be to split out
         the displaying from the querying... *)
      if not
          (showMergeFn
             (Printf.sprintf "Results of merging %s" (Path.toString path1))
             mergeResultLog) then
        raise (Util.Transient ("Merge command canceled by the user"));
      
      (* It's useful for now to be a bit verbose about what we're doing, but let's 
         keep it easy to switch this to debug-only in some later release... *)
      let say f = f() in

      (* Check which files got created by the merge command and do something appropriate
         with them *)
      debug (fun()-> Util.msg "New file 1 = %s\n" (Fspath.toDebugString (Fspath.concat workingDirForMerge new1)));
      let new1exists = Fs.file_exists (Fspath.concat workingDirForMerge new1) in
      let new2exists = Fs.file_exists (Fspath.concat workingDirForMerge new2) in
      let newarchexists = Fs.file_exists (Fspath.concat workingDirForMerge newarch) in
      
      if new1exists && new2exists then begin
        if newarchexists then 
	  say (fun () -> Util.msg "Three outputs detected \n")
	else
	  say (fun () -> Util.msg "Two outputs detected \n");
        let info1 = Fileinfo.get false workingDirForMerge new1 in
        let info2 = Fileinfo.get false workingDirForMerge new2 in
        let dig1' = Os.fingerprint workingDirForMerge new1 info1 in
        let dig2' = Os.fingerprint workingDirForMerge new2 info2 in
        if dig1'=dig2' then begin
          debug (fun () -> Util.msg "Two outputs equal => update the archive\n");
          copy [(new1,working1); (new2,working2); (new1,workingarch)];
	end else
	  if returnValue = Unix.WEXITED 0 then begin
            say (fun () -> (Util.msg "Two outputs not equal but merge command returned 0, so we will\n";
   		            Util.msg "overwrite the other replica and the archive with the first output\n"));
	    copy [(new1,working1); (new1,working2); (new1,workingarch)];
	  end else begin
            say (fun () -> (Util.msg "Two outputs not equal and the merge command exited with nonzero status, \n";
		            Util.msg "so we will copy back the new files but not update the archive\n"));
	    copy [(new1,working1); (new2,working2)];
	    
          end 
      end
	  
      else if new1exists && (not new2exists) && (not newarchexists) then begin
	  if returnValue = Unix.WEXITED 0 then begin
            say (fun () -> Util.msg "One output detected \n");
            copy [(new1,working1); (new1,working2); (new1,workingarch)];
	  end else begin
            say (fun () -> Util.msg "One output detected but merge command returned nonzero exit status\n");
            raise (Util.Transient "One output detected but merge command returned nonzero exit status\n")
          end
      end
	  
      else if (not new1exists) && new2exists && (not newarchexists) then begin
        assert false
      end
	  
      else if (not new1exists) && (not new2exists) && (not newarchexists) then begin
        say (fun () -> Util.msg "No outputs detected \n");
        let working1_still_exists = Fs.file_exists (Fspath.concat workingDirForMerge working1) in
        let working2_still_exists = Fs.file_exists (Fspath.concat workingDirForMerge working2) in
	
        if working1_still_exists && working2_still_exists then begin
          say (fun () -> Util.msg "No output from merge cmd and both original files are still present\n");
          let info1' = Fileinfo.get false workingDirForMerge working1 in
          let dig1' = Os.fingerprint workingDirForMerge working1 info1' in
          let info2' = Fileinfo.get false workingDirForMerge working2 in
          let dig2' = Os.fingerprint workingDirForMerge working2 info2' in
          if dig1 = dig1' && dig2 = dig2' then
            raise (Util.Transient "Merge program didn't change either temp file");
          if dig1' = dig2' then begin
            say (fun () -> Util.msg "Merge program made files equal\n");
            copy [(working1,workingarch)];
          end else if dig2 = dig2' then begin
            say (fun () -> Util.msg "Merge program changed just first input\n");
            copy [(working1,working2);(working1,workingarch)]
          end else if dig1 = dig1' then begin
            say (fun () -> Util.msg "Merge program changed just second input\n");
            copy [(working2,working1);(working2,workingarch)]
          end else
	    if returnValue <> Unix.WEXITED 0 then
	      raise (Util.Transient ("Error: the merge function changed both of "
                                     ^ "its inputs but did not make them equal"))
	    else begin
	      say (fun () -> (Util.msg "Merge program changed both of its inputs in";
			      Util.msg "different ways, but returned zero.\n"));
              (* Note that we assume the merge program knew what it was doing when it
                 returned 0 -- i.e., we assume a zero result means that the files are
                 "morally equal" and either can be replaced by the other; we therefore
                 choose one of them (#2) as the unique new result, so that we can update
                 Unison's archive and call the file 'in sync' again. *)
              copy [(working2,working1);(working2,workingarch)];
	    end
        end
	    
        else if working1_still_exists && (not working2_still_exists) 
	    && returnValue = Unix.WEXITED 0 then begin
              say (fun () -> Util.msg "No outputs and second replica has been deleted \n");
              copy [(working1,working2); (working1,workingarch)];
            end
	    
        else if (not working1_still_exists) && working2_still_exists 
	    && returnValue = Unix.WEXITED 0 then begin
              say (fun () -> Util.msg "No outputs and first replica has been deleted \n");
              copy [(working2,working1); (working2,workingarch)];
            end
        else if returnValue = Unix.WEXITED 0 then begin
            raise (Util.Transient ("Error: the merge program deleted both of its "
                                   ^ "inputs and generated no output!"))
        end else begin
            say (fun() -> Util.msg "The merge program exited with nonzero status and did not leave";
			  Util.msg " both files equal");
	    raise (Util.Transient ("Error: the merge program failed and did not leave"
				   ^ " both files equal"))
        end
      end else begin
        assert false
      end;

      Lwt_unix.run
	(debug (fun () -> Util.msg "Committing results of merge\n");
         copyBack workingDirForMerge working1 root1 path1 desc1 ui1 id >>= (fun () ->
         copyBack workingDirForMerge working2 root2 path2 desc2 ui2 id >>= (fun () ->
         let arch_fspath = Fspath.concat workingDirForMerge workingarch in
         if Fs.file_exists arch_fspath then begin
           debug (fun () -> Util.msg "Updating unison archives for %s to reflect results of merge\n"
                   (Path.toString path1));
           if not (Stasher.shouldBackupCurrent path1) then
             Util.msg "Warning: 'backupcurrent' is not set for path %s\n" (Path.toString path1);
           Stasher.stashCurrentVersion workingDirForMerge localPath1 (Some workingarch);
           let infoarch = Fileinfo.get false workingDirForMerge workingarch in
           let dig = Os.fingerprint arch_fspath Path.empty infoarch in
           debug (fun () -> Util.msg "New digest is %s\n" (Os.fullfingerprint_to_string dig));
           let new_archive_entry =
             Update.ArchiveFile
               (Props.get (Fs.stat arch_fspath) infoarch.osX, dig,
                Fileinfo.stamp (Fileinfo.get true arch_fspath Path.empty),
                Osx.stamp infoarch.osX) in
           Update.replaceArchive root1 path1 new_archive_entry >>= fun _ ->
           Update.replaceArchive root2 path2 new_archive_entry >>= fun _ ->
           Lwt.return ()
         end else 
           (Lwt.return ()) )))) )
    (fun _ ->
      Util.ignoreTransientErrors
	(fun () ->
           if not (Prefs.read keeptempfilesaftermerge) then begin
             Os.delete workingDirForMerge working1;
             Os.delete workingDirForMerge working2;
             Os.delete workingDirForMerge workingarch;
             Os.delete workingDirForMerge new1;
             Os.delete workingDirForMerge new2;
             Os.delete workingDirForMerge newarch
           end))