blob: 767dcca1fe6f723d0ca1fd0b4a30877252bdfdf9 (
plain) (
blame)
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
|
type address = Concepts.Hash.hash
type branch_index_root = address
let fixed_label = "rnt.initialization"
let fixed_label_address = Concepts.Hash.hash_of_bytes (Bytes.of_string fixed_label)
module Error = struct
open Concepts.Condition
let malformed_address length =
condition "initialization-malformed-address"
"The initialization fixed key does not contain a valid address"
("length" |=| Concepts.Value.Integer length)
let missing_branch_index address =
condition "initialization-branch-index-missing"
"The initialization fixed key points at a missing branch index"
("address" |=| Concepts.Value.String (Concepts.Hash.to_raw_string address))
end
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_address (String.length raw))
module Make (Store : Abstract.Storage.STORAGE) = struct
module Branch_index = BranchIndex.Make (Store)
let finish tx = function
| Ok value ->
let open Utilities.Result in
let* () = Store.commit tx in
Ok value
| Error condition ->
let _ = Store.abort tx in
Error condition
let with_transaction connection body =
let open Utilities.Result in
let* tx = Store.start connection in
body tx |> finish tx
let read_in_transaction tx =
let open Utilities.Result in
let* fixed = Store.get tx fixed_label_address in
match fixed with
| None -> Ok None
| Some fixed ->
let* root = address_of_blob fixed in
let* branch_index = Branch_index.find tx root in
begin match branch_index with
| Some _ -> Ok (Some root)
| None -> Error (Error.missing_branch_index root)
end
let store_blob tx blob =
let open Utilities.Result in
let address = Concepts.Hash.hash_of_blob blob in
let* () = Store.put tx address blob in
Ok address
let store_fixed_root tx root = Store.put tx fixed_label_address (address_to_blob root)
let create_initial_branch_state tx =
let open Utilities.Result in
(* The first branch state has no synthetic "genesis" commit. Both [current]
and [history] point at persisted empty trees; the runtime mounts /system
around those roots after initialization. *)
let* empty_root = Branch_index.persist tx Branch_index.empty in
Concepts.BranchState.make ~current:empty_root ~history:empty_root ~tip:None
|> Concepts.BranchState.to_blob
|> store_blob tx
let ensure_default_branch tx root branch_index =
let open Utilities.Result in
let* current = Branch_index.find_branch tx BranchIndex.default_branch_name branch_index in
match current with
| Some _ -> Ok root
| None ->
(* Older initialization slices could leave a valid but empty branch
index. Repair it by publishing a new root containing master. *)
let* branch_state = create_initial_branch_state tx in
let* branch_index =
Branch_index.put_branch tx BranchIndex.default_branch_name branch_state branch_index
in
Ok (Branch_index.hash_of branch_index)
let create_in_transaction tx =
let open Utilities.Result in
let* branch_state = create_initial_branch_state tx in
let* branch_index =
Branch_index.put_branch tx BranchIndex.default_branch_name branch_state Branch_index.empty
in
let root = Branch_index.hash_of branch_index in
let* () = store_fixed_root tx root in
Ok root
let read connection = with_transaction connection read_in_transaction
let initialize connection =
with_transaction connection (fun tx ->
let open Utilities.Result in
let* current = read_in_transaction tx in
match current with
| None -> create_in_transaction tx
| Some root ->
let* branch_index = Branch_index.find tx root in
begin match branch_index with
| None -> Error (Error.missing_branch_index root)
| Some branch_index ->
let* root' = ensure_default_branch tx root branch_index in
let* () =
if Concepts.Hash.hash_equals root root' then Ok () else store_fixed_root tx root'
in
Ok root'
end )
end
|
