lib/kernel/Initialization.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
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

type address = Concepts.Hash.hash

type t =
  { default_branch: string;
    branches: address }

let fixed_label = "rnt.boot"
let fixed_label_address = Concepts.Hash.hash_of_bytes (Bytes.of_string fixed_label)

module Field = struct
  let default_branch = "default_branch"
  let branches = "branches"
end

module Error = struct
  open Concepts.Condition

  let malformed_initialization () =
    condition "initialization-malformed"
      "An initialization representation did not conform to what was expected" empty

  let malformed_hash length =
    condition "initialization-malformed-hash"
      "An initialization address was not a valid hash"
      ("length" |=| Concepts.Value.Integer length)

  let missing_target address =
    condition "initialization-target-missing"
      "The fixed initialization label points at a missing object"
      ("address" |=| Concepts.Value.String (Concepts.Hash.to_raw_string address))
end

let make ~default_branch ~branches = {default_branch; branches}

let default_branch initialization = initialization.default_branch
let branches initialization = initialization.branches

module Body = struct
  type nonrec t = t

  let tag = 'i'
  let malformed = Error.malformed_initialization

  let equal left right =
    String.equal left.default_branch right.default_branch
    && Concepts.Hash.hash_equals left.branches right.branches

  let fields initialization =
    [ Field.default_branch, Concepts.Object.Field.string initialization.default_branch;
      Field.branches, Concepts.Object.Field.address initialization.branches ]

  let of_fields data =
    let open Utilities.Result in
    let* default_branch =
      Concepts.Object.Field.require_string Field.default_branch data
    in
    let* branches =
      Concepts.Object.Field.require_address ~malformed:Error.malformed_hash Field.branches data
    in
    Ok {default_branch; branches}
end

include (Concepts.Object.Codec.Make (Body) : Concepts.Object.S with type t := t)

let address initialization = to_blob initialization |> Concepts.Hash.hash_of_blob

let address_to_blob address =
  Concepts.Object.Field.address address |> Concepts.Codec.Bencode.to_blob

let address_of_blob blob =
  let open Utilities.Result in
  let* data = Concepts.Codec.Bencode.of_blob blob in
  let* raw = Concepts.Codec.Bencode.as_string data in
  if String.length raw = Concepts.Hash.size then Ok (Concepts.Hash.of_raw_string raw)
  else Error (Error.malformed_hash (String.length raw))

module Make (Store : Abstract.Storage.STORAGE) = struct
  let register tx initialization =
    let open Utilities.Result in
    let blob = to_blob initialization in
    let initialization_address = Concepts.Hash.hash_of_blob blob in
    let* () = Store.put tx initialization_address blob in
    let* () = Store.put tx fixed_label_address (address_to_blob initialization_address) in
    Ok initialization_address

  let load tx =
    let open Utilities.Result in
    let* label = Store.get tx fixed_label_address in
    match label with
    | None -> Ok None
    | Some label ->
        let* initialization_address = address_of_blob label in
        let* initialization = Store.get tx initialization_address in
        begin match initialization with
        | None -> Error (Error.missing_target initialization_address)
        | Some initialization ->
            let* initialization = of_blob initialization in
            Ok (Some initialization)
        end
end