Source file gc.ml

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
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019,2020 DaiLambda, Inc. <contact@dailambda.jp>            *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Result_lwt.Infix

type Error.t +=
  | GC_invalid_bases of string
  | GC_copy_hash_mismatch

let () = Error.register_printer (function
    | GC_invalid_bases s -> Some (Printf.sprintf "GC: invalid bases: %s" s)
    | GC_copy_hash_mismatch -> Some "GC: copy hash does not agree with the source"
    | _ -> None)

let copy ~base_src ~src ~base_dst =
  let check_src_ctxts () =
    if not (Cursor.context base_src == Cursor.context src) then
      Error (GC_invalid_bases "Source base and src use different contexts")
    else Ok (Cursor.context src)
  in

  let check_base_nhs () =
    let base_src, base_src_nh = Cursor.compute_hash base_src in
    let base_dst, base_dst_nh = Cursor.compute_hash base_dst in
    if base_src_nh <> base_dst_nh then Error (GC_invalid_bases "Hashes of bases are not equal")
    else Ok (base_src, base_dst)
  in

  check_src_ctxts () >>? fun src_ctxt ->
  check_base_nhs () >>? fun (base_src, base_dst) ->

  let src, src_nh = Cursor.compute_hash src in

  let Cursor (_, base_src_n, _, _) = base_src in
  let Cursor (_, src_n, _, _) = src in


  let diffs = Diff.diff src_ctxt base_src_n src_n in

  let dst = base_dst in

  (* XXX The sharings of Diff.t are lost by Diff.apply *)
  Result.fold_leftM (fun dst d ->
      let d = match d with
        | Diff.Add (n, segs) ->
            Diff.Add (Node_storage.read_node_fully ~reset_index:true src_ctxt n, segs)
        | d -> d
      in
      Diff.apply dst d) dst diffs >>? fun dst ->

  let dst, dst_nh = Cursor.compute_hash dst in
  if src_nh = dst_nh then Ok dst
  else Error GC_copy_hash_mismatch