vblt.org
forked from
gazagnaire.org/irmin
Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
1module Make (F : Codec.S) = struct
2 type hash = F.hash
3 type path = string list
4 type concrete = [ `Contents of string | `Tree of (string * concrete) list ]
5
6 (* Internal tree representation with lazy loading *)
7 type node_state =
8 | Loaded of F.node
9 | Lazy of { backend : hash Backend.t; hash : hash }
10 | Shallow of hash
11 | Pruned of hash
12
13 type tree_node =
14 | Contents of string
15 | Node of {
16 mutable state : node_state;
17 mutable children : (string * tree_node) list; (* modifications *)
18 mutable removed : string list;
19 }
20
21 type t = tree_node
22
23 let empty () =
24 Node { state = Loaded F.empty_node; children = []; removed = [] }
25
26 let of_hash ~backend hash =
27 Node { state = Lazy { backend; hash }; children = []; removed = [] }
28
29 let shallow hash = Node { state = Shallow hash; children = []; removed = [] }
30 let pruned hash = Node { state = Pruned hash; children = []; removed = [] }
31
32 let rec of_concrete : concrete -> t = function
33 | `Contents s -> Contents s
34 | `Tree entries ->
35 let children =
36 List.map (fun (name, c) -> (name, of_concrete c)) entries
37 in
38 Node { state = Loaded F.empty_node; children; removed = [] }
39
40 (* Force loading of a lazy node *)
41 let force_node state =
42 match state with
43 | Loaded n -> Some n
44 | Lazy { backend; hash } -> (
45 match backend.read hash with
46 | Some data -> (
47 match F.node_of_bytes data with Ok n -> Some n | Error _ -> None)
48 | None -> None)
49 | Shallow _ -> None
50 | Pruned _ -> None
51
52 (* Navigate to a path, returning the node and remaining path *)
53 let rec navigate t path =
54 match (t, path) with
55 | _, [] -> Some (t, [])
56 | Contents _, _ :: _ -> None
57 | Node node, name :: rest -> (
58 (* Check modifications first *)
59 match List.assoc_opt name node.children with
60 | Some child -> navigate child rest
61 | None -> (
62 if List.mem name node.removed then None
63 else
64 (* Try to load from underlying node *)
65 match force_node node.state with
66 | None -> None
67 | Some loaded -> (
68 match F.find loaded name with
69 | None -> None
70 | Some (`Contents hash) -> (
71 (* Load the content blob *)
72 match node.state with
73 | Lazy { backend; _ } -> (
74 match backend.read hash with
75 | Some data -> navigate (Contents data) rest
76 | None -> None)
77 | _ -> None)
78 | Some (`Node hash) -> (
79 match node.state with
80 | Lazy { backend; _ } ->
81 let child = of_hash ~backend hash in
82 navigate child rest
83 | _ -> None))))
84
85 let find t path =
86 match navigate t path with Some (Contents s, []) -> Some s | _ -> None
87
88 let find_tree t path =
89 match navigate t path with Some ((Node _ as n), []) -> Some n | _ -> None
90
91 let mem t path = Option.is_some (navigate t path)
92
93 let mem_tree t path =
94 match navigate t path with Some (Node _, []) -> true | _ -> false
95
96 let list t path =
97 match navigate t path with
98 | Some (Node node, []) -> (
99 match force_node node.state with
100 | None -> []
101 | Some loaded ->
102 let base_entries =
103 F.list loaded
104 |> List.filter (fun (name, _) ->
105 (not (List.mem name node.removed))
106 && not (List.mem_assoc name node.children))
107 |> List.map (fun (name, kind) ->
108 let k =
109 match kind with
110 | `Node _ -> `Node
111 | `Contents _ -> `Contents
112 in
113 (name, k))
114 in
115 let child_entries =
116 List.map
117 (fun (name, child) ->
118 let k =
119 match child with Node _ -> `Node | Contents _ -> `Contents
120 in
121 (name, k))
122 node.children
123 in
124 List.sort
125 (fun (a, _) (b, _) -> String.compare a b)
126 (base_entries @ child_entries))
127 | _ -> []
128
129 (* Add contents at path, creating intermediate nodes as needed *)
130 let rec add_at t path value =
131 match (t, path) with
132 | _, [] -> value
133 | Contents _, _ :: _ ->
134 (* Replace contents with a tree *)
135 add_at (empty ()) path value
136 | Node node, [ name ] ->
137 let children =
138 (name, value) :: List.filter (fun (n, _) -> n <> name) node.children
139 in
140 let removed = List.filter (( <> ) name) node.removed in
141 Node { node with children; removed }
142 | Node node, name :: rest ->
143 let child =
144 match List.assoc_opt name node.children with
145 | Some c -> c
146 | None -> (
147 if List.mem name node.removed then empty ()
148 else
149 match force_node node.state with
150 | None -> empty ()
151 | Some loaded -> (
152 match F.find loaded name with
153 | Some (`Node hash) -> (
154 match node.state with
155 | Lazy { backend; _ } -> of_hash ~backend hash
156 | _ -> empty ())
157 | _ -> empty ()))
158 in
159 let new_child = add_at child rest value in
160 let children =
161 (name, new_child)
162 :: List.filter (fun (n, _) -> n <> name) node.children
163 in
164 Node { node with children }
165
166 let add t path contents = add_at t path (Contents contents)
167 let add_tree t path subtree = add_at t path subtree
168
169 let rec remove t path =
170 match (t, path) with
171 | _, [] -> empty ()
172 | Contents _, _ :: _ -> t
173 | Node node, [ name ] ->
174 let children = List.filter (fun (n, _) -> n <> name) node.children in
175 let removed =
176 if List.mem name node.removed then node.removed
177 else name :: node.removed
178 in
179 Node { node with children; removed }
180 | Node node, name :: rest ->
181 let child =
182 match List.assoc_opt name node.children with
183 | Some c -> c
184 | None -> (
185 if List.mem name node.removed then empty ()
186 else
187 match force_node node.state with
188 | None -> empty ()
189 | Some loaded -> (
190 match F.find loaded name with
191 | Some (`Node hash) -> (
192 match node.state with
193 | Lazy { backend; _ } -> of_hash ~backend hash
194 | _ -> empty ())
195 | _ -> empty ()))
196 in
197 let new_child = remove child rest in
198 let children =
199 (name, new_child)
200 :: List.filter (fun (n, _) -> n <> name) node.children
201 in
202 Node { node with children }
203
204 let rec to_concrete t =
205 match t with
206 | Contents s -> `Contents s
207 | Node node ->
208 let entries =
209 match force_node node.state with
210 | None -> []
211 | Some loaded ->
212 F.list loaded
213 |> List.filter_map (fun (name, _kind) ->
214 if List.mem name node.removed then None
215 else if List.mem_assoc name node.children then None
216 else
217 (* Would need to recursively load - simplified here *)
218 None)
219 in
220 let child_entries =
221 List.map
222 (fun (name, child) -> (name, to_concrete child))
223 node.children
224 in
225 let all =
226 List.sort
227 (fun (a, _) (b, _) -> String.compare a b)
228 (entries @ child_entries)
229 in
230 `Tree all
231
232 (* Write tree to backend and return hash *)
233 let rec write_tree t ~(backend : hash Backend.t) : hash =
234 match t with
235 | Contents s ->
236 let h = F.hash_contents s in
237 backend.write h s;
238 h
239 | Node node ->
240 (* First, get the base node *)
241 let base =
242 match force_node node.state with Some n -> n | None -> F.empty_node
243 in
244 (* Apply removals *)
245 let base =
246 List.fold_left (fun n name -> F.remove n name) base node.removed
247 in
248 (* Apply additions (recursively writing children) *)
249 let final =
250 List.fold_left
251 (fun n (name, child) ->
252 let child_hash = write_tree child ~backend in
253 let kind =
254 match child with
255 | Contents _ -> `Contents child_hash
256 | Node _ -> `Node child_hash
257 in
258 F.add n name kind)
259 base node.children
260 in
261 let data = F.bytes_of_node final in
262 let h = F.hash_node final in
263 backend.write h data;
264 h
265
266 let hash t ~backend = write_tree t ~backend
267
268 type 'a force = [ `True | `False of hash -> 'a | `Shallow of hash -> 'a ]
269
270 let fold ?(force = `True) t init f =
271 let rec go path t acc =
272 match t with
273 | Contents s -> f path (`Contents s) acc
274 | Node node -> (
275 let acc = f path `Tree acc in
276 match force with
277 | `True -> (
278 match force_node node.state with
279 | None -> acc
280 | Some _loaded ->
281 (* Fold over children *)
282 List.fold_left
283 (fun acc (name, child) -> go (path @ [ name ]) child acc)
284 acc node.children)
285 | `False fn -> (
286 match node.state with
287 | Lazy { hash; _ } -> fn hash
288 | Shallow hash -> fn hash
289 | Pruned hash -> fn hash
290 | Loaded _ ->
291 List.fold_left
292 (fun acc (name, child) -> go (path @ [ name ]) child acc)
293 acc node.children)
294 | `Shallow fn -> (
295 match node.state with
296 | Shallow hash -> fn hash
297 | _ ->
298 List.fold_left
299 (fun acc (name, child) -> go (path @ [ name ]) child acc)
300 acc node.children))
301 in
302 go [] t init
303
304 let clear ?depth:_ _t = ()
305
306 let equal t1 t2 =
307 (* Simple structural equality - could be optimized with hash comparison *)
308 to_concrete t1 = to_concrete t2
309end
310
311module Git = Make (Codec.Git)
312module Mst = Make (Codec.Mst)