[OCaml] Mobile-friendly clone of cgit.
perf Memoize pages per repository head
Every page reopened the store and recomputed its content, and the root page opened every repository to fetch head dates. Rendered pages and head dates are now cached in bounded FIFO caches keyed by the hash HEAD names, resolved from plain file reads. Any new commit changes the key, so entries cannot serve a moved branch stale content; a router test proves a new commit is visible immediately.
Changed files
lib/cache.ml
@@ -0,0 +1,29 @@
1
Added:
(** A bounded key-value cache with first-in-first-out eviction.
2
Added:
3
Added:
Keys are strings; values are whatever the instance stores. When the cache
4
Added:
is full, adding a new key evicts the oldest one. Adding a key that is
5
Added:
already present is a no-op: callers build keys from content identifiers (a
6
Added:
repository head hash, for example), so a key's value never changes.
7
Added:
8
Added:
No locking: the server runs on a single Lwt event loop, and no operation
9
Added:
here yields. *)
10
Added:
11
Added:
type 'a t = {
12
Added:
capacity : int;
13
Added:
table : (string, 'a) Hashtbl.t;
14
Added:
order : string Queue.t;
15
Added:
}
16
Added:
17
Added:
let create ~capacity =
18
Added:
{ capacity; table = Hashtbl.create 64; order = Queue.create () }
19
Added:
20
Added:
let find cache key = Hashtbl.find_opt cache.table key
21
Added:
22
Added:
let add cache key value =
23
Added:
if not (Hashtbl.mem cache.table key) then (
24
Added:
if Queue.length cache.order >= cache.capacity then (
25
Added:
match Queue.take_opt cache.order with
26
Added:
| Some oldest -> Hashtbl.remove cache.table oldest
27
Added:
| None -> ());
28
Added:
Hashtbl.replace cache.table key value;
29
Added:
Queue.add key cache.order)
lib/cache.mli
@@ -0,0 +1,17 @@
1
Added:
(** A bounded key-value cache with first-in-first-out eviction.
2
Added:
3
Added:
Keys are strings; values are whatever the instance stores. Callers build
4
Added:
keys from content identifiers (a repository head hash, for example), so a
5
Added:
key's value never changes — adding a key that is already present is
6
Added:
therefore a no-op. *)
7
Added:
8
Added:
type 'a t
9
Added:
10
Added:
val create : capacity:int -> 'a t
11
Added:
(** An empty cache holding at most [capacity] entries. *)
12
Added:
13
Added:
val find : 'a t -> string -> 'a option
14
Added:
15
Added:
val add : 'a t -> string -> 'a -> unit
16
Added:
(** Insert a value, evicting the oldest entry when the cache is full. A no-op
17
Added:
when the key is already present. *)
lib/handlers.ml
@@ -64,16 +64,35 @@
64
64
in
65
65
List.fold_left (walk prefix) [] nodes |> List.rev
66
66
67
Added:
(* Head commit dates for the repository list pages, keyed by (path, head
68
Added:
hash). Any new commit changes the key, so an entry can never go stale. *)
69
Added:
let date_cache : (int64 * Git.User.tz_offset option) option Cache.t =
70
Added:
Cache.create ~capacity:1024
71
Added:
67
72
let fetch_repo_dates config repo_paths =
68
73
let open Lwt.Syntax in
74
Added:
let fetch path =
75
Added:
Lwt.bind (Resolvers.open_repository config path) @@ function
76
Added:
| Error _ -> Lwt.return None
77
Added:
| Ok repository ->
78
Added:
let* date = Resolvers.head_commit_date repository in
79
Added:
let* () = Resolvers.close_repository repository in
80
Added:
Lwt.return date
81
Added:
in
69
82
Lwt_list.map_p
70
83
(fun path ->
71
Removed:
Lwt.bind (Resolvers.open_repository config path) @@ function
72
Removed:
| Error _ -> Lwt.return (path, None)
73
Removed:
| Ok repository ->
74
Removed:
let* date = Resolvers.head_commit_date repository in
75
Removed:
let* () = Resolvers.close_repository repository in
76
Removed:
Lwt.return (path, date))
84
Added:
match Resolvers.head_hash_hint config path with
85
Added:
| None ->
86
Added:
let* date = fetch path in
87
Added:
Lwt.return (path, date)
88
Added:
| Some head -> (
89
Added:
let key = path ^ "\x00" ^ head in
90
Added:
match Cache.find date_cache key with
91
Added:
| Some date -> Lwt.return (path, date)
92
Added:
| None ->
93
Added:
let* date = fetch path in
94
Added:
Cache.add date_cache key date;
95
Added:
Lwt.return (path, date)))
77
96
repo_paths
78
97
79
98
let root config _request =
@@ -318,6 +337,54 @@
318
337
Views.root (site config) ~dates ~prefix:subdir ?readme nodes
319
338
| Error error -> error_response error
320
339
340
Added:
(* Rendered pages are memoized per repository head: the key embeds the hash
341
Added:
HEAD names, so any new commit changes the key and an entry can never serve
342
Added:
a moved branch's old content. What CAN go stale until eviction is metadata
343
Added:
outside the object store — the description file — which is accepted.
344
Added:
Requests whose head cannot be resolved cheaply are served uncached. *)
345
Added:
let page_cache : (Dream.status * (string * string) list * string) Cache.t =
346
Added:
Cache.create ~capacity:256
347
Added:
348
Added:
(* Raw blobs pass through here too; the size cap keeps a handful of large
349
Added:
files from occupying the whole cache. *)
350
Added:
let max_cacheable_body_bytes = 512 * 1024
351
Added:
352
Added:
let respond_cached config name request serve =
353
Added:
match Resolvers.head_hash_hint config name with
354
Added:
| None -> serve ()
355
Added:
| Some head -> (
356
Added:
let key = String.concat "\x00" [ name; head; Dream.target request ] in
357
Added:
match Cache.find page_cache key with
358
Added:
| Some (status, headers, body) ->
359
Added:
Lwt.return (Dream.response ~status ~headers body)
360
Added:
| None ->
361
Added:
let open Lwt.Syntax in
362
Added:
let* response = serve () in
363
Added:
let* body = Dream.body response in
364
Added:
let status = Dream.status response in
365
Added:
let headers = Dream.all_headers response in
366
Added:
if
367
Added:
Dream.status_to_int status = 200
368
Added:
&& String.length body <= max_cacheable_body_bytes
369
Added:
then Cache.add page_cache key (status, headers, body);
370
Added:
Lwt.return (Dream.response ~status ~headers body))
371
Added:
372
Added:
(* The repository a route is scoped to, or [None] for the root page, which
373
Added:
depends on every repository and is not cached. *)
374
Added:
let route_repo = function
375
Added:
| Routes.Root -> None
376
Added:
| Routes.Project_dir name
377
Added:
| Routes.Repo name
378
Added:
| Routes.Commits name
379
Added:
| Routes.Commits_branch (name, _)
380
Added:
| Routes.Commit (name, _)
381
Added:
| Routes.Files name
382
Added:
| Routes.File (name, _)
383
Added:
| Routes.File_at (name, _)
384
Added:
| Routes.Raw_file (name, _)
385
Added:
| Routes.Raw_at (name, _) ->
386
Added:
Some name
387
Added:
321
388
let routes config =
322
389
let repo_dispatcher request =
323
390
let path = Dream.target request in
@@ -347,32 +414,39 @@
347
414
in
348
415
match Routes.dispatch path with
349
416
| None -> error_response (Not_found ("not found: " ^ Dream.target request))
350
Removed:
| Some Routes.Root -> root config request
351
Removed:
| Some (Routes.Project_dir name) | Some (Routes.Repo name) ->
352
Removed:
summary_or_directory name
353
Removed:
| Some (Routes.Commits name) ->
354
Removed:
Repo.with_repository config name (fun repository context ->
355
Removed:
Repo.commits config request repository context)
356
Removed:
| Some (Routes.Commits_branch (name, branch)) ->
357
Removed:
Repo.with_repository config name (fun repository context ->
358
Removed:
Repo.commits_branch config repository context branch)
359
Removed:
| Some (Routes.Commit (name, hash)) ->
360
Removed:
Repo.with_repository config name (fun repository context ->
361
Removed:
Repo.commit_id repository context hash)
362
Removed:
| Some (Routes.Files name) ->
363
Removed:
Repo.with_repository config name Repo.files_at_head
364
Removed:
| Some (Routes.File (name, hash)) ->
365
Removed:
Repo.with_repository config name (fun repository context ->
366
Removed:
Repo.file_id repository context hash)
367
Removed:
| Some (Routes.File_at (name, path)) ->
368
Removed:
Repo.with_repository config name (fun repository context ->
369
Removed:
Repo.file_at repository context path)
370
Removed:
| Some (Routes.Raw_file (name, hash)) ->
371
Removed:
Repo.with_repository config name (fun repository context ->
372
Removed:
Repo.raw_file repository context hash)
373
Removed:
| Some (Routes.Raw_at (name, path)) ->
374
Removed:
Repo.with_repository config name (fun repository context ->
375
Removed:
Repo.raw_at repository context path)
417
Added:
| Some route -> (
418
Added:
let serve () =
419
Added:
match route with
420
Added:
| Routes.Root -> root config request
421
Added:
| Routes.Project_dir name | Routes.Repo name ->
422
Added:
summary_or_directory name
423
Added:
| Routes.Commits name ->
424
Added:
Repo.with_repository config name (fun repository context ->
425
Added:
Repo.commits config request repository context)
426
Added:
| Routes.Commits_branch (name, branch) ->
427
Added:
Repo.with_repository config name (fun repository context ->
428
Added:
Repo.commits_branch config repository context branch)
429
Added:
| Routes.Commit (name, hash) ->
430
Added:
Repo.with_repository config name (fun repository context ->
431
Added:
Repo.commit_id repository context hash)
432
Added:
| Routes.Files name ->
433
Added:
Repo.with_repository config name Repo.files_at_head
434
Added:
| Routes.File (name, hash) ->
435
Added:
Repo.with_repository config name (fun repository context ->
436
Added:
Repo.file_id repository context hash)
437
Added:
| Routes.File_at (name, path) ->
438
Added:
Repo.with_repository config name (fun repository context ->
439
Added:
Repo.file_at repository context path)
440
Added:
| Routes.Raw_file (name, hash) ->
441
Added:
Repo.with_repository config name (fun repository context ->
442
Added:
Repo.raw_file repository context hash)
443
Added:
| Routes.Raw_at (name, path) ->
444
Added:
Repo.with_repository config name (fun repository context ->
445
Added:
Repo.raw_at repository context path)
446
Added:
in
447
Added:
match route_repo route with
448
Added:
| None -> serve ()
449
Added:
| Some name -> respond_cached config name request serve)
376
450
in
377
451
[
378
452
Dream.get "/" (root config);
lib/resolvers.ml
@@ -216,7 +216,7 @@
216
216
let fallback_branch_candidates config =
217
217
fallback_branch_candidates_for config.Config.default_branch
218
218
219
Removed:
(** Parse the [packed-refs] file and return all entries as [(hex, refname)]
219
Added:
(** Parse a [packed-refs] file and return all entries as [(hex, refname)]
220
220
pairs. This is the shared primitive used both by [resolve_head_hash] (which
221
221
needs branch references for its fallback) and by [Reference.refs_by_prefix]
222
222
(which enumerates branches and tags for the UI).
@@ -224,9 +224,8 @@
224
224
[Store.Ref.list] only walks the filesystem for loose reference files; when a
225
225
repository has been garbage-collected or was received as a pack, all refs
226
226
live exclusively in [packed-refs] and are invisible to it. *)
227
Removed:
let read_packed_refs store =
228
Removed:
let dotgit = Fpath.to_string (Store.dotgit store) in
229
Removed:
let path = Filename.concat dotgit "packed-refs" in
227
Added:
let read_packed_refs_at git_dir =
228
Added:
let path = Filename.concat git_dir "packed-refs" in
230
229
try
231
230
In_channel.with_open_text path @@ fun ic ->
232
231
let rec collect acc =
@@ -246,6 +245,41 @@
246
245
in
247
246
collect []
248
247
with Sys_error _ -> []
248
Added:
249
Added:
let read_packed_refs store =
250
Added:
read_packed_refs_at (Fpath.to_string (Store.dotgit store))
251
Added:
252
Added:
(** Cheaply resolve the commit hash that HEAD names, using plain file reads and
253
Added:
no object store: HEAD itself, then one loose reference file, then
254
Added:
[packed-refs]. [None] means "could not tell cheaply" — callers must fall
255
Added:
back to opening the repository rather than conclude anything. *)
256
Added:
let head_hash_hint config name =
257
Added:
let path = Filename.concat config.Config.git_project_root name in
258
Added:
match repository_layout_or_none path with
259
Added:
| None -> None
260
Added:
| Some { git_dir; _ } -> (
261
Added:
let first_line file =
262
Added:
try In_channel.with_open_text file In_channel.input_line
263
Added:
with Sys_error _ -> None
264
Added:
in
265
Added:
match first_line (Filename.concat git_dir "HEAD") with
266
Added:
| None -> None
267
Added:
| Some line -> (
268
Added:
let line = String.trim line in
269
Added:
if String.starts_with ~prefix:"ref: " line then
270
Added:
let refname =
271
Added:
String.trim (String.sub line 5 (String.length line - 5))
272
Added:
in
273
Added:
match first_line (Filename.concat git_dir refname) with
274
Added:
| Some hex when is_valid_hash_hex (String.trim hex) ->
275
Added:
Some (String.trim hex)
276
Added:
| _ ->
277
Added:
read_packed_refs_at git_dir
278
Added:
|> List.find_opt (fun (_, packed_name) ->
279
Added:
packed_name = refname)
280
Added:
|> Option.map fst
281
Added:
else if is_valid_hash_hex line then Some line
282
Added:
else None))
249
283
250
284
(** Branch entries from [packed-refs], returned as [(full_refname, reference)]
251
285
pairs suitable for [try_references]. *)
lib/resolvers.mli
@@ -34,6 +34,12 @@
34
34
val head_commit_date :
35
35
repository -> (int64 * Git.User.tz_offset option) option Lwt.t
36
36
37
Added:
val head_hash_hint : Config.t -> string -> string option
38
Added:
(** Cheaply resolve the commit hash that HEAD names, using plain file reads and
39
Added:
no object store. [None] means "could not tell cheaply" — fall back to
40
Added:
opening the repository rather than conclude anything. Intended as a cache
41
Added:
key: any new commit on the served branch changes the result. *)
42
Added:
37
43
(** {1 Repository metadata} *)
38
44
39
45
val default_repo_description : string
test/test_cache.ml
@@ -0,0 +1,31 @@
1
Added:
(** The bounded FIFO cache: hits, misses, eviction order, and no-op re-adds. *)
2
Added:
3
Added:
let test_find_and_add () =
4
Added:
let cache = Ogit.Cache.create ~capacity:4 in
5
Added:
Alcotest.(check (option int)) "miss" None (Ogit.Cache.find cache "a");
6
Added:
Ogit.Cache.add cache "a" 1;
7
Added:
Alcotest.(check (option int)) "hit" (Some 1) (Ogit.Cache.find cache "a")
8
Added:
9
Added:
let test_eviction () =
10
Added:
let cache = Ogit.Cache.create ~capacity:2 in
11
Added:
Ogit.Cache.add cache "a" 1;
12
Added:
Ogit.Cache.add cache "b" 2;
13
Added:
Ogit.Cache.add cache "c" 3;
14
Added:
Alcotest.(check (option int)) "oldest evicted" None (Ogit.Cache.find cache "a");
15
Added:
Alcotest.(check (option int)) "second kept" (Some 2) (Ogit.Cache.find cache "b");
16
Added:
Alcotest.(check (option int)) "newest kept" (Some 3) (Ogit.Cache.find cache "c")
17
Added:
18
Added:
let test_readd_is_noop () =
19
Added:
let cache = Ogit.Cache.create ~capacity:2 in
20
Added:
Ogit.Cache.add cache "a" 1;
21
Added:
Ogit.Cache.add cache "a" 9;
22
Added:
Alcotest.(check (option int))
23
Added:
"value unchanged" (Some 1) (Ogit.Cache.find cache "a")
24
Added:
25
Added:
let suite =
26
Added:
( "cache",
27
Added:
[
28
Added:
Alcotest.test_case "find and add" `Quick test_find_and_add;
29
Added:
Alcotest.test_case "eviction" `Quick test_eviction;
30
Added:
Alcotest.test_case "re-add is a no-op" `Quick test_readd_is_noop;
31
Added:
] )
test/test_ogit.ml
@@ -12,6 +12,7 @@
12
12
Test_router.suite;
13
13
Test_dispatch.suite;
14
14
Test_list_ext.suite;
15
Added:
Test_cache.suite;
15
16
Test_diff.suite;
16
17
Test_readme.suite;
17
18
Test_views.suite;
test/test_router.ml
@@ -122,6 +122,49 @@
122
122
Alcotest.(check int) "missing path" 404 (status "/project/file/dir/none");
123
123
Alcotest.(check int) "raw tree" 400 (status "/project/raw/dir"))
124
124
125
Added:
(* The page cache is keyed on the repository's head hash: a new commit must be
126
Added:
visible immediately, because it changes the key rather than the entry. *)
127
Added:
let test_cache_sees_new_commit () =
128
Added:
with_temp_directory "ogit-router" (fun root ->
129
Added:
let name = "project" in
130
Added:
let path = Filename.concat root name in
131
Added:
Unix.mkdir path 0o755;
132
Added:
ignore (git [ "-C"; path; "init"; "-q"; "-b"; "main" ]);
133
Added:
ignore (git [ "-C"; path; "config"; "user.name"; "Test" ]);
134
Added:
ignore (git [ "-C"; path; "config"; "user.email"; "t@t.invalid" ]);
135
Added:
let write content =
136
Added:
Out_channel.with_open_text (Filename.concat path "f.txt") (fun ch ->
137
Added:
output_string ch content)
138
Added:
in
139
Added:
let commit message =
140
Added:
ignore (git [ "-C"; path; "add"; "." ]);
141
Added:
ignore (git [ "-C"; path; "commit"; "-q"; "-m"; message ])
142
Added:
in
143
Added:
write "generation-one\n";
144
Added:
commit "first";
145
Added:
let config = Ogit.Config.{ default with git_project_root = root } in
146
Added:
let request = Dream.test (Dream.router (Ogit.Handlers.routes config)) in
147
Added:
let body target =
148
Added:
Dream.request ~target "" |> request |> Dream.body |> Lwt_main.run
149
Added:
in
150
Added:
let contains haystack needle =
151
Added:
let nl = String.length needle and hl = String.length haystack in
152
Added:
let rec at i = i + nl <= hl && (String.sub haystack i nl = needle || at (i + 1)) in
153
Added:
at 0
154
Added:
in
155
Added:
(* Twice, so the second read comes from the cache. *)
156
Added:
Alcotest.(check bool)
157
Added:
"first read" true
158
Added:
(contains (body "/project/raw/f.txt") "generation-one");
159
Added:
Alcotest.(check bool)
160
Added:
"cached read" true
161
Added:
(contains (body "/project/raw/f.txt") "generation-one");
162
Added:
write "generation-two\n";
163
Added:
commit "second";
164
Added:
Alcotest.(check bool)
165
Added:
"new commit visible" true
166
Added:
(contains (body "/project/raw/f.txt") "generation-two"))
167
Added:
125
168
let suite =
126
169
( "router",
127
170
[
@@ -131,4 +174,6 @@
131
174
Alcotest.test_case "missing object" `Slow test_missing_object;
132
175
Alcotest.test_case "raw response headers" `Slow test_raw_response_headers;
133
176
Alcotest.test_case "file by path" `Slow test_file_by_path;
177
Added:
Alcotest.test_case "cache sees new commit" `Slow
178
Added:
test_cache_sees_new_commit;
134
179
] )