Skip to content

Commit 63a8e8f

Browse files
dinosauredinosaure
authored
Merge pull request #58 from dinosaure/git
Separate the Git logic from the Pack logic
2 parents 1c39a24 + 630985d commit 63a8e8f

File tree

3 files changed

+266
-168
lines changed

3 files changed

+266
-168
lines changed

‎lib/dune

Lines changed: 15 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -58,11 +58,25 @@
5858
(modules temp)
5959
(libraries fmt bob.fpath))
6060

61+
(library
62+
(name git)
63+
(public_name bob.git)
64+
(modules git)
65+
(libraries bob.fiber bob.stream cstruct digestif))
66+
6167
(library
6268
(name pack)
6369
(public_name bob.pack)
6470
(modules pack)
65-
(libraries bob.fiber bob.temp bob.stream cstruct unix digestif carton))
71+
(libraries
72+
bob.fiber
73+
bob.temp
74+
bob.stream
75+
bob.git
76+
cstruct
77+
unix
78+
digestif
79+
carton))
6680

6781
(library
6882
(name bob_unix)

‎lib/git.ml

Lines changed: 195 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,195 @@
1+
open Stdbob
2+
3+
let src = Logs.Src.create "bob.git"
4+
5+
module Log = (val Logs.src_log src : Logs.LOG)
6+
7+
module SHA1 = struct
8+
include Digestif.SHA1
9+
10+
let hash x = Hashtbl.hash x
11+
let length = digest_size
12+
let feed = feed_bigstring
13+
let null = digest_string ""
14+
let compare a b = String.compare (to_raw_string a) (to_raw_string b)
15+
16+
let sink_bigstring ?(ctx = empty) () =
17+
Stream.Sink.make ~init:(Fiber.always ctx)
18+
~push:(fun ctx bstr -> Fiber.return (feed_bigstring ctx bstr))
19+
~stop:(Fiber.return <.> get) ()
20+
21+
let sink_string ?(ctx = empty) () =
22+
Stream.Sink.make ~init:(Fiber.always ctx)
23+
~push:(fun ctx str -> Fiber.return (feed_string ctx str))
24+
~stop:(Fiber.return <.> get) ()
25+
end
26+
27+
let v_space = Astring.String.Sub.of_string " "
28+
let v_null = Astring.String.Sub.of_string "\x00"
29+
30+
let tree_of_string ?path str =
31+
let path_with ~name =
32+
match path with
33+
| Some path -> Bob_fpath.(path / name)
34+
| None -> Bob_fpath.v name
35+
in
36+
let one str =
37+
let open Astring.String.Sub in
38+
let ( >>= ) = Option.bind in
39+
cut ~sep:v_space str >>= fun (perm, str) ->
40+
cut ~sep:v_null str >>= fun (name, str) ->
41+
(try Some (with_range ~len:SHA1.length str) with _ -> None)
42+
>>= fun hash ->
43+
let str = with_range ~first:SHA1.length str in
44+
let hash = SHA1.of_raw_string (to_string hash) in
45+
match to_string perm with
46+
| "40000" -> Some (`Dir (path_with ~name:(to_string name), hash), str)
47+
| "100644" -> Some (`Reg (path_with ~name:(to_string name), hash), str)
48+
| _ -> failwith "Invalid kind of entry into a tree"
49+
in
50+
let rec go acc str =
51+
match one str with
52+
| Some (entry, str) -> go (entry :: acc) str
53+
| None -> List.rev acc
54+
in
55+
go [] (Astring.String.Sub.of_string str)
56+
57+
let v_space = Cstruct.string " "
58+
let v_null = Cstruct.string "\x00"
59+
60+
let tree_of_cstruct ?path contents =
61+
let path_with ~name =
62+
match path with
63+
| Some path -> Bob_fpath.(path / name)
64+
| None -> Bob_fpath.v name
65+
in
66+
let init () = Fiber.return (Cstruct.of_bigarray contents) in
67+
let pull contents =
68+
let ( >>= ) = Option.bind in
69+
Cstruct.cut ~sep:v_space contents >>= fun (perm, contents) ->
70+
Cstruct.cut ~sep:v_null contents >>= fun (name, contents) ->
71+
(try Some (Cstruct.sub contents 0 SHA1.length) with _ -> None)
72+
>>= fun hash ->
73+
let contents = Cstruct.shift contents SHA1.length in
74+
let hash = SHA1.of_raw_string (Cstruct.to_string hash) in
75+
match Cstruct.to_string perm with
76+
| "40000" ->
77+
let path = path_with ~name:(Cstruct.to_string name) in
78+
Some (`Dir (path, hash), contents)
79+
| "100644" ->
80+
let path = path_with ~name:(Cstruct.to_string name) in
81+
Some (`Reg (path, hash), contents)
82+
| _ -> failwith "Invalid kind of entry into a tree"
83+
in
84+
let pull = Fiber.return <.> pull in
85+
let stop = Fiber.ignore in
86+
Stream.Source { init; pull; stop }
87+
88+
let digest ~kind ?(off = 0) ?len buf =
89+
let len =
90+
match len with Some len -> len | None -> Bigarray.Array1.dim buf - off
91+
in
92+
let ctx = SHA1.empty in
93+
let ctx =
94+
match kind with
95+
| `A -> SHA1.feed_string ctx (Fmt.str "commit %d\000" len)
96+
| `B -> SHA1.feed_string ctx (Fmt.str "tree %d\000" len)
97+
| `C -> SHA1.feed_string ctx (Fmt.str "blob %d\000" len)
98+
| `D -> SHA1.feed_string ctx (Fmt.str "mesg %d\000" len)
99+
in
100+
let ctx = SHA1.feed_bigstring ctx ~off ~len buf in
101+
SHA1.get ctx
102+
103+
let hash_of_root ~real_length ~root hash =
104+
let str =
105+
Fmt.str "%s\000%s%d" (Bob_fpath.basename root) (SHA1.to_raw_string hash)
106+
real_length
107+
in
108+
let hdr = Fmt.str "commit %d\000" (String.length str) in
109+
SHA1.digest_string (hdr ^ str)
110+
111+
module Filesystem = struct
112+
let readdir =
113+
let readdir d =
114+
try Sys.readdir (Bob_fpath.to_string d) with _exn -> [||]
115+
in
116+
Array.to_list <.> readdir
117+
118+
let rec traverse ~get ~add visited stack ~f acc =
119+
match stack with
120+
| [] -> Fiber.return acc
121+
| x :: r ->
122+
if List.exists (Bob_fpath.equal x) visited then
123+
traverse ~get ~add visited r ~f acc
124+
else
125+
let open Fiber in
126+
let contents = get x in
127+
traverse ~get ~add (x :: visited) (add contents stack) ~f acc >>= f x
128+
129+
let fold ?(dotfiles = false) ~f acc paths =
130+
let dir_child d acc bname =
131+
if (not dotfiles) && bname.[0] = '.' then acc
132+
else Bob_fpath.(d / bname) :: acc
133+
in
134+
let add stack vs = vs @ stack in
135+
let get path =
136+
let entries = readdir path in
137+
List.fold_left (dir_child path) [] entries
138+
in
139+
traverse ~get ~add [] paths ~f acc
140+
141+
let fold ?dotfiles ~f acc d = fold ?dotfiles ~f acc [ d ]
142+
end
143+
144+
let serialize_directory entries =
145+
let entries =
146+
List.sort (fun (a, _) (b, _) -> Bob_fpath.compare a b) entries
147+
in
148+
let open Stream in
149+
let open Stream in
150+
Stream.of_list entries >>= fun (p, hash) ->
151+
match Bob_fpath.is_dir_path p with
152+
| true ->
153+
Stream.of_list
154+
[
155+
"40000 ";
156+
Bob_fpath.(to_string (rem_empty_seg p));
157+
"\x00";
158+
SHA1.to_raw_string hash;
159+
]
160+
|> Fiber.return
161+
| false ->
162+
Stream.of_list
163+
[ "100644 "; Bob_fpath.to_string p; "\x00"; SHA1.to_raw_string hash ]
164+
|> Fiber.return
165+
166+
let hash_of_directory ~root:_ rstore path =
167+
let entries = Filesystem.readdir path in
168+
let entries =
169+
List.filter_map
170+
(fun entry ->
171+
let key = Bob_fpath.(path / entry) in
172+
match Hashtbl.find_opt rstore key with
173+
| Some (hash, `Dir) -> Some (Bob_fpath.(to_dir_path (v entry)), hash)
174+
| Some (hash, `Reg) -> Some (Bob_fpath.v entry, hash)
175+
| Some (_, `Root) -> None
176+
| None -> None)
177+
entries
178+
in
179+
let open Fiber in
180+
let open Stream in
181+
Stream.to_string (serialize_directory entries) >>= fun str ->
182+
Log.debug (fun m -> m "Serialization of %a:" Bob_fpath.pp path);
183+
Log.debug (fun m -> m "@[<hov>%a@]" (Hxd_string.pp Hxd.default) str);
184+
let hdr = Fmt.str "tree %d\000" (String.length str) in
185+
Stream.(into (SHA1.sink_string ()) (double hdr str))
186+
187+
let hash_of_filename path =
188+
let open Fiber in
189+
let open Stream in
190+
let len = Unix.(stat (Bob_fpath.to_string path)).Unix.st_size in
191+
let hdr = Fmt.str "blob %d\000" len in
192+
let ctx = SHA1.feed_string SHA1.empty hdr in
193+
Stream.of_file path >>= function
194+
| Error (`Msg err) -> Fmt.failwith "%s." err
195+
| Ok stream -> Stream.(into (SHA1.sink_bigstring ~ctx ()) stream)

0 commit comments

Comments
 (0)