gazagnaire.org
Git object storage and pack files for Eio
1(* Copyright (c) 2013-2017 Thomas Gazagnaire <thomas@gazagnaire.org>
2 Copyright (c) 2017-2024 Romain Calascibetta <romain.calascibetta@gmail.com>
3 Copyright (c) 2024-2026 Thomas Gazagnaire <thomas@gazagnaire.org>
4
5 Permission to use, copy, modify, and distribute this software for any
6 purpose with or without fee is hereby granted, provided that the above
7 copyright notice and this permission notice appear in all copies.
8
9 THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10 WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11 MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12 ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13 WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14 ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15 OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)
16
17(** Git tag objects. *)
18
19type kind = Blob | Commit | Tag | Tree
20
21let kind_to_string = function
22 | Blob -> "blob"
23 | Commit -> "commit"
24 | Tag -> "tag"
25 | Tree -> "tree"
26
27let kind_of_string = function
28 | "blob" -> Ok Blob
29 | "commit" -> Ok Commit
30 | "tag" -> Ok Tag
31 | "tree" -> Ok Tree
32 | s -> Error (`Msg ("Invalid tag kind: " ^ s))
33
34let kind_of_string_exn s =
35 match kind_of_string s with Ok k -> k | Error (`Msg m) -> invalid_arg m
36
37type t = {
38 obj : Hash.t;
39 kind : kind;
40 tag : string;
41 tagger : User.t option;
42 message : string option;
43}
44
45let v obj kind ?tagger ~tag message = { obj; kind; tag; tagger; message }
46let obj t = t.obj
47let kind t = t.kind
48let name t = t.tag
49let tagger t = t.tagger
50let message t = t.message
51
52let pp ppf t =
53 Fmt.pf ppf "@[<v>object %a@," Hash.pp t.obj;
54 Fmt.pf ppf "type %s@," (kind_to_string t.kind);
55 Fmt.pf ppf "tag %s@," t.tag;
56 (match t.tagger with
57 | Some tagger -> Fmt.pf ppf "tagger %a@," User.pp tagger
58 | None -> ());
59 (match t.message with Some msg -> Fmt.pf ppf "@,%s" msg | None -> ());
60 Fmt.pf ppf "@]"
61
62let equal a b =
63 Hash.equal a.obj b.obj && a.kind = b.kind && String.equal a.tag b.tag
64
65let compare a b =
66 match Hash.compare a.obj b.obj with
67 | 0 -> (
68 match Stdlib.compare a.kind b.kind with
69 | 0 -> String.compare a.tag b.tag
70 | n -> n)
71 | n -> n
72
73let hash t = Hashtbl.hash t
74
75(** Encode tag to git format. *)
76let to_string t =
77 let buf = Buffer.create 256 in
78 Buffer.add_string buf "object ";
79 Buffer.add_string buf (Hash.to_hex t.obj);
80 Buffer.add_char buf '\n';
81 Buffer.add_string buf "type ";
82 Buffer.add_string buf (kind_to_string t.kind);
83 Buffer.add_char buf '\n';
84 Buffer.add_string buf "tag ";
85 Buffer.add_string buf t.tag;
86 Buffer.add_char buf '\n';
87 (match t.tagger with
88 | Some tagger ->
89 Buffer.add_string buf "tagger ";
90 Buffer.add_string buf (User.to_string tagger);
91 Buffer.add_char buf '\n'
92 | None -> ());
93 (match t.message with
94 | Some msg ->
95 Buffer.add_char buf '\n';
96 Buffer.add_string buf msg
97 | None -> ());
98 Buffer.contents buf
99
100(** Parse a single header line. *)
101let parse_header line =
102 match String.index_opt line ' ' with
103 | None -> None
104 | Some pos ->
105 let key = String.sub line 0 pos in
106 let value = String.sub line (pos + 1) (String.length line - pos - 1) in
107 Some (key, value)
108
109(** Parse tag from git format. *)
110let of_string s =
111 let lines = String.split_on_char '\n' s in
112 let rec parse_headers obj kind tag tagger = function
113 | [] -> (
114 (* No message *)
115 match (obj, kind, tag) with
116 | Some obj, Some kind, Some tag ->
117 Ok { obj; kind; tag; tagger; message = None }
118 | None, _, _ -> Error (`Msg "Missing object in tag")
119 | _, None, _ -> Error (`Msg "Missing type in tag")
120 | _, _, None -> Error (`Msg "Missing tag name in tag"))
121 | "" :: rest -> (
122 (* Empty line marks start of message *)
123 let message =
124 match rest with [] -> None | _ -> Some (String.concat "\n" rest)
125 in
126 match (obj, kind, tag) with
127 | Some obj, Some kind, Some tag ->
128 Ok { obj; kind; tag; tagger; message }
129 | None, _, _ -> Error (`Msg "Missing object in tag")
130 | _, None, _ -> Error (`Msg "Missing type in tag")
131 | _, _, None -> Error (`Msg "Missing tag name in tag"))
132 | line :: rest -> (
133 match parse_header line with
134 | None -> Error (`Msg ("Invalid header line: " ^ line))
135 | Some ("object", hex) ->
136 let obj = Hash.of_hex hex in
137 parse_headers (Some obj) kind tag tagger rest
138 | Some ("type", type_str) -> (
139 match kind_of_string type_str with
140 | Ok k -> parse_headers obj (Some k) tag tagger rest
141 | Error _ as e -> e)
142 | Some ("tag", tag_name) ->
143 parse_headers obj kind (Some tag_name) tagger rest
144 | Some ("tagger", user_str) -> (
145 match User.of_string user_str with
146 | Ok user -> parse_headers obj kind tag (Some user) rest
147 | Error _ as e -> e)
148 | Some (_key, _value) ->
149 (* Skip unknown headers *)
150 parse_headers obj kind tag tagger rest)
151 in
152 parse_headers None None None None lines
153
154let of_string_exn s =
155 match of_string s with Ok t -> t | Error (`Msg m) -> failwith m
156
157let digest t =
158 let s = to_string t in
159 Hash.digest_string ~kind:`Tag s
160
161module Set = Set.Make (struct
162 type nonrec t = t
163
164 let compare = compare
165end)
166
167module Map = Map.Make (struct
168 type nonrec t = t
169
170 let compare = compare
171end)