vblt.org
forked from
gazagnaire.org/irmin
Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
1(** Common CLI helpers. *)
2
3open Irmin
4
5(* Output helpers using Tty *)
6let success fmt =
7 let style = Tty.Style.(fg Tty.Color.green) in
8 Fmt.pr ("%a " ^^ fmt ^^ "@.") (Tty.Style.styled style Fmt.string) "✓"
9
10let error fmt =
11 let style = Tty.Style.(fg Tty.Color.red) in
12 Fmt.epr ("%a " ^^ fmt ^^ "@.") (Tty.Style.styled style Fmt.string) "✗"
13
14let styled_bold = Tty.Style.(styled bold Fmt.string)
15let styled_cyan = Tty.Style.(styled (fg Tty.Color.cyan) Fmt.string)
16let styled_faint = Tty.Style.(styled faint Fmt.string)
17let styled_yellow = Tty.Style.(styled (fg Tty.Color.yellow) Fmt.string)
18let styled_blue = Tty.Style.(styled (fg Tty.Color.blue) Fmt.string)
19
20let path_of_string s =
21 String.split_on_char '/' s |> List.filter (fun s -> s <> "")
22
23type log_entry = { hash : string; author : string; message : string }
24(** Log entry for commit history. *)
25
26(** Backend module signature - first-class modules for extensibility. *)
27module type BACKEND = sig
28 type store
29 type tree
30 type hash
31
32 val open_store :
33 sw:Eio.Switch.t -> fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> store
34
35 val checkout : store -> branch:string -> tree option
36 val empty_tree : store -> tree
37 val tree_find : tree -> string list -> string option
38 val tree_add : tree -> string list -> string -> tree
39 val tree_remove : tree -> string list -> tree
40 val tree_list : tree -> string list -> (string * [ `Contents | `Node ]) list
41 val head : store -> branch:string -> hash option
42
43 val commit :
44 store ->
45 tree:tree ->
46 parents:hash list ->
47 message:string ->
48 author:string ->
49 hash
50
51 val set_head : store -> branch:string -> hash -> unit
52 val branches : store -> string list
53 val log : store -> branch:string -> limit:int option -> log_entry list
54 val hash_to_hex : hash -> string
55 val hash_short : hash -> string
56end
57
58(** Git backend implementation. *)
59module Git : BACKEND = struct
60 type store = Store.Git.t
61 type tree = Tree.Git.t
62 type hash = Hash.sha1
63
64 let open_store ~sw ~fs ~config =
65 let git_dir = Fpath.(v config.Config.store_path / ".git") in
66 Git_interop.import_git ~sw ~fs ~git_dir
67
68 let checkout store ~branch = Store.Git.checkout store ~branch
69 let empty_tree _store = Tree.Git.empty ()
70 let tree_find tree path = Tree.Git.find tree path
71 let tree_add tree path content = Tree.Git.add tree path content
72 let tree_remove tree path = Tree.Git.remove tree path
73 let tree_list tree path = Tree.Git.list tree path
74 let head store ~branch = Store.Git.head store ~branch
75
76 let commit store ~tree ~parents ~message ~author =
77 (* Disable inlining for git interop: inlined contents use a format
78 (version byte \x01) that is not valid git, so git tools cannot
79 read the tree objects. *)
80 Store.Git.commit ~inline_threshold:0 store ~tree ~parents ~message ~author
81
82 let set_head store ~branch hash = Store.Git.set_head store ~branch hash
83 let branches store = Store.Git.branches store
84
85 let log store ~branch ~limit =
86 let rec walk n hash acc =
87 if n = Some 0 then List.rev acc
88 else
89 match Store.Git.read_commit store hash with
90 | None -> List.rev acc
91 | Some commit -> (
92 let entry =
93 {
94 hash = Hash.to_hex hash;
95 author = Commit.Git.author commit;
96 message = Commit.Git.message commit;
97 }
98 in
99 match Commit.Git.parents commit with
100 | [] -> List.rev (entry :: acc)
101 | p :: _ -> walk (Option.map pred n) p (entry :: acc))
102 in
103 match Store.Git.head store ~branch with
104 | None -> []
105 | Some h -> walk limit h []
106
107 let hash_to_hex h = Hash.to_hex h
108 let hash_short h = String.sub (Hash.to_hex h) 0 7
109end
110
111(** MST backend implementation using ATProto blockstore. *)
112module Mst : BACKEND = struct
113 type store = Atp.Blockstore.writable
114 type tree = Atp.Mst.node * Atp.Blockstore.writable
115 type hash = Atp.Cid.t
116
117 let open_store ~sw:_ ~fs ~config =
118 match config.Config.backend with
119 | Config.Memory -> Atp.Blockstore.memory ()
120 | Config.Mst | Config.Git ->
121 let irmin_dir = Filename.concat config.Config.store_path ".irmin" in
122 (try Unix.mkdir irmin_dir 0o755 with Unix.Unix_error _ -> ());
123 let blocks_path = Eio.Path.(fs / irmin_dir / "blocks") in
124 Atp.Blockstore.filesystem blocks_path
125
126 let checkout _store ~branch =
127 (* TODO: Load root from refs *)
128 ignore branch;
129 None
130
131 let empty_tree store = (Atp.Mst.empty, store)
132
133 let tree_find (mst, bs) path =
134 let key = String.concat "/" path in
135 match Atp.Mst.get key mst ~store:(bs :> Atp.Blockstore.readable) with
136 | None -> None
137 | Some cid -> bs#get cid
138
139 let tree_add (mst, bs) path content =
140 let key = String.concat "/" path in
141 let cid = Atp.Cid.of_string content in
142 bs#put cid content;
143 let mst' = Atp.Mst.add key cid mst ~store:bs in
144 (mst', bs)
145
146 let tree_remove (mst, bs) path =
147 let key = String.concat "/" path in
148 let mst' = Atp.Mst.remove key mst ~store:bs in
149 (mst', bs)
150
151 let tree_list (mst, bs) path =
152 let prefix =
153 match path with [] -> "" | _ -> String.concat "/" path ^ "/"
154 in
155 Atp.Mst.leaves mst ~store:(bs :> Atp.Blockstore.readable)
156 |> Seq.filter_map (fun (k, _cid) ->
157 if
158 prefix = ""
159 || String.length k > String.length prefix
160 && String.sub k 0 (String.length prefix) = prefix
161 then
162 let suffix =
163 String.sub k (String.length prefix)
164 (String.length k - String.length prefix)
165 in
166 match String.index_opt suffix '/' with
167 | None -> Some (suffix, `Contents)
168 | Some i -> Some (String.sub suffix 0 i, `Node)
169 else None)
170 |> List.of_seq |> List.sort_uniq compare
171
172 let head _store ~branch =
173 (* TODO: Store refs in blockstore *)
174 ignore branch;
175 None
176
177 let commit bs ~tree:(mst, _) ~parents ~message ~author =
178 ignore parents;
179 ignore message;
180 ignore author;
181 let cid = Atp.Mst.to_cid mst ~store:bs in
182 bs#sync;
183 cid
184
185 let set_head _store ~branch _hash =
186 (* TODO: Store refs *)
187 ignore branch
188
189 let branches _store = [ "main" ]
190
191 let log _store ~branch ~limit =
192 (* MST stores don't have traditional commit history *)
193 ignore branch;
194 ignore limit;
195 []
196
197 let hash_to_hex cid = Atp.Cid.to_string cid
198
199 let hash_short cid =
200 let s = Atp.Cid.to_string cid in
201 if String.length s > 7 then String.sub s 0 7 else s
202end
203
204(** Get the appropriate backend module for a configuration. *)
205let backend_of_config (config : Config.t) : (module BACKEND) =
206 match config.backend with
207 | Config.Git -> (module Git)
208 | Config.Mst | Config.Memory -> (module Mst)