[OCaml] Mobile-friendly clone of cgit.
refactor Make dispatch return the route type
dispatch produced a separate action type, so the "one value in both directions" promise was untestable. It now returns Routes.t and a test verifies that dispatch inverts path_of for every route shape. Accepted paths are exact: a recognised route followed by extra segments is rejected instead of ignored. The reserved segment names are documented.
Changed files
lib/handlers.ml
@@ -310,36 +310,41 @@
310
310
| None -> path
311
311
| Some i -> String.sub path 0 i
312
312
in
313
Added:
(* A path without a reserved segment names either a repository (serve its
314
Added:
summary) or a directory of repositories (serve the listing). The
315
Added:
filesystem decides: a name that opens as a repository is one. *)
316
Added:
let summary_or_directory name =
317
Added:
Lwt.bind (Resolvers.open_repository config name) (function
318
Added:
| Error (Resolvers.Not_found _) -> project_dir config name
319
Added:
| Error error -> error_response error
320
Added:
| Ok repository ->
321
Added:
let context = Repo.view_context config repository in
322
Added:
Lwt.finalize
323
Added:
(fun () -> Repo.summary config repository context)
324
Added:
(fun () -> Resolvers.close_repository repository))
325
Added:
in
313
326
match Routes.dispatch path with
314
327
| None -> error_response (Not_found ("not found: " ^ Dream.target request))
315
Removed:
| Some (name, action) -> (
316
Removed:
match action with
317
Removed:
| Routes.Summary ->
318
Removed:
Lwt.bind (Resolvers.open_repository config name) (function
319
Removed:
| Error (Resolvers.Not_found _) -> project_dir config name
320
Removed:
| Error error -> error_response error
321
Removed:
| Ok repository ->
322
Removed:
let context = Repo.view_context config repository in
323
Removed:
Lwt.finalize
324
Removed:
(fun () -> Repo.summary config repository context)
325
Removed:
(fun () -> Resolvers.close_repository repository))
326
Removed:
| Routes.Commits_page ->
327
Removed:
Repo.with_repository config name (fun repository context ->
328
Removed:
Repo.commits config request repository context)
329
Removed:
| Routes.Commits_for_branch branch ->
330
Removed:
Repo.with_repository config name (fun repository context ->
331
Removed:
Repo.commits_branch config repository context branch)
332
Removed:
| Routes.Commit_detail hash ->
333
Removed:
Repo.with_repository config name (fun repository context ->
334
Removed:
Repo.commit_id repository context hash)
335
Removed:
| Routes.Files_page ->
336
Removed:
Repo.with_repository config name Repo.files_at_head
337
Removed:
| Routes.File_detail hash ->
338
Removed:
Repo.with_repository config name (fun repository context ->
339
Removed:
Repo.file_id repository context hash)
340
Removed:
| Routes.Raw hash ->
341
Removed:
Repo.with_repository config name (fun repository context ->
342
Removed:
Repo.raw_file repository context hash))
328
Added:
| Some Routes.Root -> root config request
329
Added:
| Some (Routes.Project_dir name) | Some (Routes.Repo name) ->
330
Added:
summary_or_directory name
331
Added:
| Some (Routes.Commits name) ->
332
Added:
Repo.with_repository config name (fun repository context ->
333
Added:
Repo.commits config request repository context)
334
Added:
| Some (Routes.Commits_branch (name, branch)) ->
335
Added:
Repo.with_repository config name (fun repository context ->
336
Added:
Repo.commits_branch config repository context branch)
337
Added:
| Some (Routes.Commit (name, hash)) ->
338
Added:
Repo.with_repository config name (fun repository context ->
339
Added:
Repo.commit_id repository context hash)
340
Added:
| Some (Routes.Files name) ->
341
Added:
Repo.with_repository config name Repo.files_at_head
342
Added:
| Some (Routes.File (name, hash)) ->
343
Added:
Repo.with_repository config name (fun repository context ->
344
Added:
Repo.file_id repository context hash)
345
Added:
| Some (Routes.Raw_file (name, hash)) ->
346
Added:
Repo.with_repository config name (fun repository context ->
347
Added:
Repo.raw_file repository context hash)
343
348
in
344
349
[
345
350
Dream.get "/" (root config);
lib/routes.ml
@@ -3,12 +3,8 @@
3
3
One {!t} value describes a page, and the same value both generates a link
4
4
({!path_of}) and is recovered from an incoming request ({!dispatch}).
5
5
Keeping the two directions in one module is what stops generated links and
6
Removed:
served routes from drifting apart.
6
Added:
served routes from drifting apart. *)
7
7
8
Removed:
Only path-shaped routes live here. Query parameters — the commit list's
9
Removed:
filters and page number — are not modelled, because they refine a page
10
Removed:
rather than identify one. *)
11
Removed:
12
8
type t =
13
9
| Root
14
10
| Project_dir of string
@@ -32,46 +28,38 @@
32
28
| File (repo, hash) -> "/" ^ repo ^ "/file/" ^ hash
33
29
| Raw_file (repo, hash) -> "/" ^ repo ^ "/raw/" ^ hash
34
30
35
Removed:
(** Dispatch a request path (without leading slash) into a route. Returns
36
Removed:
[(repo_name, action, param)] where action identifies what to do. *)
37
Removed:
type action =
38
Removed:
| Summary
39
Removed:
| Commits_page
40
Removed:
| Commits_for_branch of string
41
Removed:
| Commit_detail of string
42
Removed:
| Files_page
43
Removed:
| File_detail of string
44
Removed:
| Raw of string
45
Removed:
46
31
let known_actions = [ "summary"; "commits"; "commit"; "files"; "file"; "raw" ]
47
32
33
Added:
(* The split point is the first segment naming a known action; everything
34
Added:
before it is the repository or directory path. Anything after the action
35
Added:
that the route shapes above do not account for is rejected rather than
36
Added:
ignored, so every accepted path is one [path_of] can regenerate. *)
48
37
let dispatch path =
49
Removed:
(* path is the full URL path without leading slash, e.g. "sub/repo/commits/" *)
50
38
let segments =
51
39
String.split_on_char '/' path |> List.filter (fun s -> s <> "")
52
40
in
53
Removed:
(* Try to find the split point: the last segment that matches a known action *)
54
41
let rec find_split repo_acc = function
55
Removed:
| [] ->
56
Removed:
(* No action found — treat the whole path as repo with implicit summary *)
42
Added:
| [] -> (
43
Added:
(* No action segment: the root, or a repository/directory path whose
44
Added:
page is the implicit summary. Only the filesystem can tell a
45
Added:
repository from a directory of repositories, so dispatch reports
46
Added:
[Project_dir] and the handler resolves which one it is. *)
47
Added:
match String.concat "/" (List.rev repo_acc) with
48
Added:
| "" -> Some Root
49
Added:
| repo -> Some (Project_dir repo))
50
Added:
| seg :: rest when List.mem seg known_actions -> (
57
51
let repo = String.concat "/" (List.rev repo_acc) in
58
Removed:
if repo = "" then None else Some (repo, Summary)
59
Removed:
| seg :: rest when List.mem seg known_actions ->
60
Removed:
let repo = String.concat "/" (List.rev repo_acc) in
61
52
if repo = "" then None
62
53
else
63
Removed:
let action =
64
Removed:
match (seg, rest) with
65
Removed:
| "summary", _ -> Some Summary
66
Removed:
| "commits", [] -> Some Commits_page
67
Removed:
| "commits", [ branch ] -> Some (Commits_for_branch branch)
68
Removed:
| "commit", [ hash ] -> Some (Commit_detail hash)
69
Removed:
| "files", _ -> Some Files_page
70
Removed:
| "file", [ hash ] -> Some (File_detail hash)
71
Removed:
| "raw", [ hash ] -> Some (Raw hash)
72
Removed:
| _ -> None
73
Removed:
in
74
Removed:
Option.map (fun a -> (repo, a)) action
54
Added:
match (seg, rest) with
55
Added:
| "summary", [] -> Some (Repo repo)
56
Added:
| "commits", [] -> Some (Commits repo)
57
Added:
| "commits", [ branch ] -> Some (Commits_branch (repo, branch))
58
Added:
| "commit", [ hash ] -> Some (Commit (repo, hash))
59
Added:
| "files", [] -> Some (Files repo)
60
Added:
| "file", [ hash ] -> Some (File (repo, hash))
61
Added:
| "raw", [ hash ] -> Some (Raw_file (repo, hash))
62
Added:
| _ -> None)
75
63
| seg :: rest -> find_split (seg :: repo_acc) rest
76
64
in
77
65
find_split [] segments
lib/routes.mli
@@ -1,14 +1,20 @@
1
1
(** URL paths, in both directions.
2
2
3
3
One {!t} value describes a page, and the same value both generates a link
4
Removed:
({!path_of}) and is recovered from an incoming request ({!dispatch}).
5
Removed:
Keeping the two directions in one module is what stops generated links and
6
Removed:
served routes from drifting apart.
4
Added:
({!path_of}) and is recovered from an incoming request ({!dispatch}). For
5
Added:
every route [r], [dispatch] inverts [path_of]:
6
Added:
[dispatch (path_of r without its leading slash) = Some r]. Keeping the two
7
Added:
directions in one module is what stops generated links and served routes
8
Added:
from drifting apart.
7
9
8
10
Only path-shaped routes live here. Query parameters — the commit list's
9
11
filters and page number — are not modelled, because they refine a page
10
Removed:
rather than identify one. *)
12
Added:
rather than identify one.
11
13
14
Added:
The segments [summary], [commits], [commit], [files], [file], and [raw] are
15
Added:
reserved: they mark where a repository path ends, so a repository or
16
Added:
directory carrying one of these names is not reachable. *)
17
Added:
12
18
(** {1 Routes} *)
13
19
14
20
type t =
@@ -29,16 +35,11 @@
29
35
30
36
(** {1 Dispatch} *)
31
37
32
Removed:
type action =
33
Removed:
| Summary
34
Removed:
| Commits_page
35
Removed:
| Commits_for_branch of string
36
Removed:
| Commit_detail of string
37
Removed:
| Files_page
38
Removed:
| File_detail of string
39
Removed:
| Raw of string
40
Removed:
(** What the handler should do once the repository is identified. *)
38
Added:
val dispatch : string -> t option
39
Added:
(** Parse a request path (without leading slash) back into a route. Returns
40
Added:
[None] when the path matches no known route, including a recognised route
41
Added:
followed by extra segments.
41
42
42
Removed:
val dispatch : string -> (string * action) option
43
Removed:
(** Parse a request path (without leading slash) into a repository name and
44
Removed:
action. Returns [None] when the path does not match any known route. *)
43
Added:
A path without a reserved segment comes back as {!Project_dir} even when it
44
Added:
names a repository: only the filesystem can tell the two apart, so the
45
Added:
handler resolves which page to serve. *)
test/test_dispatch.ml
@@ -1,65 +1,96 @@
1
Removed:
(** URL dispatch: that {!Ogit.Routes.dispatch} recovers the intended repository
2
Removed:
and action, including from malformed input. *)
1
Added:
(** URL dispatch: that {!Ogit.Routes.dispatch} recovers the intended route,
2
Added:
rejects malformed input, and inverts {!Ogit.Routes.path_of}. *)
3
3
4
Removed:
let action_to_string = function
5
Removed:
| Ogit.Routes.Summary -> "Summary"
6
Removed:
| Ogit.Routes.Commits_page -> "Commits_page"
7
Removed:
| Ogit.Routes.Commits_for_branch b -> "Commits_for_branch " ^ b
8
Removed:
| Ogit.Routes.Commit_detail h -> "Commit_detail " ^ h
9
Removed:
| Ogit.Routes.Files_page -> "Files_page"
10
Removed:
| Ogit.Routes.File_detail h -> "File_detail " ^ h
11
Removed:
| Ogit.Routes.Raw h -> "Raw " ^ h
4
Added:
let route_to_string = function
5
Added:
| Ogit.Routes.Root -> "Root"
6
Added:
| Ogit.Routes.Project_dir d -> "Project_dir " ^ d
7
Added:
| Ogit.Routes.Repo r -> "Repo " ^ r
8
Added:
| Ogit.Routes.Commits r -> "Commits " ^ r
9
Added:
| Ogit.Routes.Commits_branch (r, b) -> "Commits_branch (" ^ r ^ ", " ^ b ^ ")"
10
Added:
| Ogit.Routes.Commit (r, h) -> "Commit (" ^ r ^ ", " ^ h ^ ")"
11
Added:
| Ogit.Routes.Files r -> "Files " ^ r
12
Added:
| Ogit.Routes.File (r, h) -> "File (" ^ r ^ ", " ^ h ^ ")"
13
Added:
| Ogit.Routes.Raw_file (r, h) -> "Raw_file (" ^ r ^ ", " ^ h ^ ")"
12
14
13
Removed:
let check_dispatch msg path expected =
14
Removed:
let result = Ogit.Routes.dispatch path in
15
Added:
let route_testable =
15
16
let pp fmt = function
16
17
| None -> Format.fprintf fmt "None"
17
Removed:
| Some (repo, action) ->
18
Removed:
Format.fprintf fmt "Some (%S, %s)" repo (action_to_string action)
18
Added:
| Some route -> Format.fprintf fmt "Some (%s)" (route_to_string route)
19
19
in
20
Removed:
let eq a b =
21
Removed:
match (a, b) with
22
Removed:
| None, None -> true
23
Removed:
| Some (r1, a1), Some (r2, a2) ->
24
Removed:
r1 = r2 && action_to_string a1 = action_to_string a2
25
Removed:
| _ -> false
26
Removed:
in
27
Removed:
let testable = Alcotest.testable pp eq in
28
Removed:
Alcotest.check testable msg expected result
20
Added:
Alcotest.testable pp ( = )
29
21
22
Added:
let check_dispatch msg path expected =
23
Added:
Alcotest.check route_testable msg expected (Ogit.Routes.dispatch path)
24
Added:
30
25
let test_basic_actions () =
31
Removed:
check_dispatch "summary" "myrepo/summary/" (Some ("myrepo", Summary));
32
Removed:
check_dispatch "commits" "myrepo/commits/" (Some ("myrepo", Commits_page));
33
Removed:
check_dispatch "files" "myrepo/files/" (Some ("myrepo", Files_page))
26
Added:
check_dispatch "summary" "myrepo/summary/" (Some (Repo "myrepo"));
27
Added:
check_dispatch "commits" "myrepo/commits/" (Some (Commits "myrepo"));
28
Added:
check_dispatch "files" "myrepo/files/" (Some (Files "myrepo"))
34
29
35
30
let test_parametric_actions () =
36
31
check_dispatch "commit with hash" "myrepo/commit/abc123"
37
Removed:
(Some ("myrepo", Commit_detail "abc123"));
32
Added:
(Some (Commit ("myrepo", "abc123")));
38
33
check_dispatch "file with hash" "myrepo/file/def456"
39
Removed:
(Some ("myrepo", File_detail "def456"));
34
Added:
(Some (File ("myrepo", "def456")));
40
35
check_dispatch "raw with hash" "myrepo/raw/789abc"
41
Removed:
(Some ("myrepo", Raw "789abc"));
36
Added:
(Some (Raw_file ("myrepo", "789abc")));
42
37
check_dispatch "commits for branch" "myrepo/commits/main"
43
Removed:
(Some ("myrepo", Commits_for_branch "main"))
38
Added:
(Some (Commits_branch ("myrepo", "main")))
44
39
45
40
let test_nested_repo () =
46
41
check_dispatch "nested summary" "sub/dir/repo/summary/"
47
Removed:
(Some ("sub/dir/repo", Summary));
42
Added:
(Some (Repo "sub/dir/repo"));
48
43
check_dispatch "nested commit" "sub/repo/commit/abc"
49
Removed:
(Some ("sub/repo", Commit_detail "abc"));
44
Added:
(Some (Commit ("sub/repo", "abc")));
50
45
check_dispatch "deeply nested" "a/b/c/repo/files/"
51
Removed:
(Some ("a/b/c/repo", Files_page))
46
Added:
(Some (Files "a/b/c/repo"))
52
47
48
Added:
(* A path without a reserved segment is reported as [Project_dir]; the handler
49
Added:
decides whether the filesystem holds a repository or a directory there. *)
53
50
let test_implicit_summary () =
54
Removed:
check_dispatch "bare repo path" "myrepo" (Some ("myrepo", Summary));
55
Removed:
check_dispatch "bare with trailing slash" "myrepo/" (Some ("myrepo", Summary))
51
Added:
check_dispatch "bare repo path" "myrepo" (Some (Project_dir "myrepo"));
52
Added:
check_dispatch "bare with trailing slash" "myrepo/"
53
Added:
(Some (Project_dir "myrepo"))
56
54
55
Added:
let test_root () = check_dispatch "empty path is root" "" (Some Root)
56
Added:
57
57
let test_malformed () =
58
Removed:
check_dispatch "empty path" "" None;
59
58
check_dispatch "commit without hash" "myrepo/commit/" None;
60
59
check_dispatch "file without hash" "myrepo/file/" None;
61
Removed:
check_dispatch "raw without hash" "myrepo/raw/" None
60
Added:
check_dispatch "raw without hash" "myrepo/raw/" None;
61
Added:
check_dispatch "action without repo" "summary/" None;
62
Added:
check_dispatch "trailing junk after summary" "myrepo/summary/junk" None;
63
Added:
check_dispatch "trailing junk after files" "myrepo/files/extra" None;
64
Added:
check_dispatch "trailing junk after hash" "myrepo/commit/abc/def" None
62
65
66
Added:
(* The documented contract: dispatch inverts path_of for every route shape. *)
67
Added:
let test_round_trip () =
68
Added:
let samples =
69
Added:
Ogit.Routes.
70
Added:
[
71
Added:
Root;
72
Added:
Project_dir "dir";
73
Added:
Project_dir "nested/dir";
74
Added:
Repo "repo";
75
Added:
Repo "sub/repo";
76
Added:
Commits "repo";
77
Added:
Commits_branch ("repo", "main");
78
Added:
Commit ("repo", "abc123");
79
Added:
Files "repo";
80
Added:
File ("repo", "def456");
81
Added:
Raw_file ("repo", "789abc");
82
Added:
]
83
Added:
in
84
Added:
List.iter
85
Added:
(fun route ->
86
Added:
let path = Ogit.Routes.path_of route in
87
Added:
let stripped = String.sub path 1 (String.length path - 1) in
88
Added:
Alcotest.check route_testable
89
Added:
(Printf.sprintf "round trip %s" (route_to_string route))
90
Added:
(Some route)
91
Added:
(Ogit.Routes.dispatch stripped))
92
Added:
samples
93
Added:
63
94
let suite =
64
95
( "dispatch",
65
96
[
@@ -67,5 +98,7 @@
67
98
Alcotest.test_case "parametric actions" `Quick test_parametric_actions;
68
99
Alcotest.test_case "nested repo" `Quick test_nested_repo;
69
100
Alcotest.test_case "implicit summary" `Quick test_implicit_summary;
101
Added:
Alcotest.test_case "root" `Quick test_root;
70
102
Alcotest.test_case "malformed URLs" `Quick test_malformed;
103
Added:
Alcotest.test_case "round trip" `Quick test_round_trip;
71
104
] )