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 Store = Store.Make (F)
5 module Tree = Store.Tree
6 module Commit = Store.Commit
7
8 type status =
9 [ `In_sync
10 | `Local_ahead of int
11 | `Remote_ahead of int
12 | `Diverged of int * int (* local, remote *)
13 | `Trees_differ ]
14
15 (* Extract subtree at prefix from a tree *)
16 let extract_subtree tree prefix = Tree.find_tree tree prefix
17
18 (* Check if a commit touches the given prefix *)
19 let commit_touches_prefix store commit prefix =
20 let tree = Store.read_tree store (Commit.tree commit) in
21 Option.is_some (Tree.find_tree tree prefix)
22
23 (* Split: Extract subtree history into a new store *)
24 let split store ~prefix =
25 let backend = Backend.Memory.create_with_hash F.hash_to_hex F.hash_equal in
26 let new_store = Store.create ~backend in
27
28 (* Walk commits and rewrite those touching prefix *)
29 let rec rewrite_commit old_hash rewritten =
30 if List.mem_assoc old_hash rewritten then
31 (List.assoc old_hash rewritten, rewritten)
32 else
33 match Store.read_commit store old_hash with
34 | None -> (old_hash, rewritten)
35 | Some commit -> (
36 if not (commit_touches_prefix store commit prefix) then
37 (* Skip commits not touching prefix *)
38 match Commit.parents commit with
39 | [] -> (old_hash, rewritten)
40 | p :: _ -> rewrite_commit p rewritten
41 else
42 (* Rewrite parents first *)
43 let parents, rewritten =
44 List.fold_left
45 (fun (parents, rw) p ->
46 let new_p, rw = rewrite_commit p rw in
47 (new_p :: parents, rw))
48 ([], rewritten) (Commit.parents commit)
49 in
50 let parents = List.rev parents in
51
52 (* Extract subtree *)
53 let tree = Store.read_tree store (Commit.tree commit) in
54 match extract_subtree tree prefix with
55 | None -> (old_hash, rewritten)
56 | Some subtree ->
57 let new_hash =
58 Store.commit new_store ~tree:subtree ~parents
59 ~message:(Commit.message commit)
60 ~author:(Commit.author commit)
61 in
62 (new_hash, (old_hash, new_hash) :: rewritten))
63 in
64
65 (* Start from main branch head *)
66 (match Store.head store ~branch:"main" with
67 | Some head ->
68 let new_head, _ = rewrite_commit head [] in
69 Store.set_head new_store ~branch:"main" new_head
70 | None -> ());
71
72 new_store
73
74 (* Add: Add external repo as subtree *)
75 let add store ~prefix ~source =
76 match Store.head source ~branch:"main" with
77 | None -> failwith "Source has no main branch"
78 | Some source_head -> (
79 match Store.read_commit source source_head with
80 | None -> failwith "Cannot read source commit"
81 | Some source_commit ->
82 let source_tree =
83 Store.read_tree source (Commit.tree source_commit)
84 in
85
86 (* Get current tree or empty *)
87 let current_tree =
88 match Store.head store ~branch:"main" with
89 | None -> Tree.empty ()
90 | Some h -> (
91 match Store.read_commit store h with
92 | None -> Tree.empty ()
93 | Some c -> Store.read_tree store (Commit.tree c))
94 in
95
96 (* Add source tree at prefix *)
97 let new_tree = Tree.add_tree current_tree prefix source_tree in
98
99 let parents =
100 match Store.head store ~branch:"main" with
101 | None -> []
102 | Some h -> [ h ]
103 in
104
105 let message =
106 Fmt.str "Add '%s' from external source" (String.concat "/" prefix)
107 in
108
109 let new_head =
110 Store.commit store ~tree:new_tree ~parents ~message
111 ~author:"irmin-subtree"
112 in
113 Store.set_head store ~branch:"main" new_head;
114 new_head)
115
116 (* Pull: Update subtree from external source *)
117 let pull store ~prefix ~source =
118 match Store.head source ~branch:"main" with
119 | None -> Error (`Conflict [])
120 | Some source_head -> (
121 match Store.read_commit source source_head with
122 | None -> Error (`Conflict [])
123 | Some source_commit ->
124 let source_tree =
125 Store.read_tree source (Commit.tree source_commit)
126 in
127
128 let current_tree =
129 match Store.head store ~branch:"main" with
130 | None -> Tree.empty ()
131 | Some h -> (
132 match Store.read_commit store h with
133 | None -> Tree.empty ()
134 | Some c -> Store.read_tree store (Commit.tree c))
135 in
136
137 (* Replace subtree at prefix *)
138 let new_tree =
139 let without = Tree.remove current_tree prefix in
140 Tree.add_tree without prefix source_tree
141 in
142
143 let parents =
144 match Store.head store ~branch:"main" with
145 | None -> []
146 | Some h -> [ h ]
147 in
148
149 let message =
150 Fmt.str "Pull updates into '%s'" (String.concat "/" prefix)
151 in
152
153 let new_head =
154 Store.commit store ~tree:new_tree ~parents ~message
155 ~author:"irmin-subtree"
156 in
157 Store.set_head store ~branch:"main" new_head;
158 Ok new_head)
159
160 (* Push: Push subtree changes to external repo *)
161 let push store ~prefix ~target =
162 match Store.head store ~branch:"main" with
163 | None -> failwith "Store has no main branch"
164 | Some head -> (
165 match Store.read_commit store head with
166 | None -> failwith "Cannot read store commit"
167 | Some commit -> (
168 let tree = Store.read_tree store (Commit.tree commit) in
169 match extract_subtree tree prefix with
170 | None -> failwith "No subtree at prefix"
171 | Some subtree ->
172 let parents =
173 match Store.head target ~branch:"main" with
174 | None -> []
175 | Some h -> [ h ]
176 in
177
178 let message =
179 Fmt.str "Push from '%s'" (String.concat "/" prefix)
180 in
181
182 let new_head =
183 Store.commit target ~tree:subtree ~parents ~message
184 ~author:"irmin-subtree"
185 in
186 Store.set_head target ~branch:"main" new_head;
187 new_head))
188
189 (* Status: Compare subtree with external repo *)
190 let status store ~prefix ~external_ =
191 let local_head = Store.head store ~branch:"main" in
192 let remote_head = Store.head external_ ~branch:"main" in
193
194 match (local_head, remote_head) with
195 | None, None -> `In_sync
196 | None, Some _ -> `Remote_ahead 1
197 | Some _, None -> `Local_ahead 1
198 | Some lh, Some rh -> (
199 (* Get subtree hash from local *)
200 let local_tree_hash =
201 match Store.read_commit store lh with
202 | None -> None
203 | Some c -> (
204 let tree = Store.read_tree store (Commit.tree c) in
205 match Tree.find_tree tree prefix with
206 | None -> None
207 | Some t -> Some (Tree.hash t ~backend:(Store.backend store)))
208 in
209
210 (* Get tree hash from remote *)
211 let remote_tree_hash =
212 match Store.read_commit external_ rh with
213 | None -> None
214 | Some c -> Some (Commit.tree c)
215 in
216
217 match (local_tree_hash, remote_tree_hash) with
218 | None, None -> `In_sync
219 | None, Some _ -> `Remote_ahead 1
220 | Some _, None -> `Local_ahead 1
221 | Some lt, Some rt ->
222 if F.hash_equal lt rt then `In_sync
223 else if
224 (* Check ancestry *)
225 Store.is_ancestor external_ ~ancestor:rt ~descendant:lt
226 then
227 `Local_ahead (Store.commits_between external_ ~base:rt ~head:lt)
228 else if Store.is_ancestor external_ ~ancestor:lt ~descendant:rt then
229 `Remote_ahead (Store.commits_between external_ ~base:lt ~head:rt)
230 else `Trees_differ)
231end
232
233module Git = Make (Codec.Git)
234module Mst = Make (Codec.Mst)