[OCaml] Mobile-friendly clone of cgit.
feat Serve files and raw blobs by path
Add File_at and Raw_at routes that address a file by its path from the repository root. Resolution walks one tree per segment, unlike the hash routes, which search the whole tree per request. Path segments are percent-encoded in generated links and decoded on dispatch, so file names survive the round trip. Hash routes keep working for existing links.
Changed files
lib/handlers.ml
@@ -247,6 +247,14 @@
247
247
Views.Repo.files context trail nodes
248
248
| `Blob blob -> Views.Repo.file context trail blob
249
249
250
Added:
let file_at repository context path =
251
Added:
let* object_, trail = Resolvers.object_at_path repository path in
252
Added:
match object_ with
253
Added:
| `Tree tree ->
254
Added:
let* nodes = Resolvers.Tree.expand repository tree in
255
Added:
Views.Repo.files context trail nodes
256
Added:
| `Blob blob -> Views.Repo.file context trail blob
257
Added:
250
258
let mime_of_filename filename =
251
259
match Filename.extension filename |> String.lowercase_ascii with
252
260
| ".png" -> "image/png"
@@ -284,6 +292,20 @@
284
292
(Dream.response ~headers:(raw_headers content_type) blob.content)
285
293
| `Tree _ ->
286
294
error_response (Resolvers.Bad_request "object is a tree, not a blob")
295
Added:
296
Added:
let raw_at repository _context path =
297
Added:
let* object_, _trail = Resolvers.object_at_path repository path in
298
Added:
match object_ with
299
Added:
| `Blob blob ->
300
Added:
let content_type =
301
Added:
match List.rev (String.split_on_char '/' path) with
302
Added:
| name :: _ -> mime_of_filename name
303
Added:
| [] -> "text/plain; charset=utf-8"
304
Added:
in
305
Added:
Lwt.return
306
Added:
(Dream.response ~headers:(raw_headers content_type) blob.content)
307
Added:
| `Tree _ ->
308
Added:
error_response (Resolvers.Bad_request "path names a tree, not a file")
287
309
end
288
310
289
311
let project_dir config subdir =
@@ -342,9 +364,15 @@
342
364
| Some (Routes.File (name, hash)) ->
343
365
Repo.with_repository config name (fun repository context ->
344
366
Repo.file_id repository context hash)
367
Added:
| Some (Routes.File_at (name, path)) ->
368
Added:
Repo.with_repository config name (fun repository context ->
369
Added:
Repo.file_at repository context path)
345
370
| Some (Routes.Raw_file (name, hash)) ->
346
371
Repo.with_repository config name (fun repository context ->
347
372
Repo.raw_file repository context hash)
373
Added:
| Some (Routes.Raw_at (name, path)) ->
374
Added:
Repo.with_repository config name (fun repository context ->
375
Added:
Repo.raw_at repository context path)
348
376
in
349
377
[
350
378
Dream.get "/" (root config);
lib/resolvers.ml
@@ -742,6 +742,48 @@
742
742
| Git.Value.Blob blob -> Lwt_result.return (`Blob (Blob.to_t blob))
743
743
| _ -> Lwt_result.fail (Not_found ("no tree or blob matches id " ^ id))
744
744
745
Added:
(* Resolving by path walks at most one tree per segment, unlike
746
Added:
[Tree.find_path], which searches the whole tree for a hash. *)
747
Added:
let object_at_path repository path =
748
Added:
let segments =
749
Added:
String.split_on_char '/' path |> List.filter (fun s -> s <> "")
750
Added:
in
751
Added:
let missing () = Lwt_result.fail (Not_found ("no such path: " ^ path)) in
752
Added:
if segments = [] then
753
Added:
Lwt_result.fail (Bad_request "empty path in repository")
754
Added:
else
755
Added:
let* root = Tree.head_tree_hash repository in
756
Added:
let rec walk trail tree_hash = function
757
Added:
| [] -> missing ()
758
Added:
| segment :: rest -> (
759
Added:
Lwt_result.bind (read_value repository tree_hash) @@ function
760
Added:
| Git.Value.Tree tree -> (
761
Added:
let entries = Store.Value.Tree.to_list tree in
762
Added:
match
763
Added:
List.find_opt
764
Added:
(fun (entry : Store.Value.Tree.entry) ->
765
Added:
entry.name = segment)
766
Added:
entries
767
Added:
with
768
Added:
| None -> missing ()
769
Added:
| Some entry ->
770
Added:
let step = (entry.name, Store.Hash.to_hex entry.node) in
771
Added:
let trail = step :: trail in
772
Added:
if rest = [] then
773
Added:
Lwt_result.bind (read_value repository entry.node)
774
Added:
@@ function
775
Added:
| Git.Value.Blob blob ->
776
Added:
Lwt_result.return
777
Added:
(`Blob (Blob.to_t blob), List.rev trail)
778
Added:
| Git.Value.Tree tree ->
779
Added:
Lwt_result.return
780
Added:
(`Tree (Tree.to_t tree), List.rev trail)
781
Added:
| _ -> missing ()
782
Added:
else walk trail entry.node rest)
783
Added:
| _ -> missing ())
784
Added:
in
785
Added:
walk [] root segments
786
Added:
745
787
module Readme = struct
746
788
type t = { name : string; content : string }
747
789
end
lib/resolvers.mli
@@ -118,6 +118,18 @@
118
118
string ->
119
119
([> `Blob of Blob.t | `Tree of Tree.t ], error) Lwt_result.t
120
120
121
Added:
val object_at_path :
122
Added:
repository ->
123
Added:
string ->
124
Added:
( [ `Blob of Blob.t | `Tree of Tree.t ] * (string * string) list,
125
Added:
error )
126
Added:
Lwt_result.t
127
Added:
(** Resolve a slash-separated file path against the HEAD tree. Returns the
128
Added:
object and the trail of [(name, hash)] pairs from the root to it. Walks one
129
Added:
tree per path segment, so it is cheaper than searching for a hash with
130
Added:
{!Tree.find_path}. An empty path is a [Bad_request]; a path that names
131
Added:
nothing is [Not_found]. *)
132
Added:
121
133
(** {1 Repository helpers} *)
122
134
123
135
module Readme : sig
lib/routes.ml
@@ -14,8 +14,64 @@
14
14
| Commit of string * string
15
15
| Files of string
16
16
| File of string * string
17
Added:
| File_at of string * string
17
18
| Raw_file of string * string
19
Added:
| Raw_at of string * string
18
20
21
Added:
(* Path arguments in [File_at] and [Raw_at] carry repository file names, which
22
Added:
may contain characters that are not safe in a URL. [path_of] percent-encodes
23
Added:
each segment and [dispatch] decodes them, so the round trip preserves any
24
Added:
name. Repository names and object ids are emitted as-is: the former are
25
Added:
constrained by [Resolvers.is_valid_repo_name], the latter are hexadecimal. *)
26
Added:
27
Added:
let encode_segment segment =
28
Added:
let buffer = Buffer.create (String.length segment) in
29
Added:
String.iter
30
Added:
(fun char ->
31
Added:
match char with
32
Added:
| 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '-' | '.' | '_' | '~' ->
33
Added:
Buffer.add_char buffer char
34
Added:
| _ ->
35
Added:
Buffer.add_string buffer (Printf.sprintf "%%%02X" (Char.code char)))
36
Added:
segment;
37
Added:
Buffer.contents buffer
38
Added:
39
Added:
let encode_path path =
40
Added:
String.split_on_char '/' path |> List.map encode_segment |> String.concat "/"
41
Added:
42
Added:
let hex_digit_value = function
43
Added:
| '0' .. '9' as digit -> Some (Char.code digit - Char.code '0')
44
Added:
| 'a' .. 'f' as digit -> Some (Char.code digit - Char.code 'a' + 10)
45
Added:
| 'A' .. 'F' as digit -> Some (Char.code digit - Char.code 'A' + 10)
46
Added:
| _ -> None
47
Added:
48
Added:
(* A '%' that is not followed by two hexadecimal digits is kept literally
49
Added:
rather than rejected: the segment then simply names no existing file. *)
50
Added:
let decode_segment segment =
51
Added:
let length = String.length segment in
52
Added:
let buffer = Buffer.create length in
53
Added:
let rec go index =
54
Added:
if index >= length then ()
55
Added:
else if segment.[index] = '%' && index + 2 < length then (
56
Added:
match
57
Added:
(hex_digit_value segment.[index + 1], hex_digit_value segment.[index + 2])
58
Added:
with
59
Added:
| Some high, Some low ->
60
Added:
Buffer.add_char buffer (Char.chr ((high * 16) + low));
61
Added:
go (index + 3)
62
Added:
| _ ->
63
Added:
Buffer.add_char buffer '%';
64
Added:
go (index + 1))
65
Added:
else (
66
Added:
Buffer.add_char buffer segment.[index];
67
Added:
go (index + 1))
68
Added:
in
69
Added:
go 0;
70
Added:
Buffer.contents buffer
71
Added:
72
Added:
let decode_path segments =
73
Added:
List.map decode_segment segments |> String.concat "/"
74
Added:
19
75
(* Generate URL paths for routes *)
20
76
let path_of = function
21
77
| Root -> "/"
@@ -26,10 +82,21 @@
26
82
| Commit (repo, hash) -> "/" ^ repo ^ "/commit/" ^ hash
27
83
| Files repo -> "/" ^ repo ^ "/files/"
28
84
| File (repo, hash) -> "/" ^ repo ^ "/file/" ^ hash
85
Added:
| File_at (repo, path) -> "/" ^ repo ^ "/file/" ^ encode_path path
29
86
| Raw_file (repo, hash) -> "/" ^ repo ^ "/raw/" ^ hash
87
Added:
| Raw_at (repo, path) -> "/" ^ repo ^ "/raw/" ^ encode_path path
30
88
31
89
let known_actions = [ "summary"; "commits"; "commit"; "files"; "file"; "raw" ]
32
90
91
Added:
(* The store hashes objects with SHA-1, whose hexadecimal form is 40
92
Added:
characters. A single segment of that shape is an object id; anything else
93
Added:
under file/ or raw/ is a path. *)
94
Added:
let is_hex_hash candidate =
95
Added:
String.length candidate = 40
96
Added:
&& String.for_all
97
Added:
(function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false)
98
Added:
candidate
99
Added:
33
100
(* The split point is the first segment naming a known action; everything
34
101
before it is the repository or directory path. Anything after the action
35
102
that the route shapes above do not account for is rejected rather than
@@ -57,8 +124,11 @@
57
124
| "commits", [ branch ] -> Some (Commits_branch (repo, branch))
58
125
| "commit", [ hash ] -> Some (Commit (repo, hash))
59
126
| "files", [] -> Some (Files repo)
60
Removed:
| "file", [ hash ] -> Some (File (repo, hash))
61
Removed:
| "raw", [ hash ] -> Some (Raw_file (repo, hash))
127
Added:
| "file", [ hash ] when is_hex_hash hash -> Some (File (repo, hash))
128
Added:
| "file", (_ :: _ as path) -> Some (File_at (repo, decode_path path))
129
Added:
| "raw", [ hash ] when is_hex_hash hash ->
130
Added:
Some (Raw_file (repo, hash))
131
Added:
| "raw", (_ :: _ as path) -> Some (Raw_at (repo, decode_path path))
62
132
| _ -> None)
63
133
| seg :: rest -> find_split (seg :: repo_acc) rest
64
134
in
lib/routes.mli
@@ -26,9 +26,18 @@
26
26
| Commit of string * string
27
27
| Files of string
28
28
| File of string * string
29
Added:
| File_at of string * string
29
30
| Raw_file of string * string
31
Added:
| Raw_at of string * string
30
32
(** A page in the application. The string arguments carry the repository
31
Removed:
name and an object identifier where applicable. *)
33
Added:
name and either an object identifier ({!File}, {!Raw_file}) or a
34
Added:
slash-separated file path from the repository root ({!File_at},
35
Added:
{!Raw_at}).
36
Added:
37
Added:
Path arguments are percent-encoded by {!path_of} and decoded by
38
Added:
{!dispatch}, so file names survive the round trip unaltered. A
39
Added:
single-segment path that is itself 40 hexadecimal characters is
40
Added:
indistinguishable from an object id and dispatches as one. *)
32
41
33
42
val path_of : t -> string
34
43
(** Generate the URL path for a route. *)
test/test_dispatch.ml
@@ -10,7 +10,9 @@
10
10
| Ogit.Routes.Commit (r, h) -> "Commit (" ^ r ^ ", " ^ h ^ ")"
11
11
| Ogit.Routes.Files r -> "Files " ^ r
12
12
| Ogit.Routes.File (r, h) -> "File (" ^ r ^ ", " ^ h ^ ")"
13
Added:
| Ogit.Routes.File_at (r, p) -> "File_at (" ^ r ^ ", " ^ p ^ ")"
13
14
| Ogit.Routes.Raw_file (r, h) -> "Raw_file (" ^ r ^ ", " ^ h ^ ")"
15
Added:
| Ogit.Routes.Raw_at (r, p) -> "Raw_at (" ^ r ^ ", " ^ p ^ ")"
14
16
15
17
let route_testable =
16
18
let pp fmt = function
@@ -27,16 +29,30 @@
27
29
check_dispatch "commits" "myrepo/commits/" (Some (Commits "myrepo"));
28
30
check_dispatch "files" "myrepo/files/" (Some (Files "myrepo"))
29
31
32
Added:
let full_hash = String.make 40 'a'
33
Added:
30
34
let test_parametric_actions () =
31
35
check_dispatch "commit with hash" "myrepo/commit/abc123"
32
36
(Some (Commit ("myrepo", "abc123")));
33
Removed:
check_dispatch "file with hash" "myrepo/file/def456"
34
Removed:
(Some (File ("myrepo", "def456")));
35
Removed:
check_dispatch "raw with hash" "myrepo/raw/789abc"
36
Removed:
(Some (Raw_file ("myrepo", "789abc")));
37
Added:
check_dispatch "file with full hash"
38
Added:
("myrepo/file/" ^ full_hash)
39
Added:
(Some (File ("myrepo", full_hash)));
40
Added:
check_dispatch "raw with full hash"
41
Added:
("myrepo/raw/" ^ full_hash)
42
Added:
(Some (Raw_file ("myrepo", full_hash)));
37
43
check_dispatch "commits for branch" "myrepo/commits/main"
38
44
(Some (Commits_branch ("myrepo", "main")))
39
45
46
Added:
let test_path_actions () =
47
Added:
check_dispatch "file at path" "myrepo/file/src/main.ml"
48
Added:
(Some (File_at ("myrepo", "src/main.ml")));
49
Added:
check_dispatch "file at single segment" "myrepo/file/README.md"
50
Added:
(Some (File_at ("myrepo", "README.md")));
51
Added:
check_dispatch "raw at path" "myrepo/raw/doc/logo.svg"
52
Added:
(Some (Raw_at ("myrepo", "doc/logo.svg")));
53
Added:
check_dispatch "encoded segment decodes" "myrepo/file/a%20b.txt"
54
Added:
(Some (File_at ("myrepo", "a b.txt")))
55
Added:
40
56
let test_nested_repo () =
41
57
check_dispatch "nested summary" "sub/dir/repo/summary/"
42
58
(Some (Repo "sub/dir/repo"));
@@ -63,7 +79,8 @@
63
79
check_dispatch "trailing junk after files" "myrepo/files/extra" None;
64
80
check_dispatch "trailing junk after hash" "myrepo/commit/abc/def" None
65
81
66
Removed:
(* The documented contract: dispatch inverts path_of for every route shape. *)
82
Added:
(* The documented contract: dispatch inverts path_of for every route shape,
83
Added:
including file paths that need percent-encoding. *)
67
84
let test_round_trip () =
68
85
let samples =
69
86
Ogit.Routes.
@@ -77,8 +94,11 @@
77
94
Commits_branch ("repo", "main");
78
95
Commit ("repo", "abc123");
79
96
Files "repo";
80
Removed:
File ("repo", "def456");
81
Removed:
Raw_file ("repo", "789abc");
97
Added:
File ("repo", String.make 40 'a');
98
Added:
File_at ("repo", "src/main.ml");
99
Added:
File_at ("repo", "dir with space/na%me.txt");
100
Added:
Raw_file ("repo", String.make 40 'b');
101
Added:
Raw_at ("repo", "doc/logo.svg");
82
102
]
83
103
in
84
104
List.iter
@@ -96,6 +116,7 @@
96
116
[
97
117
Alcotest.test_case "basic actions" `Quick test_basic_actions;
98
118
Alcotest.test_case "parametric actions" `Quick test_parametric_actions;
119
Added:
Alcotest.test_case "path actions" `Quick test_path_actions;
99
120
Alcotest.test_case "nested repo" `Quick test_nested_repo;
100
121
Alcotest.test_case "implicit summary" `Quick test_implicit_summary;
101
122
Alcotest.test_case "root" `Quick test_root;
test/test_router.ml
@@ -94,6 +94,34 @@
94
94
"nosniff" "nosniff"
95
95
(header "X-Content-Type-Options"))
96
96
97
Added:
(* Files are addressable by their path from the repository root, for both the
98
Added:
rendered page and the raw content. *)
99
Added:
let test_file_by_path () =
100
Added:
with_temp_directory "ogit-router" (fun root ->
101
Added:
let name = "project" in
102
Added:
let path = Filename.concat root name in
103
Added:
Unix.mkdir path 0o755;
104
Added:
ignore (git [ "-C"; path; "init"; "-q"; "-b"; "main" ]);
105
Added:
ignore (git [ "-C"; path; "config"; "user.name"; "Test" ]);
106
Added:
ignore (git [ "-C"; path; "config"; "user.email"; "t@t.invalid" ]);
107
Added:
let dir = Filename.concat path "dir" in
108
Added:
Unix.mkdir dir 0o755;
109
Added:
Out_channel.with_open_text (Filename.concat dir "nested.txt") (fun ch ->
110
Added:
output_string ch "nested content\n");
111
Added:
ignore (git [ "-C"; path; "add"; "." ]);
112
Added:
ignore (git [ "-C"; path; "commit"; "-q"; "-m"; "init" ]);
113
Added:
let config = Ogit.Config.{ default with git_project_root = root } in
114
Added:
let request = Dream.test (Dream.router (Ogit.Handlers.routes config)) in
115
Added:
let status target =
116
Added:
Dream.request ~target "" |> request |> Dream.status
117
Added:
|> Dream.status_to_int
118
Added:
in
119
Added:
Alcotest.(check int) "blob page" 200 (status "/project/file/dir/nested.txt");
120
Added:
Alcotest.(check int) "tree page" 200 (status "/project/file/dir");
121
Added:
Alcotest.(check int) "raw blob" 200 (status "/project/raw/dir/nested.txt");
122
Added:
Alcotest.(check int) "missing path" 404 (status "/project/file/dir/none");
123
Added:
Alcotest.(check int) "raw tree" 400 (status "/project/raw/dir"))
124
Added:
97
125
let suite =
98
126
( "router",
99
127
[
@@ -102,4 +130,5 @@
102
130
Alcotest.test_case "invalid hash" `Slow test_invalid_hash;
103
131
Alcotest.test_case "missing object" `Slow test_missing_object;
104
132
Alcotest.test_case "raw response headers" `Slow test_raw_response_headers;
133
Added:
Alcotest.test_case "file by path" `Slow test_file_by_path;
105
134
] )