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
4 module Tree = Tree.Make (F)
5 module Commit = Commit.Make (F)
6
7 type t = { backend : hash Backend.t }
8
9 let create ?cache ~backend () =
10 let backend =
11 match cache with
12 | Some n when n > 0 -> Backend.cached ~capacity:n backend
13 | _ -> backend
14 in
15 { backend }
16 let backend t = t.backend
17
18 let tree t ?at () =
19 match at with
20 | None -> Tree.empty ()
21 | Some h -> Tree.of_hash ~backend:t.backend h
22
23 let read_commit t h =
24 match t.backend.read h with
25 | None -> None
26 | Some data -> (
27 match Commit.of_bytes data with Ok c -> Some c | Error _ -> None)
28
29 let read_tree t h = Tree.of_hash ~backend:t.backend h
30
31 let checkout t ~branch =
32 match t.backend.get_ref ("refs/heads/" ^ branch) with
33 | None -> None
34 | Some commit_hash -> (
35 match read_commit t commit_hash with
36 | None -> None
37 | Some commit -> Some (read_tree t (Commit.tree commit)))
38
39 let commit ?inline_threshold ?inode t ~tree ~parents ~message ~author =
40 (* This is where delayed writes happen *)
41 let tree_hash = Tree.hash ?inline_threshold ?inode tree ~backend:t.backend in
42 let c = Commit.v ~tree:tree_hash ~parents ~author ~message () in
43 let data = Commit.to_bytes c in
44 let h = Commit.hash c in
45 t.backend.write h data;
46 h
47
48 let head t ~branch = t.backend.get_ref ("refs/heads/" ^ branch)
49 let set_head t ~branch h = t.backend.set_ref ("refs/heads/" ^ branch) h
50
51 let branches t =
52 t.backend.list_refs ()
53 |> List.filter_map (fun r ->
54 if String.length r > 11 && String.sub r 0 11 = "refs/heads/" then
55 Some (String.sub r 11 (String.length r - 11))
56 else None)
57
58 let update_branch t ~branch ~old ~new_ =
59 t.backend.test_and_set_ref ("refs/heads/" ^ branch) ~test:old
60 ~set:(Some new_)
61
62 (* Simple ancestry check - walks parent chain *)
63 let is_ancestor t ~ancestor ~descendant =
64 let rec walk visited h =
65 if F.hash_equal h ancestor then true
66 else if List.exists (F.hash_equal h) visited then false
67 else
68 match read_commit t h with
69 | None -> false
70 | Some c ->
71 let visited = h :: visited in
72 List.exists (walk visited) (Commit.parents c)
73 in
74 F.hash_equal ancestor descendant || walk [] descendant
75
76 (* Find merge base using simple BFS *)
77 let merge_base t h1 h2 =
78 let rec ancestors_of h visited =
79 if List.exists (F.hash_equal h) visited then visited
80 else
81 match read_commit t h with
82 | None -> h :: visited
83 | Some c ->
84 let visited = h :: visited in
85 List.fold_left
86 (fun acc p -> ancestors_of p acc)
87 visited (Commit.parents c)
88 in
89 let ancestors1 = ancestors_of h1 [] in
90 let rec find_common h =
91 if List.exists (F.hash_equal h) ancestors1 then Some h
92 else
93 match read_commit t h with
94 | None -> None
95 | Some c -> (
96 match Commit.parents c with [] -> None | p :: _ -> find_common p)
97 in
98 find_common h2
99
100 let commits_between t ~base ~head =
101 let rec count h n =
102 if F.hash_equal h base then n
103 else
104 match read_commit t h with
105 | None -> n
106 | Some c -> (
107 match Commit.parents c with [] -> n | p :: _ -> count p (n + 1))
108 in
109 count head 0
110
111 type diff_entry =
112 [ `Add of Tree.path * hash
113 | `Remove of Tree.path
114 | `Change of Tree.path * hash * hash ]
115
116 let diff t ~old ~new_ =
117 let old_tree = read_tree t old in
118 let new_tree = read_tree t new_ in
119
120 let rec diff_trees prefix old_tree new_tree =
121 let old_entries = Tree.list old_tree [] in
122 let new_entries = Tree.list new_tree [] in
123
124 let old_names = List.map fst old_entries in
125 let new_names = List.map fst new_entries in
126
127 (* Entries only in old -> Remove *)
128 let removed =
129 old_names
130 |> List.filter (fun name -> not (List.mem name new_names))
131 |> List.to_seq
132 |> Seq.map (fun name -> `Remove (prefix @ [ name ]))
133 in
134
135 (* Entries only in new -> Add *)
136 let added =
137 new_names
138 |> List.filter (fun name -> not (List.mem name old_names))
139 |> List.to_seq
140 |> Seq.filter_map (fun name ->
141 match Tree.find new_tree [ name ] with
142 | Some content ->
143 let hash = F.hash_contents content in
144 Some (`Add (prefix @ [ name ], hash))
145 | None ->
146 (* It's a subtree - handled by added_subtrees recursion below *)
147 None)
148 in
149
150 (* Entries in both -> check for changes *)
151 let common =
152 List.filter (fun name -> List.mem name new_names) old_names
153 in
154 let changes =
155 common |> List.to_seq
156 |> Seq.flat_map (fun name ->
157 let path = prefix @ [ name ] in
158 let old_kind = List.assoc name old_entries in
159 let new_kind = List.assoc name new_entries in
160 match (old_kind, new_kind) with
161 | `Contents, `Contents -> (
162 match
163 (Tree.find old_tree [ name ], Tree.find new_tree [ name ])
164 with
165 | Some old_c, Some new_c ->
166 let old_h = F.hash_contents old_c in
167 let new_h = F.hash_contents new_c in
168 if F.hash_equal old_h new_h then Seq.empty
169 else Seq.return (`Change (path, old_h, new_h))
170 | _ -> Seq.empty)
171 | `Node, `Node -> (
172 match
173 ( Tree.find_tree old_tree [ name ],
174 Tree.find_tree new_tree [ name ] )
175 with
176 | Some old_sub, Some new_sub -> diff_trees path old_sub new_sub
177 | _ -> Seq.empty)
178 | `Contents, `Node ->
179 (* Changed from contents to tree - remove old contents *)
180 Seq.return (`Remove path)
181 |> Seq.append
182 (match Tree.find_tree new_tree [ name ] with
183 | Some sub -> diff_trees path (Tree.empty ()) sub
184 | None -> Seq.empty)
185 | `Node, `Contents ->
186 (* Changed from tree to contents - add new contents *)
187 (match Tree.find new_tree [ name ] with
188 | Some c ->
189 let new_h = F.hash_contents c in
190 Seq.return (`Add (path, new_h))
191 | None -> Seq.empty)
192 |> Seq.append
193 (match Tree.find_tree old_tree [ name ] with
194 | Some sub -> diff_trees path sub (Tree.empty ())
195 | None -> Seq.empty))
196 in
197
198 (* Also recurse into added subtrees *)
199 let added_subtrees =
200 new_names
201 |> List.filter (fun name -> not (List.mem name old_names))
202 |> List.to_seq
203 |> Seq.flat_map (fun name ->
204 match Tree.find_tree new_tree [ name ] with
205 | Some sub -> diff_trees (prefix @ [ name ]) (Tree.empty ()) sub
206 | None -> Seq.empty)
207 in
208
209 (* Also recurse into removed subtrees *)
210 let removed_subtrees =
211 old_names
212 |> List.filter (fun name -> not (List.mem name new_names))
213 |> List.to_seq
214 |> Seq.flat_map (fun name ->
215 match Tree.find_tree old_tree [ name ] with
216 | Some sub -> diff_trees (prefix @ [ name ]) sub (Tree.empty ())
217 | None -> Seq.empty)
218 in
219
220 Seq.append removed
221 (Seq.append added
222 (Seq.append changes (Seq.append added_subtrees removed_subtrees)))
223 in
224 diff_trees [] old_tree new_tree
225end
226
227module Git = Make (Codec.Git)
228module Mst = Make (Codec.Mst)