[OCaml] Mobile-friendly clone of cgit.
refactor centralize repository request lifecycle
Load and validate configuration explicitly, preserve typed resolver errors through HTTP status mapping, and reuse one Git store per repository request with guaranteed cleanup. Use bidirectional dream-html paths for routing and links, remove I/O from views, consolidate page rendering and reference lookup, honor configured commit limits, and make tree path failures unambiguous. Expand regression coverage for configuration failures, repository routing, object status classification, breadcrumb resolution, and scoped test fixtures. Update architecture documentation and release version derivation.
Changed files
README.org
@@ -7,14 +7,56 @@
7
7
8
8
* Ogit
9
9
10
Removed:
A mobile-friendly alternative to cgit.
10
Added:
A lightweight, mobile-friendly alternative to cgit.
11
11
12
12
13
Removed:
** Alternatives
13
Added:
* Architecture
14
14
15
Added:
The executable in =bin/main.ml= loads configuration and delegates to
16
Added:
=lib/main.ml=. Startup fails visibly when an explicitly selected
17
Added:
configuration file is missing or when configuration cannot be parsed or
18
Added:
validated.
19
Added:
20
Added:
Requests flow through the following layers:
21
Added:
22
Added:
1. =Routes= defines bidirectional, type-safe paths used for both Dream
23
Added:
route registration and generated links.
24
Added:
2. =Handlers= opens and validates one repository context per request,
25
Added:
maps application errors to HTTP statuses, and coordinates data
26
Added:
access with rendering.
27
Added:
3. =Resolvers= provides repository discovery and Git data access. An
28
Added:
opened repository context owns its Git store, resolved metadata, and
29
Added:
default-branch policy so operations in one request reuse the same
30
Added:
store.
31
Added:
4. =Views= renders data supplied by handlers. Views do not access the
32
Added:
filesystem or load configuration.
33
Added:
5. =Static_handler= serves assets embedded at build time by
34
Added:
=ocaml-crunch=.
35
Added:
36
Added:
Resolver failures retain their category until the HTTP boundary:
37
Added:
malformed input becomes =400 Bad Request=, missing repositories or Git
38
Added:
objects become =404 Not Found=, and storage or filesystem failures
39
Added:
become =500 Internal Server Error=.
40
Added:
41
Added:
42
Added:
* Configuration
43
Added:
44
Added:
Ogit reads the path named by =OGIT_CONFIG=. Otherwise it checks
45
Added:
=$XDG_CONFIG_HOME/ogit/config.toml= and finally
46
Added:
=/etc/ogit/config.toml=. When no explicit =OGIT_CONFIG= is selected, a
47
Added:
missing file uses environment-derived defaults; malformed or invalid
48
Added:
files never silently fall back.
49
Added:
50
Added:
The =commits_max_displayed= value controls commit list lengths on summary,
51
Added:
all-commit, and branch pages. =default_branch= is tried after =HEAD= and
52
Added:
before the conventional =main= and =master= fallbacks.
53
Added:
54
Added:
55
Added:
* Alternatives
56
Added:
15
57
- =cgit=
16
58
- Very fast page renders.
17
Removed:
- Unwieldly appearance on mobile.
59
Added:
- Unwieldy appearance on mobile.
18
60
- Extensive use of Git terminology; not beginner-friendly.
19
61
- codemadness' =stagit=
20
62
- Minimalist.
@@ -26,16 +68,8 @@
26
68
Listed in no particular order.
27
69
28
70
29
Removed:
** Features
30
Removed:
31
Removed:
- [ ] Repo file browser breadcrumbs
32
Removed:
- [ ] Diff view for commits
33
Removed:
- [ ] Index link
34
Removed:
- [ ] Config default app port
35
Removed:
36
Removed:
37
71
** Bugs
38
72
39
73
- [ ] Proper copyright holder management.
40
74
- Should be the main repository author by default, not the ogit
41
Removed:
process owner...
75
Added:
process owner.
lib/config.ml
@@ -11,31 +11,42 @@
11
11
port : int;
12
12
}
13
13
14
Added:
type load_error =
15
Added:
| Not_found of string
16
Added:
| Parse_error of string
17
Added:
| Invalid_value of string
18
Added:
| Io_error of string
19
Added:
20
Added:
let environment_value name =
21
Added:
match Sys.getenv_opt name with Some "" | None -> None | value -> value
22
Added:
23
Added:
let getenv_first names ~default =
24
Added:
List.find_map environment_value names |> Option.value ~default
25
Added:
14
26
let default =
27
Added:
let home = getenv_first [ "HOME" ] ~default:"." in
15
28
{
16
Removed:
user = Sys.getenv "LOGNAME";
17
Removed:
default_branch = "master";
18
Removed:
git_project_root = Filename.concat (Sys.getenv "HOME") "git";
29
Added:
user = getenv_first [ "LOGNAME"; "USER" ] ~default:"git";
30
Added:
default_branch = "main";
31
Added:
git_project_root = Filename.concat home "git";
19
32
commits_max_displayed = 10;
20
33
host = "127.0.0.1";
21
34
port = 8081;
22
35
}
23
36
24
37
let locate_config_file () =
25
Removed:
match Sys.getenv_opt "OGIT_CONFIG" with
38
Added:
match environment_value "OGIT_CONFIG" with
26
39
| Some file -> file
27
40
| None -> (
28
Removed:
match Sys.getenv_opt "XDG_CONFIG_HOME" with
41
Added:
match environment_value "XDG_CONFIG_HOME" with
29
42
| Some config_home ->
30
43
Filename.concat (Filename.concat config_home "ogit") "config.toml"
31
44
| None -> "/etc/ogit/config.toml")
32
45
33
Removed:
let config_file = locate_config_file ()
34
Removed:
35
46
let to_table t =
36
47
let open Types in
37
48
List.map
38
Removed:
(fun (k, v) -> (Min.key k, v))
49
Added:
(fun (key, value) -> (Min.key key, value))
39
50
[
40
51
("user", TString t.user);
41
52
("default_branch", TString t.default_branch);
@@ -46,59 +57,114 @@
46
57
]
47
58
|> Min.of_key_values
48
59
49
Removed:
let write_file ?(file = config_file) table =
50
Removed:
let oc = open_out file in
51
Removed:
Printer.string_of_table table |> Printf.fprintf oc "%s\n";
52
Removed:
close_out oc
60
Added:
let write_file ?file table =
61
Added:
let file = Option.value file ~default:(locate_config_file ()) in
62
Added:
Out_channel.with_open_text file (fun channel ->
63
Added:
Printer.string_of_table table |> Printf.fprintf channel "%s\n")
53
64
54
Removed:
let read_file ?(file = config_file) () =
65
Added:
let find_string table key =
66
Added:
match Types.Table.find_opt (Min.key key) table with
67
Added:
| Some (Types.TString value) -> Ok value
68
Added:
| Some _ -> Error (Invalid_value ("expected string for key: " ^ key))
69
Added:
| None -> Error (Invalid_value ("missing key: " ^ key))
70
Added:
71
Added:
let find_int table key =
72
Added:
match Types.Table.find_opt (Min.key key) table with
73
Added:
| Some (Types.TInt value) -> Ok value
74
Added:
| Some _ -> Error (Invalid_value ("expected int for key: " ^ key))
75
Added:
| None -> Error (Invalid_value ("missing key: " ^ key))
76
Added:
77
Added:
let find_string_opt table key ~default =
78
Added:
match Types.Table.find_opt (Min.key key) table with
79
Added:
| Some (Types.TString value) -> Ok value
80
Added:
| Some _ -> Error (Invalid_value ("expected string for key: " ^ key))
81
Added:
| None -> Ok default
82
Added:
83
Added:
let find_int_opt table key ~default =
84
Added:
match Types.Table.find_opt (Min.key key) table with
85
Added:
| Some (Types.TInt value) -> Ok value
86
Added:
| Some _ -> Error (Invalid_value ("expected int for key: " ^ key))
87
Added:
| None -> Ok default
88
Added:
89
Added:
let of_table table =
90
Added:
let ( let* ) = Result.bind in
91
Added:
let* git_project_root = find_string table "git_project_root" in
92
Added:
let* user = find_string table "user" in
93
Added:
let* default_branch = find_string table "default_branch" in
94
Added:
let* commits_max_displayed = find_int table "commits_max_displayed" in
95
Added:
let* host = find_string_opt table "host" ~default:default.host in
96
Added:
let* port = find_int_opt table "port" ~default:default.port in
97
Added:
if commits_max_displayed <= 0 then
98
Added:
Error (Invalid_value "commits_max_displayed must be positive")
99
Added:
else if port < 1 || port > 65535 then
100
Added:
Error (Invalid_value "port must be between 1 and 65535")
101
Added:
else
102
Added:
Ok
103
Added:
{
104
Added:
git_project_root;
105
Added:
user;
106
Added:
default_branch;
107
Added:
commits_max_displayed;
108
Added:
host;
109
Added:
port;
110
Added:
}
111
Added:
112
Added:
let io_error file error =
113
Added:
Io_error (Printf.sprintf "%s: %s" file (Unix.error_message error))
114
Added:
115
Added:
let file_exists file =
55
116
try
117
Added:
ignore (Unix.stat file);
118
Added:
Ok ()
119
Added:
with
120
Added:
| Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
121
Added:
Error (Not_found file)
122
Added:
| Unix.Unix_error (error, _, _) -> Error (io_error file error)
123
Added:
124
Added:
let read_file ?file () =
125
Added:
let file = Option.value file ~default:(locate_config_file ()) in
126
Added:
let ( let* ) = Result.bind in
127
Added:
let* () = file_exists file in
128
Added:
try
56
129
match Toml.Parser.from_filename file with
57
Removed:
| `Error (e, l) ->
58
Removed:
Error (Printf.sprintf "%s: %s at line %d" l.source e l.line)
59
Removed:
| `Ok table ->
60
Removed:
let find_string key =
61
Removed:
match Types.Table.find_opt (Min.key key) table with
62
Removed:
| Some (TString s) -> Ok s
63
Removed:
| Some _ -> Error ("Expected string for key: " ^ key)
64
Removed:
| None -> Error ("Missing key: " ^ key)
65
Removed:
in
66
Removed:
let find_int key =
67
Removed:
match Types.Table.find_opt (Min.key key) table with
68
Removed:
| Some (TInt i) -> Ok i
69
Removed:
| Some _ -> Error ("Expected int for key: " ^ key)
70
Removed:
| None -> Error ("Missing key: " ^ key)
71
Removed:
in
72
Removed:
let find_string_opt key ~default:d =
73
Removed:
match Types.Table.find_opt (Min.key key) table with
74
Removed:
| Some (TString s) -> Ok s
75
Removed:
| Some _ -> Error ("Expected string for key: " ^ key)
76
Removed:
| None -> Ok d
77
Removed:
in
78
Removed:
let find_int_opt key ~default:d =
79
Removed:
match Types.Table.find_opt (Min.key key) table with
80
Removed:
| Some (TInt i) -> Ok i
81
Removed:
| Some _ -> Error ("Expected int for key: " ^ key)
82
Removed:
| None -> Ok d
83
Removed:
in
84
Removed:
let ( let* ) = Result.bind in
85
Removed:
let* git_project_root = find_string "git_project_root" in
86
Removed:
let* user = find_string "user" in
87
Removed:
let* default_branch = find_string "default_branch" in
88
Removed:
let* commits_max_displayed = find_int "commits_max_displayed" in
89
Removed:
let* host = find_string_opt "host" ~default:default.host in
90
Removed:
let* port = find_int_opt "port" ~default:default.port in
91
Removed:
Ok
92
Removed:
{
93
Removed:
git_project_root;
94
Removed:
user;
95
Removed:
default_branch;
96
Removed:
commits_max_displayed;
97
Removed:
host;
98
Removed:
port;
99
Removed:
}
100
Removed:
with _ ->
101
Removed:
prerr_endline "[config.ml] Falling back to default config.";
102
Removed:
Ok default
130
Added:
| `Error (message, location) ->
131
Added:
Error
132
Added:
(Parse_error
133
Added:
(Printf.sprintf "%s: %s at line %d" location.source message
134
Added:
location.line))
135
Added:
| `Ok table -> of_table table
136
Added:
with Sys_error message -> Error (Io_error message)
103
137
104
Removed:
let config = match read_file () with Ok cfg -> cfg | Error _ -> default
138
Added:
let implicit_config_files () =
139
Added:
match environment_value "XDG_CONFIG_HOME" with
140
Added:
| Some config_home ->
141
Added:
[
142
Added:
Filename.concat (Filename.concat config_home "ogit") "config.toml";
143
Added:
"/etc/ogit/config.toml";
144
Added:
]
145
Added:
| None -> [ "/etc/ogit/config.toml" ]
146
Added:
147
Added:
let load () =
148
Added:
match environment_value "OGIT_CONFIG" with
149
Added:
| Some file -> read_file ~file ()
150
Added:
| None ->
151
Added:
let rec first_existing = function
152
Added:
| [] -> Ok default
153
Added:
| file :: rest -> (
154
Added:
match read_file ~file () with
155
Added:
| Error (Not_found _) -> first_existing rest
156
Added:
| result -> result)
157
Added:
in
158
Added:
first_existing (implicit_config_files ())
159
Added:
160
Added:
let pp_load_error formatter = function
161
Added:
| Not_found file ->
162
Added:
Format.fprintf formatter "configuration file not found: %s" file
163
Added:
| Parse_error message ->
164
Added:
Format.fprintf formatter "invalid configuration: %s" message
165
Added:
| Invalid_value message ->
166
Added:
Format.fprintf formatter "invalid configuration value: %s" message
167
Added:
| Io_error message ->
168
Added:
Format.fprintf formatter "could not read configuration: %s" message
169
Added:
170
Added:
let load_error_to_string error = Format.asprintf "%a" pp_load_error error
lib/handlers.ml
@@ -1,91 +1,122 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
Removed:
let root _req = Views.root ()
3
Added:
let error_response error =
4
Added:
let status, title =
5
Added:
match error with
6
Added:
| Resolvers.Bad_request _ -> (`Bad_Request, "Bad request")
7
Added:
| Resolvers.Not_found _ -> (`Not_Found, "Not found")
8
Added:
| Resolvers.Store_error _ | Resolvers.Internal _ ->
9
Added:
(`Internal_Server_Error, "Internal server error")
10
Added:
in
11
Added:
let message = Format.asprintf "%a" Resolvers.pp_error error in
12
Added:
Views.error_page ~status ~title message
4
13
14
Added:
let root config _request =
15
Added:
match Resolvers.repositories config with
16
Added:
| Ok repositories -> Views.root ~user:config.Config.user repositories
17
Added:
| Error error -> error_response error
18
Added:
5
19
module Repo = struct
6
Removed:
let ( let* ) m f =
7
Removed:
Lwt.bind m @@ function
8
Removed:
| Ok x -> f x
9
Removed:
| Error e ->
10
Removed:
let msg = Format.asprintf "%a" Resolvers.Store.pp_error e in
11
Removed:
Views.error_page msg
20
Added:
let ( let* ) result continue =
21
Added:
Lwt.bind result @@ function
22
Added:
| Ok value -> continue value
23
Added:
| Error error -> error_response error
12
24
13
Removed:
let handle handler req =
14
Removed:
let repo = Dream.param req "repo" in
15
Removed:
handler repo
25
Added:
let view_context config repository =
26
Added:
Views.Repo.context ~user:config.Config.user
27
Added:
~repo:(Resolvers.repository_name repository)
28
Added:
~description:(Resolvers.repository_description repository)
16
29
17
Removed:
let handle_id handler req =
18
Removed:
let repo = Dream.param req "repo" in
19
Removed:
let id = Dream.param req "id" in
20
Removed:
handler repo id
30
Added:
let with_repository config name continue =
31
Added:
Lwt.bind (Resolvers.open_repository config name) @@ function
32
Added:
| Error error -> error_response error
33
Added:
| Ok repository ->
34
Added:
let context = view_context config repository in
35
Added:
Lwt.finalize
36
Added:
(fun () -> continue repository context)
37
Added:
(fun () -> Resolvers.close_repository repository)
21
38
22
Removed:
let summary repo =
23
Removed:
let* branches = Resolvers.Reference.branches repo in
24
Removed:
let* commits = Resolvers.Commit.recent repo 10 in
25
Removed:
Views.Repo.summary repo branches commits
39
Added:
let handle config handler _request name = with_repository config name handler
26
40
27
Removed:
let commits repo =
28
Removed:
let* commits = Resolvers.Commit.recent repo 100 in
29
Removed:
Views.Repo.commits repo commits
41
Added:
let handle_id config handler _request name id =
42
Added:
with_repository config name (fun repository context ->
43
Added:
handler repository context id)
30
44
31
Removed:
let commits_branch repo branch =
32
Removed:
let* ref = Resolvers.Reference.of_id repo branch in
33
Removed:
let* commits = Resolvers.Commit.recent_from repo ref.hash 100 in
34
Removed:
Views.Repo.commits repo commits
45
Added:
let summary config repository context =
46
Added:
let* branches = Resolvers.Reference.branches repository in
47
Added:
let* commits =
48
Added:
Resolvers.Commit.recent repository config.Config.commits_max_displayed
49
Added:
in
50
Added:
Views.Repo.summary context branches commits
35
51
36
Removed:
let commit_id repo id =
37
Removed:
let* commit = Resolvers.Commit.of_id repo id in
38
Removed:
let* diff = Resolvers.Diff.of_commit repo commit in
39
Removed:
Views.Repo.commit repo commit diff
52
Added:
let commits config repository context =
53
Added:
let* commits =
54
Added:
Resolvers.Commit.recent repository config.Config.commits_max_displayed
55
Added:
in
56
Added:
Views.Repo.commits context commits
40
57
41
Removed:
let files_at_head repo =
42
Removed:
let* tree = Resolvers.Tree.head repo in
43
Removed:
Views.Repo.files repo [] tree
58
Added:
let commits_branch config repository context branch =
59
Added:
let* reference = Resolvers.Reference.of_id repository branch in
60
Added:
let* commits =
61
Added:
Resolvers.Commit.recent_from repository reference.hash
62
Added:
config.Config.commits_max_displayed
63
Added:
in
64
Added:
Views.Repo.commits context commits
44
65
45
Removed:
let file_id repo id =
46
Removed:
let* res = Resolvers.blob_or_tree repo id in
47
Removed:
match res with
48
Removed:
| `Tree tree ->
49
Removed:
let* trail = Resolvers.Tree.find_path repo id in
50
Removed:
Views.Repo.files repo trail tree
51
Removed:
| `Blob blob ->
52
Removed:
let* trail = Resolvers.Tree.find_path repo id in
53
Removed:
Views.Repo.file repo trail blob
66
Added:
let commit_id repository context id =
67
Added:
let* commit = Resolvers.Commit.of_id repository id in
68
Added:
let* diff = Resolvers.Diff.of_commit repository commit in
69
Added:
Views.Repo.commit context commit diff
54
70
55
Removed:
let branches repo =
56
Removed:
let* branches = Resolvers.Reference.branches repo in
57
Removed:
Views.Repo.branches repo branches
71
Added:
let files_at_head repository context =
72
Added:
let* tree = Resolvers.Tree.head repository in
73
Added:
Views.Repo.files context [] tree
58
74
59
Removed:
let tags repo =
60
Removed:
let* tags = Resolvers.Reference.tags repo in
61
Removed:
Views.Repo.tags repo tags
75
Added:
let file_id repository context id =
76
Added:
let* trail = Resolvers.Tree.find_path repository id in
77
Added:
let* object_ = Resolvers.blob_or_tree repository id in
78
Added:
match object_ with
79
Added:
| `Tree tree -> Views.Repo.files context trail tree
80
Added:
| `Blob blob -> Views.Repo.file context trail blob
62
81
63
Removed:
let readme repo =
64
Removed:
let* readme = Resolvers.Repo.readme repo in
65
Removed:
Views.Repo.file repo []
66
Removed:
@@
67
Removed:
match readme with
68
Removed:
| None -> { content = "README does not exist for " ^ repo }
69
Removed:
| Some file -> file
82
Added:
let branches repository context =
83
Added:
let* branches = Resolvers.Reference.branches repository in
84
Added:
Views.Repo.branches context branches
85
Added:
86
Added:
let tags repository context =
87
Added:
let* tags = Resolvers.Reference.tags repository in
88
Added:
Views.Repo.tags context tags
89
Added:
90
Added:
let readme repository context =
91
Added:
let* readme = Resolvers.Repo.readme repository in
92
Added:
let blob =
93
Added:
match readme with
94
Added:
| None ->
95
Added:
Resolvers.Blob.
96
Added:
{
97
Added:
content =
98
Added:
"README does not exist for "
99
Added:
^ Resolvers.repository_name repository;
100
Added:
}
101
Added:
| Some blob -> blob
102
Added:
in
103
Added:
Views.Repo.file ~active:Layout.Readme context [] blob
70
104
end
71
105
72
Removed:
let all_handlers =
73
Removed:
let open Dream in
106
Added:
let routes config =
107
Added:
let open Dream_html in
74
108
[
75
Removed:
get "/" root;
76
Removed:
scope "/:repo" []
77
Removed:
Repo.
78
Removed:
[
79
Removed:
get "/" (handle summary);
80
Removed:
get "/summary/" (handle summary);
81
Removed:
get "/commits/" (handle commits);
82
Removed:
get "/commits/:id" (handle_id commits_branch);
83
Removed:
get "/commit/:id" (handle_id commit_id);
84
Removed:
get "/files/" (handle files_at_head);
85
Removed:
get "/file/:id" (handle_id file_id);
86
Removed:
get "/branches/" (handle branches);
87
Removed:
get "/tags/" (handle tags);
88
Removed:
get "/README" (handle readme);
89
Removed:
];
90
Removed:
get "/static/**" @@ Static_handler.handler;
109
Added:
get Routes.root_path (root config);
110
Added:
get Routes.repo_root_path (Repo.handle config (Repo.summary config));
111
Added:
get Routes.repo_path (Repo.handle config (Repo.summary config));
112
Added:
get Routes.commits_path (Repo.handle config (Repo.commits config));
113
Added:
get Routes.commits_branch_path
114
Added:
(Repo.handle_id config (Repo.commits_branch config));
115
Added:
get Routes.commit_path (Repo.handle_id config Repo.commit_id);
116
Added:
get Routes.files_path (Repo.handle config Repo.files_at_head);
117
Added:
get Routes.file_path (Repo.handle_id config Repo.file_id);
118
Added:
get Routes.branches_path (Repo.handle config Repo.branches);
119
Added:
get Routes.tags_path (Repo.handle config Repo.tags);
120
Added:
get Routes.readme_path (Repo.handle config Repo.readme);
121
Added:
get Routes.static_path Static_handler.handler;
91
122
]
lib/main.ml
@@ -1,7 +1,11 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
Added:
let run_with_config config =
4
Added:
Dream.run ~port:config.Config.port ~interface:config.Config.host
5
Added:
@@ Dream.logger
6
Added:
@@ Dream.router (Handlers.routes config)
7
Added:
3
8
let run () =
4
Removed:
let port = Config.config.port in
5
Removed:
let interface = Config.config.host in
6
Removed:
Dream.run ~port ~interface @@ Dream.logger
7
Removed:
@@ Dream.router Handlers.all_handlers
9
Added:
match Config.load () with
10
Added:
| Ok config -> run_with_config config
11
Added:
| Error error -> failwith (Config.load_error_to_string error)
lib/resolvers.ml
@@ -2,8 +2,22 @@
2
2
3
3
module Store = Git_unix.Store
4
4
open Lwt_result.Syntax
5
Removed:
open Config
6
5
6
Added:
type error =
7
Added:
| Bad_request of string
8
Added:
| Not_found of string
9
Added:
| Store_error of Store.error
10
Added:
| Internal of string
11
Added:
12
Added:
let pp_error formatter = function
13
Added:
| Bad_request message -> Format.fprintf formatter "%s" message
14
Added:
| Not_found message -> Format.fprintf formatter "%s" message
15
Added:
| Store_error error -> Store.pp_error formatter error
16
Added:
| Internal message -> Format.fprintf formatter "%s" message
17
Added:
18
Added:
let map_store promise =
19
Added:
Lwt.map (Result.map_error (fun error -> Store_error error)) promise
20
Added:
7
21
let is_hex_digit = function
8
22
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
9
23
| _ -> false
@@ -13,7 +27,7 @@
13
27
14
28
let hash_of_hex hash =
15
29
if is_valid_hash_hex hash then Lwt_result.return (Store.Hash.of_hex hash)
16
Removed:
else Lwt_result.fail (`Msg ("invalid object id " ^ hash))
30
Added:
else Lwt_result.fail (Bad_request ("invalid object id " ^ hash))
17
31
18
32
let is_valid_repo_name repo =
19
33
let invalid_char = function '/' | '\\' | '\x00' -> true | _ -> false in
@@ -23,34 +37,73 @@
23
37
24
38
let validate_repo_name repo =
25
39
if is_valid_repo_name repo then Lwt_result.return repo
26
Removed:
else Lwt_result.fail (`Msg ("invalid repository name " ^ repo))
40
Added:
else Lwt_result.fail (Bad_request ("invalid repository name " ^ repo))
27
41
28
Removed:
let full_path path = Filename.concat config.git_project_root path
29
Removed:
30
42
type repository_layout = { worktree : string; git_dir : string }
31
43
32
Removed:
let is_directory path = try Sys.is_directory path with Sys_error _ -> false
44
Added:
let filesystem_error path error =
45
Added:
Internal (Printf.sprintf "%s: %s" path (Unix.error_message error))
33
46
34
Removed:
let is_git_directory path =
35
Removed:
is_directory path
36
Removed:
&& Sys.file_exists (Filename.concat path "HEAD")
37
Removed:
&& is_directory (Filename.concat path "objects")
47
Added:
let is_directory_result path =
48
Added:
try Ok ((Unix.stat path).st_kind = Unix.S_DIR) with
49
Added:
| Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> Ok false
50
Added:
| Unix.Unix_error (error, _, _) -> Error (filesystem_error path error)
38
51
39
Removed:
let repository_layout path =
52
Added:
let file_exists_result path =
53
Added:
try
54
Added:
ignore (Unix.stat path);
55
Added:
Ok true
56
Added:
with
57
Added:
| Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> Ok false
58
Added:
| Unix.Unix_error (error, _, _) -> Error (filesystem_error path error)
59
Added:
60
Added:
let is_git_directory_result path =
61
Added:
let ( let* ) = Result.bind in
62
Added:
let* directory = is_directory_result path in
63
Added:
if not directory then Ok false
64
Added:
else
65
Added:
let* has_head = file_exists_result (Filename.concat path "HEAD") in
66
Added:
let* has_objects = is_directory_result (Filename.concat path "objects") in
67
Added:
Ok (has_head && has_objects)
68
Added:
69
Added:
let repository_layout_result path =
70
Added:
let ( let* ) = Result.bind in
40
71
let dotgit = Filename.concat path ".git" in
41
Removed:
if is_git_directory path then Some { worktree = path; git_dir = path }
42
Removed:
else if is_directory path && is_git_directory dotgit then
43
Removed:
Some { worktree = path; git_dir = dotgit }
44
Removed:
else None
72
Added:
let* bare = is_git_directory_result path in
73
Added:
if bare then Ok (Some { worktree = path; git_dir = path })
74
Added:
else
75
Added:
let* worktree = is_directory_result path in
76
Added:
if not worktree then Ok None
77
Added:
else
78
Added:
let* non_bare = is_git_directory_result dotgit in
79
Added:
if non_bare then Ok (Some { worktree = path; git_dir = dotgit })
80
Added:
else Ok None
45
81
82
Added:
let repository_layout path =
83
Added:
match repository_layout_result path with
84
Added:
| Ok layout -> layout
85
Added:
| Error _ -> None
86
Added:
46
87
let is_repository path = Option.is_some (repository_layout path)
47
88
48
Removed:
let store repo =
49
Removed:
let* repo = validate_repo_name repo in
50
Removed:
match repository_layout (full_path repo) with
51
Removed:
| Some { worktree; git_dir } ->
52
Removed:
Store.v ~dotgit:(Fpath.v git_dir) (Fpath.v worktree)
53
Removed:
| None -> Lwt_result.fail (`Msg ("not a Git repository " ^ repo))
89
Added:
let repositories config =
90
Added:
try
91
Added:
let names = Sys.readdir config.Config.git_project_root |> Array.to_list in
92
Added:
let ( let* ) = Result.bind in
93
Added:
let rec collect repositories = function
94
Added:
| [] -> Ok (List.sort String.compare repositories)
95
Added:
| name :: rest when String.starts_with ~prefix:"." name ->
96
Added:
collect repositories rest
97
Added:
| name :: rest ->
98
Added:
let path = Filename.concat config.Config.git_project_root name in
99
Added:
let* layout = repository_layout_result path in
100
Added:
collect
101
Added:
(if Option.is_some layout then name :: repositories
102
Added:
else repositories)
103
Added:
rest
104
Added:
in
105
Added:
collect [] names
106
Added:
with Sys_error message -> Error (Internal message)
54
107
55
108
let default_repo_description = "Unnamed repository"
56
109
@@ -64,33 +117,58 @@
64
117
| description -> description
65
118
with Sys_error _ -> default_repo_description
66
119
67
Removed:
let repo_description repo =
68
Removed:
if is_valid_repo_name repo then
69
Removed:
match repository_layout (full_path repo) with
70
Removed:
| Some { git_dir; _ } ->
71
Removed:
let description_path = Filename.concat git_dir "description" in
72
Removed:
read_description_file description_path
73
Removed:
| None -> default_repo_description
74
Removed:
else default_repo_description
120
Added:
let description_of_layout { git_dir; _ } =
121
Added:
Filename.concat git_dir "description" |> read_description_file
75
122
76
Removed:
let short_hash hash = String.sub hash 0 8
123
Added:
type repository = {
124
Added:
name : string;
125
Added:
store : Store.t;
126
Added:
description : string;
127
Added:
default_branch : string;
128
Added:
}
129
Added:
130
Added:
let open_repository config name =
131
Added:
let* name = validate_repo_name name in
132
Added:
let path = Filename.concat config.Config.git_project_root name in
133
Added:
match repository_layout_result path with
134
Added:
| Error error -> Lwt_result.fail error
135
Added:
| Ok None -> Lwt_result.fail (Not_found ("not a Git repository " ^ name))
136
Added:
| Ok (Some ({ worktree; git_dir } as layout)) ->
137
Added:
let* store =
138
Added:
map_store (Store.v ~dotgit:(Fpath.v git_dir) (Fpath.v worktree))
139
Added:
in
140
Added:
Lwt_result.return
141
Added:
{
142
Added:
name;
143
Added:
store;
144
Added:
description = description_of_layout layout;
145
Added:
default_branch = config.Config.default_branch;
146
Added:
}
147
Added:
148
Added:
let repository_name repository = repository.name
149
Added:
let repository_description repository = repository.description
150
Added:
let close_repository repository = Store.close_pack_files repository.store
151
Added:
let short_hash hash = String.sub hash 0 (min 8 (String.length hash))
77
152
let branch_ref name = Git.Reference.v ("refs/heads/" ^ name)
78
153
79
Removed:
let fallback_branch_candidates () =
80
Removed:
let add acc name = if List.mem name acc then acc else acc @ [ name ] in
81
Removed:
let candidates = [] in
82
Removed:
let candidates = add candidates config.default_branch in
83
Removed:
let candidates = add candidates "main" in
84
Removed:
add candidates "master"
154
Added:
let fallback_branch_candidates_for default_branch =
155
Added:
List.fold_left
156
Added:
(fun candidates name ->
157
Added:
if List.mem name candidates then candidates else candidates @ [ name ])
158
Added:
[]
159
Added:
[ default_branch; "main"; "master" ]
85
160
86
Removed:
let resolve_head_hash store =
87
Removed:
let fail_store_error err =
88
Removed:
Lwt_result.fail (`Msg (Fmt.str "%a" Store.pp_error err))
161
Added:
let fallback_branch_candidates config =
162
Added:
fallback_branch_candidates_for config.Config.default_branch
163
Added:
164
Added:
let resolve_head_hash repository =
165
Added:
let resolve reference =
166
Added:
map_store (Store.Ref.resolve repository.store reference)
89
167
in
90
168
let rec try_references = function
91
169
| [] ->
92
170
let open Lwt.Syntax in
93
Removed:
let* references = Store.Ref.list store in
171
Added:
let* references = Store.Ref.list repository.store in
94
172
let branches =
95
173
references |> List.map fst
96
174
|> List.filter_map (fun reference ->
@@ -98,31 +176,41 @@
98
176
if String.starts_with ~prefix:"refs/heads/" name then
99
177
Some (name, reference)
100
178
else None)
101
Removed:
|> List.sort (fun (a, _) (b, _) -> String.compare a b)
179
Added:
|> List.sort (fun (left, _) (right, _) -> String.compare left right)
102
180
in
103
181
let rec try_branches = function
104
182
| [] ->
105
183
Lwt_result.fail
106
Removed:
(`Msg "no branch could be resolved for repository")
184
Added:
(Not_found "no branch could be resolved for repository")
107
185
| (_, reference) :: rest -> (
108
Removed:
Lwt.bind (Store.Ref.resolve store reference) @@ function
186
Added:
Lwt.bind (resolve reference) @@ function
109
187
| Ok hash -> Lwt_result.return hash
110
Removed:
| Error (`Reference_not_found _) -> try_branches rest
111
Removed:
| Error err -> fail_store_error err)
188
Added:
| Error (Store_error (`Reference_not_found _)) ->
189
Added:
try_branches rest
190
Added:
| Error error -> Lwt_result.fail error)
112
191
in
113
192
try_branches branches
114
193
| reference :: rest -> (
115
Removed:
Lwt.bind (Store.Ref.resolve store reference) @@ function
194
Added:
Lwt.bind (resolve reference) @@ function
116
195
| Ok hash -> Lwt_result.return hash
117
Removed:
| Error (`Reference_not_found _) -> try_references rest
118
Removed:
| Error err -> fail_store_error err)
196
Added:
| Error (Store_error (`Reference_not_found _)) -> try_references rest
197
Added:
| Error error -> Lwt_result.fail error)
119
198
in
120
Removed:
Lwt.bind (Store.Ref.resolve store Git.Reference.head) @@ function
199
Added:
Lwt.bind (resolve Git.Reference.head) @@ function
121
200
| Ok hash -> Lwt_result.return hash
122
Removed:
| Error (`Reference_not_found _) ->
123
Removed:
try_references (List.map branch_ref (fallback_branch_candidates ()))
124
Removed:
| Error err -> fail_store_error err
201
Added:
| Error (Store_error (`Reference_not_found _)) ->
202
Added:
fallback_branch_candidates_for repository.default_branch
203
Added:
|> List.map branch_ref |> try_references
204
Added:
| Error error -> Lwt_result.fail error
125
205
206
Added:
let read_value repository hash =
207
Added:
Lwt.bind (Store.read repository.store hash) @@ function
208
Added:
| Error (`Not_found _) ->
209
Added:
Lwt_result.fail
210
Added:
(Not_found ("no object matches id " ^ Store.Hash.to_hex hash))
211
Added:
| Error error -> Lwt_result.fail (Store_error error)
212
Added:
| Ok value -> Lwt_result.return value
213
Added:
126
214
module Commit = struct
127
215
type user = Git.User.t
128
216
@@ -134,43 +222,46 @@
134
222
message : string option;
135
223
}
136
224
137
Removed:
let to_t c =
225
Added:
let to_t commit =
138
226
Store.
139
227
{
140
Removed:
hash = Value.Commit.digest c |> Hash.to_hex;
141
Removed:
tree = Value.Commit.tree c |> Hash.to_hex;
142
Removed:
parents = Value.Commit.parents c |> List.map Hash.to_hex;
143
Removed:
author = Value.Commit.author c;
144
Removed:
message = Value.Commit.message c;
228
Added:
hash = Value.Commit.digest commit |> Hash.to_hex;
229
Added:
tree = Value.Commit.tree commit |> Hash.to_hex;
230
Added:
parents = Value.Commit.parents commit |> List.map Hash.to_hex;
231
Added:
author = Value.Commit.author commit;
232
Added:
message = Value.Commit.message commit;
145
233
}
146
234
147
Removed:
let of_id repo id =
148
Removed:
let* store = store repo in
149
Removed:
let* hash = hash_of_hex id in
150
Removed:
Lwt_result.bind (Store.read store hash) @@ function
235
Added:
let of_hash repository hash =
236
Added:
Lwt_result.bind (read_value repository hash) @@ function
151
237
| Git.Value.Commit commit -> Lwt_result.return (to_t commit)
152
Removed:
| _ -> Lwt_result.fail @@ `Msg ("no commit matches id " ^ id)
238
Added:
| _ ->
239
Added:
Store.Hash.to_hex hash |> Printf.sprintf "no commit matches id %s"
240
Added:
|> fun message -> Lwt_result.fail (Not_found message)
153
241
154
Removed:
let head repo =
155
Removed:
let* store = store repo in
156
Removed:
let* hash = resolve_head_hash store in
157
Removed:
let id = hash |> Store.Hash.to_hex in
158
Removed:
of_id repo id
242
Added:
let of_id repository id =
243
Added:
let* hash = hash_of_hex id in
244
Added:
of_hash repository hash
159
245
160
Removed:
let recent_from repo hash n =
161
Removed:
let rec walk acc hash count =
162
Removed:
if count = 0 then Lwt_result.return (List.rev acc)
246
Added:
let head repository =
247
Added:
let* hash = resolve_head_hash repository in
248
Added:
of_hash repository hash
249
Added:
250
Added:
let recent_from repository hash count =
251
Added:
let rec walk commits hash remaining =
252
Added:
if remaining <= 0 then Lwt_result.return (List.rev commits)
163
253
else
164
Removed:
let* commit = of_id repo hash in
254
Added:
let* commit = of_id repository hash in
165
255
match commit.parents with
166
Removed:
| parent_hash :: _ -> walk (commit :: acc) parent_hash (count - 1)
167
Removed:
| [] -> Lwt_result.return (List.rev (commit :: acc))
256
Added:
| parent_hash :: _ ->
257
Added:
walk (commit :: commits) parent_hash (remaining - 1)
258
Added:
| [] -> Lwt_result.return (List.rev (commit :: commits))
168
259
in
169
Removed:
walk [] hash n
260
Added:
walk [] hash count
170
261
171
Removed:
let recent repo n =
172
Removed:
let* head_commit = head repo in
173
Removed:
recent_from repo head_commit.hash n
262
Added:
let recent repository count =
263
Added:
let* head_hash = resolve_head_hash repository in
264
Added:
recent_from repository (Store.Hash.to_hex head_hash) count
174
265
end
175
266
176
267
module Reference = struct
@@ -187,38 +278,25 @@
187
278
let tag_name name = drop_prefix ~prefix:"refs/tags/" name
188
279
let to_t_with_name name (_, hash) = { name; hash = Store.Hash.to_hex hash }
189
280
190
Removed:
let branches repo =
191
Removed:
let* store = store repo in
281
Added:
let refs_by_prefix repository name_of_reference =
192
282
let open Lwt.Syntax in
193
Removed:
let* references = Store.Ref.list store in
194
Removed:
let branches =
195
Removed:
references
196
Removed:
|> List.filter_map (fun ((reference, _) as raw) ->
197
Removed:
Git.Reference.to_string reference
198
Removed:
|> branch_name
199
Removed:
|> Option.map (fun name -> to_t_with_name name raw))
200
Removed:
in
201
Removed:
Lwt_result.return branches
283
Added:
let* references = Store.Ref.list repository.store in
284
Added:
references
285
Added:
|> List.filter_map (fun ((reference, _) as raw) ->
286
Added:
Git.Reference.to_string reference
287
Added:
|> name_of_reference
288
Added:
|> Option.map (fun name -> to_t_with_name name raw))
289
Added:
|> List.sort (fun left right -> String.compare left.name right.name)
290
Added:
|> Lwt_result.return
202
291
203
Removed:
let tags repo =
204
Removed:
let* store = store repo in
205
Removed:
let open Lwt.Syntax in
206
Removed:
let* references = Store.Ref.list store in
207
Removed:
let tags =
208
Removed:
references
209
Removed:
|> List.filter_map (fun ((reference, _) as raw) ->
210
Removed:
Git.Reference.to_string reference
211
Removed:
|> tag_name
212
Removed:
|> Option.map (fun name -> to_t_with_name name raw))
213
Removed:
in
214
Removed:
Lwt_result.return tags
292
Added:
let branches repository = refs_by_prefix repository branch_name
293
Added:
let tags repository = refs_by_prefix repository tag_name
215
294
216
Removed:
let of_id repo id =
217
Removed:
let* branches = branches repo in
218
Removed:
let branch = branches |> List.find_opt (fun branch -> branch.name = id) in
219
Removed:
match branch with
295
Added:
let of_id repository id =
296
Added:
let* branches = branches repository in
297
Added:
match List.find_opt (fun branch -> branch.name = id) branches with
220
298
| Some branch -> Lwt_result.return branch
221
Removed:
| None -> Lwt_result.fail @@ `Msg ("no reference matches id " ^ id)
299
Added:
| None -> Lwt_result.fail (Not_found ("no reference matches id " ^ id))
222
300
end
223
301
224
302
let mode_of_perm : Git.Tree.perm -> int = function
@@ -241,10 +319,11 @@
241
319
| `Normal | `Everybody -> File
242
320
243
321
let to_t (entry : Store.Value.Tree.entry) =
244
Removed:
let hash = Store.Hash.to_hex entry.node in
245
Removed:
let name = entry.name in
246
Removed:
let perm = perm_of_git entry.perm in
247
Removed:
{ hash; name; perm }
322
Added:
{
323
Added:
hash = Store.Hash.to_hex entry.node;
324
Added:
name = entry.name;
325
Added:
perm = perm_of_git entry.perm;
326
Added:
}
248
327
249
328
let is_readme { name; _ } =
250
329
String.(lowercase_ascii name |> starts_with ~prefix:"readme")
@@ -254,63 +333,56 @@
254
333
type t = { entries : Entry.t list }
255
334
256
335
let to_t tree =
257
Removed:
let entries = Store.Value.Tree.to_list tree |> List.map Entry.to_t in
258
Removed:
{ entries }
336
Added:
{ entries = Store.Value.Tree.to_list tree |> List.map Entry.to_t }
259
337
260
Removed:
let of_id repo id =
261
Removed:
let* store = store repo in
262
Removed:
let* hash = hash_of_hex id in
263
Removed:
Lwt_result.bind (Store.read store hash) @@ function
338
Added:
let of_hash repository hash =
339
Added:
Lwt_result.bind (read_value repository hash) @@ function
264
340
| Git.Value.Tree tree -> Lwt_result.return (to_t tree)
265
Removed:
| _ -> Lwt_result.fail @@ `Msg ("no tree matches id " ^ id)
341
Added:
| _ ->
342
Added:
Store.Hash.to_hex hash |> Printf.sprintf "no tree matches id %s"
343
Added:
|> fun message -> Lwt_result.fail (Not_found message)
266
344
267
Removed:
let head repo =
268
Removed:
let* store = store repo in
269
Removed:
let* hash = resolve_head_hash store in
270
Removed:
Lwt_result.bind (Store.read store hash) @@ function
345
Added:
let head_tree_hash repository =
346
Added:
let* hash = resolve_head_hash repository in
347
Added:
Lwt_result.bind (read_value repository hash) @@ function
271
348
| Git.Value.Commit commit ->
272
Removed:
let tree_id = Store.Value.Commit.tree commit |> Store.Hash.to_hex in
273
Removed:
of_id repo tree_id
274
Removed:
| _ -> Lwt_result.fail @@ `Msg "HEAD reference does not point to a commit"
349
Added:
Lwt_result.return (Store.Value.Commit.tree commit)
350
Added:
| _ -> Lwt_result.fail (Internal "HEAD does not point to a commit")
275
351
276
Removed:
let find_path repo target_hash =
277
Removed:
let* store = store repo in
278
Removed:
let* head_hash = resolve_head_hash store in
279
Removed:
let head_tree_hash =
280
Removed:
Lwt_result.bind (Store.read store head_hash) @@ function
281
Removed:
| Git.Value.Commit commit ->
282
Removed:
Lwt_result.return (Store.Value.Commit.tree commit |> Store.Hash.to_hex)
283
Removed:
| _ -> Lwt_result.fail @@ `Msg "HEAD is not a commit"
284
Removed:
in
285
Removed:
let* root_hash = head_tree_hash in
286
Removed:
if root_hash = target_hash then Lwt_result.return []
352
Added:
let head repository =
353
Added:
let* hash = head_tree_hash repository in
354
Added:
of_hash repository hash
355
Added:
356
Added:
let find_path repository target_hash =
357
Added:
let* target = hash_of_hex target_hash in
358
Added:
let* root = head_tree_hash repository in
359
Added:
if Store.Hash.equal root target then Lwt_result.return []
287
360
else
288
361
let rec search trail tree_hash =
289
Removed:
let* hash = hash_of_hex tree_hash in
290
Removed:
Lwt_result.bind (Store.read store hash) @@ function
362
Added:
Lwt_result.bind (read_value repository tree_hash) @@ function
291
363
| Git.Value.Tree tree ->
292
Removed:
let entries = Store.Value.Tree.to_list tree in
293
364
let rec try_entries = function
294
365
| [] -> Lwt_result.return None
295
Removed:
| (entry : Store.Value.Tree.entry) :: rest -> (
296
Removed:
let entry_hash = Store.Hash.to_hex entry.node in
297
Removed:
let step = (entry.name, entry_hash) in
298
Removed:
if entry_hash = target_hash then
366
Added:
| (entry : Store.Value.Tree.entry) :: rest ->
367
Added:
let step = (entry.name, Store.Hash.to_hex entry.node) in
368
Added:
if Store.Hash.equal entry.node target then
299
369
Lwt_result.return (Some (List.rev (step :: trail)))
300
Removed:
else
301
Removed:
match entry.perm with
302
Removed:
| `Dir -> (
303
Removed:
let* found = search (step :: trail) entry_hash in
304
Removed:
match found with
305
Removed:
| Some _ as result -> Lwt_result.return result
306
Removed:
| None -> try_entries rest)
307
Removed:
| _ -> try_entries rest)
370
Added:
else if entry.perm = `Dir then
371
Added:
let* found = search (step :: trail) entry.node in
372
Added:
match found with
373
Added:
| Some _ -> Lwt_result.return found
374
Added:
| None -> try_entries rest
375
Added:
else try_entries rest
308
376
in
309
Removed:
try_entries entries
377
Added:
try_entries (Store.Value.Tree.to_list tree)
310
378
| _ -> Lwt_result.return None
311
379
in
312
Removed:
let* result = search [] root_hash in
313
Removed:
Lwt_result.return (match result with Some trail -> trail | None -> [])
380
Added:
let* result = search [] root in
381
Added:
match result with
382
Added:
| Some trail -> Lwt_result.return trail
383
Added:
| None ->
384
Added:
Lwt_result.fail
385
Added:
(Not_found ("object is not reachable from HEAD: " ^ target_hash))
314
386
end
315
387
316
388
module Blob = struct
@@ -325,9 +397,9 @@
325
397
326
398
type tree_file = { hash : string; perm : Git.Tree.perm }
327
399
328
Removed:
let rec flatten_tree store prefix tree_hash files =
400
Added:
let rec flatten_tree repository prefix tree_hash files =
329
401
let* hash = hash_of_hex tree_hash in
330
Removed:
Lwt_result.bind (Store.read store hash) @@ function
402
Added:
Lwt_result.bind (read_value repository hash) @@ function
331
403
| Git.Value.Tree tree ->
332
404
let rec add_entries files = function
333
405
| [] -> Lwt_result.return files
@@ -339,41 +411,39 @@
339
411
let hash = Store.Hash.to_hex entry.node in
340
412
let* files =
341
413
match entry.perm with
342
Removed:
| `Dir -> flatten_tree store path hash files
414
Added:
| `Dir -> flatten_tree repository path hash files
343
415
| (`Commit | `Everybody | `Exec | `Link | `Normal) as perm ->
344
416
Lwt_result.return (Path_map.add path { hash; perm } files)
345
417
in
346
418
add_entries files entries
347
419
in
348
420
add_entries files (Store.Value.Tree.to_list tree)
349
Removed:
| _ -> Lwt_result.fail (`Msg ("no tree matches id " ^ tree_hash))
421
Added:
| _ -> Lwt_result.fail (Not_found ("no tree matches id " ^ tree_hash))
350
422
351
Removed:
let read_file store = function
423
Added:
let read_file repository = function
352
424
| None -> Lwt_result.return ""
353
425
| Some { hash; perm = `Commit } ->
354
426
Lwt_result.return ("Subproject commit " ^ hash ^ "\n")
355
427
| Some { hash; _ } -> (
356
428
let* hash = hash_of_hex hash in
357
Removed:
Lwt_result.bind (Store.read store hash) @@ function
429
Added:
Lwt_result.bind (read_value repository hash) @@ function
358
430
| Git.Value.Blob blob ->
359
431
Lwt_result.return (Store.Value.Blob.to_string blob)
360
Removed:
| _ -> Lwt_result.fail (`Msg "file entry does not point to a blob"))
432
Added:
| _ -> Lwt_result.fail (Internal "file entry does not point to a blob"))
361
433
362
Removed:
let of_commit repo (commit : Commit.t) =
363
Removed:
let* store = store repo in
364
Removed:
let* new_files = flatten_tree store "" commit.tree Path_map.empty in
434
Added:
let of_commit repository (commit : Commit.t) =
435
Added:
let* new_files = flatten_tree repository "" commit.tree Path_map.empty in
365
436
let* old_files =
366
437
match commit.parents with
367
438
| [] -> Lwt_result.return Path_map.empty
368
439
| parent :: _ -> (
369
440
let* parent_hash = hash_of_hex parent in
370
Removed:
Lwt_result.bind (Store.read store parent_hash) @@ function
441
Added:
Lwt_result.bind (read_value repository parent_hash) @@ function
371
442
| Git.Value.Commit parent_commit ->
372
Removed:
let tree =
373
Removed:
Store.Value.Commit.tree parent_commit |> Store.Hash.to_hex
374
Removed:
in
375
Removed:
flatten_tree store "" tree Path_map.empty
376
Removed:
| _ -> Lwt_result.fail (`Msg ("parent is not a commit " ^ parent)))
443
Added:
Store.Value.Commit.tree parent_commit |> Store.Hash.to_hex
444
Added:
|> fun tree -> flatten_tree repository "" tree Path_map.empty
445
Added:
| _ -> Lwt_result.fail (Internal ("parent is not a commit " ^ parent))
446
Added:
)
377
447
in
378
448
let changed_files =
379
449
Path_map.merge
@@ -388,11 +458,11 @@
388
458
old_files new_files
389
459
|> Path_map.bindings
390
460
in
391
Removed:
let rec build acc = function
392
Removed:
| [] -> Lwt_result.return (List.rev acc)
393
Removed:
| (path, (old_file, new_file)) :: files ->
394
Removed:
let* old_content = read_file store old_file in
395
Removed:
let* new_content = read_file store new_file in
461
Added:
let rec build files = function
462
Added:
| [] -> Lwt_result.return (List.rev files)
463
Added:
| (path, (old_file, new_file)) :: rest ->
464
Added:
let* old_content = read_file repository old_file in
465
Added:
let* new_content = read_file repository new_file in
396
466
let binary =
397
467
String.contains old_content '\x00'
398
468
|| String.contains new_content '\x00'
@@ -412,28 +482,27 @@
412
482
else Diff.line_diff old_content new_content |> Diff.hunks);
413
483
}
414
484
in
415
Removed:
build (file :: acc) files
485
Added:
build (file :: files) rest
416
486
in
417
487
build [] changed_files
418
488
end
419
489
420
Removed:
let blob_or_tree repo id =
421
Removed:
let* store = store repo in
490
Added:
let blob_or_tree repository id =
422
491
let* hash = hash_of_hex id in
423
Removed:
Lwt_result.bind (Store.read store hash) @@ function
424
Removed:
| Git.Value.Tree tree -> Lwt_result.return @@ `Tree (Tree.to_t tree)
425
Removed:
| Git.Value.Blob blob -> Lwt_result.return @@ `Blob (Blob.to_t blob)
426
Removed:
| _ -> Lwt_result.fail @@ `Msg ("No tree or blob matches id " ^ id)
492
Added:
Lwt_result.bind (read_value repository hash) @@ function
493
Added:
| Git.Value.Tree tree -> Lwt_result.return (`Tree (Tree.to_t tree))
494
Added:
| Git.Value.Blob blob -> Lwt_result.return (`Blob (Blob.to_t blob))
495
Added:
| _ -> Lwt_result.fail (Not_found ("no tree or blob matches id " ^ id))
427
496
428
497
module Repo = struct
429
Removed:
let readme repo =
430
Removed:
let* tree = Tree.head repo in
498
Added:
let readme repository =
499
Added:
let* tree = Tree.head repository in
431
500
match List.find_opt Entry.is_readme tree.entries with
432
501
| None -> Lwt_result.return None
433
502
| Some readme -> (
434
Removed:
let* store = store repo in
435
503
let* hash = hash_of_hex readme.hash in
436
Removed:
Lwt_result.bind (Store.read store hash) @@ function
437
Removed:
| Git.Value.Blob blob -> Lwt_result.return @@ Some (Blob.to_t blob)
438
Removed:
| _ -> Lwt_result.fail @@ `Msg ("couldn't read file " ^ readme.name))
504
Added:
Lwt_result.bind (read_value repository hash) @@ function
505
Added:
| Git.Value.Blob blob -> Lwt_result.return (Some (Blob.to_t blob))
506
Added:
| _ -> Lwt_result.fail (Internal ("could not read file " ^ readme.name))
507
Added:
)
439
508
end
lib/resolvers.mli
@@ -4,25 +4,38 @@
4
4
5
5
module Store = Git_unix.Store
6
6
7
Added:
type error =
8
Added:
| Bad_request of string
9
Added:
| Not_found of string
10
Added:
| Store_error of Store.error
11
Added:
| Internal of string
12
Added:
13
Added:
val pp_error : Format.formatter -> error -> unit
14
Added:
7
15
(** {1 Validation} *)
8
16
9
17
val is_valid_hash_hex : string -> bool
10
18
val is_valid_repo_name : string -> bool
11
19
12
Removed:
(** {1 Repository discovery} *)
20
Added:
(** {1 Repository discovery and context} *)
13
21
14
22
type repository_layout = { worktree : string; git_dir : string }
23
Added:
type repository
15
24
16
25
val is_repository : string -> bool
17
26
val repository_layout : string -> repository_layout option
27
Added:
val repositories : Config.t -> (string list, error) result
28
Added:
val open_repository : Config.t -> string -> (repository, error) Lwt_result.t
29
Added:
val repository_name : repository -> string
30
Added:
val repository_description : repository -> string
31
Added:
val close_repository : repository -> unit Lwt.t
18
32
19
33
(** {1 Repository metadata} *)
20
34
21
35
val default_repo_description : string
22
36
val read_description_file : string -> string
23
Removed:
val repo_description : string -> string
24
37
val short_hash : string -> string
25
Removed:
val fallback_branch_candidates : unit -> string list
38
Added:
val fallback_branch_candidates : Config.t -> string list
26
39
27
40
(** {1 Commits} *)
28
41
@@ -37,13 +50,10 @@
37
50
message : string option;
38
51
}
39
52
40
Removed:
val of_id : string -> string -> (t, Store.error) Lwt_result.t
41
Removed:
val head : string -> (t, Store.error) Lwt_result.t
42
Removed:
43
Removed:
val recent_from :
44
Removed:
string -> string -> int -> (t list, Store.error) Lwt_result.t
45
Removed:
46
Removed:
val recent : string -> int -> (t list, Store.error) Lwt_result.t
53
Added:
val of_id : repository -> string -> (t, error) Lwt_result.t
54
Added:
val head : repository -> (t, error) Lwt_result.t
55
Added:
val recent_from : repository -> string -> int -> (t list, error) Lwt_result.t
56
Added:
val recent : repository -> int -> (t list, error) Lwt_result.t
47
57
end
48
58
49
59
(** {1 References} *)
@@ -53,9 +63,9 @@
53
63
54
64
val branch_name : string -> string option
55
65
val tag_name : string -> string option
56
Removed:
val branches : string -> (t list, Store.error) Lwt_result.t
57
Removed:
val tags : string -> (t list, Store.error) Lwt_result.t
58
Removed:
val of_id : string -> string -> (t, Store.error) Lwt_result.t
66
Added:
val branches : repository -> (t list, error) Lwt_result.t
67
Added:
val tags : repository -> (t list, error) Lwt_result.t
68
Added:
val of_id : repository -> string -> (t, error) Lwt_result.t
59
69
end
60
70
61
71
(** {1 Entries and Trees} *)
@@ -70,10 +80,10 @@
70
80
module Tree : sig
71
81
type t = { entries : Entry.t list }
72
82
73
Removed:
val head : string -> (t, Store.error) Lwt_result.t
83
Added:
val head : repository -> (t, error) Lwt_result.t
74
84
75
85
val find_path :
76
Removed:
string -> string -> ((string * string) list, Store.error) Lwt_result.t
86
Added:
repository -> string -> ((string * string) list, error) Lwt_result.t
77
87
end
78
88
79
89
(** {1 Blobs} *)
@@ -87,18 +97,18 @@
87
97
module Diff : sig
88
98
include module type of Diff
89
99
90
Removed:
val of_commit : string -> Commit.t -> (file list, Store.error) Lwt_result.t
100
Added:
val of_commit : repository -> Commit.t -> (file list, error) Lwt_result.t
91
101
end
92
102
93
103
(** {1 Composite lookups} *)
94
104
95
105
val blob_or_tree :
106
Added:
repository ->
96
107
string ->
97
Removed:
string ->
98
Removed:
([> `Blob of Blob.t | `Tree of Tree.t ], Store.error) Lwt_result.t
108
Added:
([> `Blob of Blob.t | `Tree of Tree.t ], error) Lwt_result.t
99
109
100
110
(** {1 Repository helpers} *)
101
111
102
112
module Repo : sig
103
Removed:
val readme : string -> (Blob.t option, Store.error) Lwt_result.t
113
Added:
val readme : repository -> (Blob.t option, error) Lwt_result.t
104
114
end
lib/routes.ml
@@ -13,6 +13,7 @@
13
13
| Readme of string
14
14
15
15
let%path root_path = "/"
16
Added:
let%path repo_root_path = "/%s/"
16
17
let%path repo_path = "/%s/summary/"
17
18
let%path commits_path = "/%s/commits/"
18
19
let%path commits_branch_path = "/%s/commits/%s"
@@ -22,6 +23,7 @@
22
23
let%path branches_path = "/%s/branches/"
23
24
let%path tags_path = "/%s/tags/"
24
25
let%path readme_path = "/%s/README"
26
Added:
let%path static_path = "/static/%*s"
25
27
26
28
let link_to route ?(other_attrs = []) contents =
27
29
let open Dream_html in
lib/static_handler.ml
@@ -9,16 +9,9 @@
9
9
| ".ico" -> "image/x-icon"
10
10
| _ -> "application/octet-stream"
11
11
12
Removed:
let handler req =
13
Removed:
let target = Dream.target req in
14
Removed:
let path =
15
Removed:
match String.split_on_char '/' target with
16
Removed:
| "" :: "static" :: rest -> String.concat "/" rest
17
Removed:
| _ -> ""
18
Removed:
in
12
Added:
let handler _request _captured_length path =
19
13
match Static_assets.read path with
20
14
| Some content ->
21
Removed:
let ext = Filename.extension path in
22
Removed:
let content_type = content_type_of_ext ext in
15
Added:
let content_type = Filename.extension path |> content_type_of_ext in
23
16
Dream.respond ~headers:[ ("Content-Type", content_type) ] content
24
17
| None -> Dream.respond ~status:`Not_Found "Not found"
lib/views.ml
@@ -6,6 +6,7 @@
6
6
let root = Root.render
7
7
8
8
module Repo = struct
9
Added:
let context = Repo.context
9
10
let summary = Repo.summary
10
11
let commits = Repo.commits
11
12
let files = Repo.files
lib/views/layout.ml
@@ -1,7 +1,6 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
3
open Dream_html
4
Removed:
open Config
5
4
6
5
type page = Summary | Commits | Files | Branches | Tags | Readme
7
6
@@ -26,9 +25,8 @@
26
25
List.map (page_to_nav_item repo)
27
26
[ Summary; Commits; Files; Branches; Tags; Readme ]
28
27
in
29
Removed:
let li_of_item (route, text, path) =
30
Removed:
let is_active = path = active in
31
Removed:
let attrs = if is_active then [ Aria.current `page ] else [] in
28
Added:
let li_of_item (route, text, page) =
29
Added:
let attrs = if page = active then [ Aria.current `page ] else [] in
32
30
HTML.li attrs [ Routes.link_to route (txt "%s" text) ]
33
31
in
34
32
HTML.(
@@ -74,11 +72,10 @@
74
72
if subtitle = "" then []
75
73
else [ p [ class_ "subtitle" ] [ txt "%s" subtitle ] ]))
76
74
77
Removed:
let page_footer () =
75
Added:
let page_footer user =
78
76
let now = Unix.(time () |> localtime) in
79
77
let year = string_of_int (now.tm_year + 1900) in
80
Removed:
let footer_text = Printf.sprintf "Copyright %s %s" year config.user in
81
Removed:
HTML.footer [] [ txt "%s" footer_text ]
78
Added:
HTML.footer [] [ txt "Copyright %s %s" year user ]
82
79
83
80
let head page_title =
84
81
let open HTML in
@@ -90,30 +87,34 @@
90
87
link [ rel "icon"; type_ "image/x-icon"; href "/static/git_icon.svg" ];
91
88
]
92
89
93
Removed:
let body bd =
90
Added:
let body ~user page_data =
94
91
let open HTML in
95
92
body []
96
93
[
97
94
a [ href "#main"; class_ "skip-link" ] [ txt "Skip to content" ];
98
Removed:
page_header ~has_repo:(Option.is_some bd.repo) bd.title bd.subtitle;
99
Removed:
(match bd.repo with
95
Added:
page_header
96
Added:
~has_repo:(Option.is_some page_data.repo)
97
Added:
page_data.title page_data.subtitle;
98
Added:
(match page_data.repo with
100
99
| None -> HTML.null []
101
Removed:
| Some repo -> topnav ~active:bd.active repo);
102
Removed:
div [ id "main" ] bd.content;
103
Removed:
page_footer ();
100
Added:
| Some repo -> topnav ~active:page_data.active repo);
101
Added:
div [ id "main" ] page_data.content;
102
Added:
page_footer user;
104
103
]
105
104
106
Removed:
let render ?(page_title = "Ogit") body_data =
107
Removed:
HTML.html [ HTML.lang "en" ] [ head page_title; body body_data ]
105
Added:
let render ?(page_title = "Ogit") ~user body_data =
106
Added:
HTML.html [ HTML.lang "en" ] [ head page_title; body ~user body_data ]
108
107
109
Removed:
let error_page message =
108
Added:
let error_page ?(title = "Request failed") ?(status = `Internal_Server_Error)
109
Added:
message =
110
Added:
let page_title = title in
110
111
let open HTML in
111
Removed:
respond
112
Added:
respond ~status
112
113
@@ html []
113
114
[
114
115
head []
115
116
[
116
Removed:
title [] "Fatal Error";
117
Added:
HTML.title [] "%s" page_title;
117
118
meta
118
119
[
119
120
name "viewport"; content "width=device-width, initial-scale=1";
@@ -122,7 +123,7 @@
122
123
];
123
124
body []
124
125
[
125
Removed:
h1 [] [ txt "Fatal Error" ];
126
Added:
h1 [] [ txt "%s" page_title ];
126
127
div
127
128
[ id "main" ]
128
129
[
lib/views/repo.ml
@@ -2,9 +2,23 @@
2
2
3
3
open Dream_html
4
4
5
Removed:
let page_title repo =
6
Removed:
Printf.sprintf "%s — %s" repo (Resolvers.repo_description repo)
5
Added:
type context = { repo : string; description : string; user : string }
6
Added:
type commit_message = { summary : string; body : string }
7
7
8
Added:
let context ~user ~repo ~description = { repo; description; user }
9
Added:
let page_title context = context.repo ^ " — " ^ context.description
10
Added:
11
Added:
let render_page ?heading context ~active content =
12
Added:
respond
13
Added:
@@ Layout.render ~user:context.user ~page_title:(page_title context)
14
Added:
{
15
Added:
repo = Some context.repo;
16
Added:
title = Option.value heading ~default:context.repo;
17
Added:
subtitle = context.description;
18
Added:
active;
19
Added:
content;
20
Added:
}
21
Added:
8
22
let li_of_branch repo (branch : Resolvers.Reference.t) =
9
23
HTML.(
10
24
li []
@@ -17,22 +31,14 @@
17
31
let li_of_tag repo (tag : Resolvers.Reference.t) =
18
32
HTML.(li [] [ Routes.link_to (Tags repo) (txt "%s" tag.name) ])
19
33
20
Removed:
let commit_summary message =
21
Removed:
match message with
22
Removed:
| None -> ""
23
Removed:
| Some msg -> (
24
Removed:
match String.split_on_char '\n' msg with [] -> "" | first :: _ -> first)
34
Added:
let parse_commit_message = function
35
Added:
| None -> { summary = ""; body = "" }
36
Added:
| Some message -> (
37
Added:
match String.split_on_char '\n' message with
38
Added:
| [] -> { summary = ""; body = "" }
39
Added:
| summary :: rest ->
40
Added:
{ summary; body = String.concat "\n" rest |> String.trim })
25
41
26
Removed:
let commit_body message =
27
Removed:
match message with
28
Removed:
| None -> ""
29
Removed:
| Some msg -> (
30
Removed:
match String.split_on_char '\n' msg with
31
Removed:
| [] | [ _ ] -> ""
32
Removed:
| _ :: rest ->
33
Removed:
let body = String.concat "\n" rest |> String.trim in
34
Removed:
body)
35
Removed:
36
42
let conventional_commit_types =
37
43
[
38
44
"feat";
@@ -68,43 +74,34 @@
68
74
(Some type_lower, rest)
69
75
else (None, summary)
70
76
71
Removed:
let li_of_commit repo (commit : Resolvers.Commit.t) =
72
Removed:
let timestamp (date, _) =
73
Removed:
let tm = date |> Int64.to_float |> Unix.localtime in
74
Removed:
Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.tm_year + 1900)
75
Removed:
(tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min
77
Added:
let timestamp (date, _) =
78
Added:
let tm = date |> Int64.to_float |> Unix.localtime in
79
Added:
Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.tm_year + 1900) (tm.tm_mon + 1)
80
Added:
tm.tm_mday tm.tm_hour tm.tm_min
81
Added:
82
Added:
let relative_time (date, _) =
83
Added:
let seconds = Unix.time () -. Int64.to_float date |> int_of_float in
84
Added:
let quantity value singular =
85
Added:
Printf.sprintf "%d %s%s ago" value singular (if value = 1 then "" else "s")
76
86
in
77
Removed:
let time_ago (date, _) =
78
Removed:
let commit_time = Int64.to_float date in
79
Removed:
let now = Unix.time () in
80
Removed:
let diff = now -. commit_time in
81
Removed:
let seconds = int_of_float diff in
82
Removed:
if seconds < 60 then "just now"
87
Added:
if seconds < 60 then "just now"
88
Added:
else
89
Added:
let minutes = seconds / 60 in
90
Added:
if minutes < 60 then quantity minutes "minute"
83
91
else
84
Removed:
let minutes = seconds / 60 in
85
Removed:
if minutes < 60 then
86
Removed:
Printf.sprintf "%d minute%s ago" minutes
87
Removed:
(if minutes = 1 then "" else "s")
92
Added:
let hours = minutes / 60 in
93
Added:
if hours < 24 then quantity hours "hour"
88
94
else
89
Removed:
let hours = minutes / 60 in
90
Removed:
if hours < 24 then
91
Removed:
Printf.sprintf "%d hour%s ago" hours (if hours = 1 then "" else "s")
95
Added:
let days = hours / 24 in
96
Added:
if days < 30 then quantity days "day"
92
97
else
93
Removed:
let days = hours / 24 in
94
Removed:
if days < 30 then
95
Removed:
Printf.sprintf "%d day%s ago" days (if days = 1 then "" else "s")
96
Removed:
else
97
Removed:
let months = days / 30 in
98
Removed:
if months < 12 then
99
Removed:
Printf.sprintf "%d month%s ago" months
100
Removed:
(if months = 1 then "" else "s")
101
Removed:
else
102
Removed:
let years = months / 12 in
103
Removed:
Printf.sprintf "%d year%s ago" years
104
Removed:
(if years = 1 then "" else "s")
105
Removed:
in
106
Removed:
let summary = commit_summary commit.message in
107
Removed:
let commit_type, commit_title = parse_conventional summary in
98
Added:
let months = days / 30 in
99
Added:
if months < 12 then quantity months "month"
100
Added:
else quantity (months / 12) "year"
101
Added:
102
Added:
let li_of_commit repo (commit : Resolvers.Commit.t) =
103
Added:
let message = parse_commit_message commit.message in
104
Added:
let commit_type, commit_title = parse_conventional message.summary in
108
105
let timestamp_span =
109
106
HTML.(
110
107
span [ class_ "timestamp" ] [ txt "%s" (timestamp commit.author.date) ])
@@ -112,17 +109,21 @@
112
109
let pill =
113
110
match commit_type with
114
111
| None -> HTML.null []
115
Removed:
| Some t ->
116
Removed:
HTML.(span [ class_ "commit-pill commit-pill-%s" t ] [ txt "%s" t ])
112
Added:
| Some commit_type ->
113
Added:
HTML.(
114
Added:
span
115
Added:
[ class_ "commit-pill commit-pill-%s" commit_type ]
116
Added:
[ txt "%s" commit_type ])
117
117
in
118
118
let title_span =
119
119
HTML.(span [ class_ "commit-title" ] [ txt "%s" commit_title ])
120
120
in
121
121
let ago_span =
122
122
HTML.(
123
Removed:
span [ class_ "commit-ago" ] [ txt "%s" (time_ago commit.author.date) ])
123
Added:
span
124
Added:
[ class_ "commit-ago" ]
125
Added:
[ txt "%s" (relative_time commit.author.date) ])
124
126
in
125
Removed:
let route = Routes.Commit (repo, commit.hash) in
126
127
let node =
127
128
HTML.(
128
129
null
@@ -131,7 +132,7 @@
131
132
ago_span;
132
133
])
133
134
in
134
Removed:
HTML.li [] [ Routes.link_to route node ]
135
Added:
HTML.li [] [ Routes.link_to (Routes.Commit (repo, commit.hash)) node ]
135
136
136
137
let li_of_entry repo (entry : Resolvers.Entry.t) =
137
138
let route = Routes.File (repo, entry.hash) in
@@ -140,34 +141,19 @@
140
141
in
141
142
HTML.(li [] [ Routes.link_to route text ])
142
143
143
Removed:
let summary repo branches commits =
144
Removed:
respond
145
Removed:
@@ Layout.render ~page_title:(page_title repo)
146
Removed:
{
147
Removed:
repo = Some repo;
148
Removed:
title = repo;
149
Removed:
subtitle = Resolvers.repo_description repo;
150
Removed:
active = Summary;
151
Removed:
content =
152
Removed:
HTML.
153
Removed:
[
154
Removed:
h3 [] [ txt "Branches" ];
155
Removed:
ul [] (List.map (li_of_branch repo) branches);
156
Removed:
h3 [] [ txt "Latest commits" ];
157
Removed:
ul [] (List.map (li_of_commit repo) commits);
158
Removed:
];
159
Removed:
}
144
Added:
let summary context branches commits =
145
Added:
render_page context ~active:Summary
146
Added:
HTML.
147
Added:
[
148
Added:
h3 [] [ txt "Branches" ];
149
Added:
ul [] (List.map (li_of_branch context.repo) branches);
150
Added:
h3 [] [ txt "Latest commits" ];
151
Added:
ul [] (List.map (li_of_commit context.repo) commits);
152
Added:
]
160
153
161
Removed:
let commits repo commits =
162
Removed:
respond
163
Removed:
@@ Layout.render ~page_title:(page_title repo)
164
Removed:
{
165
Removed:
repo = Some repo;
166
Removed:
title = repo;
167
Removed:
subtitle = Resolvers.repo_description repo;
168
Removed:
active = Commits;
169
Removed:
content = HTML.[ ul [] @@ List.map (li_of_commit repo) commits ];
170
Removed:
}
154
Added:
let commits context commits =
155
Added:
render_page context ~active:Commits
156
Added:
HTML.[ ul [] (List.map (li_of_commit context.repo) commits) ]
171
157
172
158
let breadcrumbs repo (trail : (string * string) list) =
173
159
let root_link = HTML.li [] [ Routes.link_to (Files repo) (txt "Home") ] in
@@ -182,59 +168,42 @@
182
168
[ class_ "breadcrumbs"; Aria.label "File path" ]
183
169
[ ul [] (root_link :: crumbs) ])
184
170
185
Removed:
let files repo trail (tree : Resolvers.Tree.t) =
186
Removed:
respond
187
Removed:
@@ Layout.render ~page_title:(page_title repo)
188
Removed:
{
189
Removed:
repo = Some repo;
190
Removed:
title = repo;
191
Removed:
subtitle = Resolvers.repo_description repo;
192
Removed:
active = Files;
193
Removed:
content =
194
Removed:
HTML.
195
Removed:
[
196
Removed:
breadcrumbs repo trail;
197
Removed:
ul [] @@ List.map (li_of_entry repo) tree.entries;
198
Removed:
];
199
Removed:
}
171
Added:
let files context trail (tree : Resolvers.Tree.t) =
172
Added:
render_page context ~active:Files
173
Added:
HTML.
174
Added:
[
175
Added:
breadcrumbs context.repo trail;
176
Added:
ul [] (List.map (li_of_entry context.repo) tree.entries);
177
Added:
]
200
178
201
Removed:
let file repo trail (blob : Resolvers.Blob.t) =
179
Added:
let file ?(active = Layout.Files) context trail (blob : Resolvers.Blob.t) =
202
180
let to_numbered_line number line =
203
Removed:
let n = number + 1 in
181
Added:
let line_number = number + 1 in
204
182
HTML.
205
183
[
206
184
a
207
185
[
208
Removed:
id "%d" n;
186
Added:
id "%d" line_number;
209
187
class_ "line-anchor";
210
Removed:
href "#%d" n;
211
Removed:
Aria.label "Line %d" n;
188
Added:
href "#%d" line_number;
189
Added:
Aria.label "Line %d" line_number;
212
190
]
213
Removed:
[ txt "%d" n ];
191
Added:
[ txt "%d" line_number ];
214
192
span [ class_ "line" ] [ txt "\t%s\n" line ];
215
193
]
216
194
in
217
195
let formatted_blob =
218
196
String.split_on_char '\n' blob.content
219
Removed:
|> List.mapi to_numbered_line |> List.flatten
197
Added:
|> List.mapi to_numbered_line |> List.concat
220
198
in
221
Removed:
respond
222
Removed:
@@ Layout.render ~page_title:(page_title repo)
223
Removed:
{
224
Removed:
repo = Some repo;
225
Removed:
title = repo;
226
Removed:
subtitle = Resolvers.repo_description repo;
227
Removed:
active = Files;
228
Removed:
content =
229
Removed:
HTML.[ breadcrumbs repo trail; div [ id "blob" ] formatted_blob ];
230
Removed:
}
199
Added:
render_page context ~active
200
Added:
HTML.[ breadcrumbs context.repo trail; div [ id "blob" ] formatted_blob ]
231
201
232
Removed:
let commit repo (commit : Resolvers.Commit.t) diff =
233
Removed:
let commit_summary_text = commit_summary commit.message in
234
Removed:
let commit_body_text = commit_body commit.message in
202
Added:
let commit context (commit : Resolvers.Commit.t) diff =
203
Added:
let message = parse_commit_message commit.message in
235
204
let number = function Some number -> string_of_int number | None -> "" in
236
205
let line (line : Resolvers.Diff.line) =
237
Removed:
let class_name, marker, sr_label =
206
Added:
let class_name, marker, screen_reader_label =
238
207
match line.kind with
239
208
| Resolvers.Diff.Context -> ("context", " ", "")
240
209
| Resolvers.Diff.Addition -> ("addition", "+", "Added: ")
@@ -247,7 +216,7 @@
247
216
span [ class_ "line-number" ] [ txt "%s" (number line.old_number) ];
248
217
span [ class_ "line-number" ] [ txt "%s" (number line.new_number) ];
249
218
span [ class_ "diff-marker"; Aria.hidden true ] [ txt "%s" marker ];
250
Removed:
span [ class_ "sr-only" ] [ txt "%s" sr_label ];
219
Added:
span [ class_ "sr-only" ] [ txt "%s" screen_reader_label ];
251
220
span [ class_ "diff-text" ] [ txt "%s" line.text ];
252
221
])
253
222
in
@@ -280,78 +249,53 @@
280
249
HTML.(
281
250
section
282
251
[ class_ "diff-file" ]
283
Removed:
([
284
Removed:
h4 [ class_ "diff-file-header" ] [ txt "%s" file.path ];
285
Removed:
div
252
Added:
(h4 [ class_ "diff-file-header" ] [ txt "%s" file.path ]
253
Added:
:: div
286
254
[ class_ "diff-meta" ]
287
255
[
288
256
txt "index %s..%s %s..%s" (hash file.old_hash)
289
257
(hash file.new_hash) (mode file.old_mode) (mode file.new_mode);
290
Removed:
];
291
Removed:
]
292
Removed:
@ file_body))
258
Added:
]
259
Added:
:: file_body))
293
260
in
294
261
let diff_content =
295
262
match diff with
296
263
| [] -> HTML.[ p [] [ txt "No file changes in this commit." ] ]
297
264
| files -> List.map file files
298
265
in
299
Removed:
respond
300
Removed:
@@ Layout.render ~page_title:(page_title repo)
301
Removed:
{
302
Removed:
repo = Some repo;
303
Removed:
title =
304
Removed:
Printf.sprintf "%s : %s" repo @@ Resolvers.short_hash commit.hash;
305
Removed:
subtitle = Resolvers.repo_description repo;
306
Removed:
active = Summary;
307
Removed:
content =
308
Removed:
HTML.(
309
Removed:
[ h3 [] [ txt "%s" commit_summary_text ] ]
310
Removed:
@ (if commit_body_text = "" then []
311
Removed:
else
312
Removed:
[ p [ class_ "commit-body" ] [ txt "%s" commit_body_text ] ])
313
Removed:
@ [
314
Removed:
dl
315
Removed:
[ class_ "commit-meta" ]
316
Removed:
[
317
Removed:
dt [] [ txt "Commit" ];
318
Removed:
dd [] [ txt "%s" commit.hash ];
319
Removed:
dt [] [ txt "Author" ];
320
Removed:
dd []
321
Removed:
[ txt "%s <%s>" commit.author.name commit.author.email ];
322
Removed:
];
323
Removed:
]
324
Removed:
@ diff_content);
325
Removed:
}
266
Added:
let content =
267
Added:
HTML.(
268
Added:
[ h3 [] [ txt "%s" message.summary ] ]
269
Added:
@ (if message.body = "" then []
270
Added:
else [ p [ class_ "commit-body" ] [ txt "%s" message.body ] ])
271
Added:
@ [
272
Added:
dl
273
Added:
[ class_ "commit-meta" ]
274
Added:
[
275
Added:
dt [] [ txt "Commit" ];
276
Added:
dd [] [ txt "%s" commit.hash ];
277
Added:
dt [] [ txt "Author" ];
278
Added:
dd [] [ txt "%s <%s>" commit.author.name commit.author.email ];
279
Added:
];
280
Added:
]
281
Added:
@ diff_content)
282
Added:
in
283
Added:
render_page
284
Added:
~heading:(context.repo ^ " : " ^ Resolvers.short_hash commit.hash)
285
Added:
context ~active:Summary content
326
286
327
Removed:
let branches repo branches =
287
Added:
let branches context branches =
328
288
let content =
329
289
match branches with
330
Removed:
| [] -> HTML.[ p [] [ txt "No branches for repo %s" repo ] ]
331
Removed:
| branches -> HTML.[ ul [] @@ List.map (li_of_branch repo) branches ]
290
Added:
| [] -> HTML.[ p [] [ txt "No branches for repo %s" context.repo ] ]
291
Added:
| branches -> HTML.[ ul [] (List.map (li_of_branch context.repo) branches) ]
332
292
in
333
Removed:
respond
334
Removed:
@@ Layout.render ~page_title:(page_title repo)
335
Removed:
{
336
Removed:
repo = Some repo;
337
Removed:
title = repo;
338
Removed:
subtitle = Resolvers.repo_description repo;
339
Removed:
active = Branches;
340
Removed:
content;
341
Removed:
}
293
Added:
render_page context ~active:Branches content
342
294
343
Removed:
let tags repo tags =
295
Added:
let tags context tags =
344
296
let content =
345
297
match tags with
346
Removed:
| [] -> HTML.[ p [] [ txt "No tags for repo %s" repo ] ]
347
Removed:
| tags -> HTML.[ ul [] @@ List.map (li_of_tag repo) tags ]
298
Added:
| [] -> HTML.[ p [] [ txt "No tags for repo %s" context.repo ] ]
299
Added:
| tags -> HTML.[ ul [] (List.map (li_of_tag context.repo) tags) ]
348
300
in
349
Removed:
respond
350
Removed:
@@ Layout.render ~page_title:(page_title repo)
351
Removed:
{
352
Removed:
repo = Some repo;
353
Removed:
title = repo;
354
Removed:
subtitle = Resolvers.repo_description repo;
355
Removed:
active = Tags;
356
Removed:
content;
357
Removed:
}
301
Added:
render_page context ~active:Tags content
lib/views/root.ml
@@ -1,32 +1,21 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
3
open Dream_html
4
Removed:
open Config
5
4
6
Removed:
let render () =
7
Removed:
try
8
Removed:
let all_repositories =
9
Removed:
let repos =
10
Removed:
Sys.readdir config.git_project_root
11
Removed:
|> Array.to_list
12
Removed:
|> List.filter (fun name ->
13
Removed:
(not (name.[0] = '.'))
14
Removed:
&& Resolvers.is_repository
15
Removed:
(Filename.concat config.git_project_root name))
16
Removed:
|> List.sort String.compare
17
Removed:
in
18
Removed:
let li_of_repo repo =
19
Removed:
HTML.li [] [ Routes.link_to (Routes.Repo repo) (txt "%s" repo) ]
20
Removed:
in
21
Removed:
HTML.(div [ id "repositories" ] [ ul [] @@ List.map li_of_repo repos ])
22
Removed:
in
23
Removed:
respond
24
Removed:
@@ Layout.render
25
Removed:
{
26
Removed:
title = "Ogit";
27
Removed:
repo = None;
28
Removed:
subtitle = "Repositories for " ^ config.user;
29
Removed:
active = Summary;
30
Removed:
content = [ all_repositories ];
31
Removed:
}
32
Removed:
with Sys_error message -> Layout.error_page message
5
Added:
let render ~user repositories =
6
Added:
let li_of_repo repo =
7
Added:
HTML.li [] [ Routes.link_to (Routes.Repo repo) (txt "%s" repo) ]
8
Added:
in
9
Added:
let all_repositories =
10
Added:
HTML.(
11
Added:
div [ id "repositories" ] [ ul [] (List.map li_of_repo repositories) ])
12
Added:
in
13
Added:
respond
14
Added:
@@ Layout.render ~user
15
Added:
{
16
Added:
title = "Ogit";
17
Added:
repo = None;
18
Added:
subtitle = "Repositories for " ^ user;
19
Added:
active = Summary;
20
Added:
content = [ all_repositories ];
21
Added:
}
scripts/build-release.sh
@@ -15,9 +15,21 @@
15
15
set -eu
16
16
17
17
SWITCH_NAME="ogit-static"
18
Removed:
OCAML_VERSION="5.2.1"
19
18
PROJECT_ROOT="$(cd "$(dirname "$0")/.." && pwd)"
19
Added:
OCAML_VERSION="$(
20
Added:
awk '/\(ocaml \(= / {
21
Added:
version = $3
22
Added:
gsub(/[()]/, "", version)
23
Added:
print version
24
Added:
exit
25
Added:
}' "${PROJECT_ROOT}/dune-project"
26
Added:
)"
20
27
DIST_DIR="${PROJECT_ROOT}/dist"
28
Added:
29
Added:
if [ -z "${OCAML_VERSION}" ]; then
30
Added:
echo "ERROR: Could not determine the OCaml version from dune-project."
31
Added:
exit 1
32
Added:
fi
21
33
22
34
# Verify musl-gcc is available
23
35
if ! command -v musl-gcc >/dev/null 2>&1; then
test/dune
@@ -1,3 +1,3 @@
1
1
(test
2
2
(name test_ogit)
3
Removed:
(libraries ogit unix))
3
Added:
(libraries ogit unix lwt.unix))
test/test_ogit.ml
@@ -1,58 +1,129 @@
1
Added:
(* -*- mode: tuareg; -*- *)
2
Added:
3
Added:
let rec remove_path path =
4
Added:
try
5
Added:
if Sys.is_directory path then (
6
Added:
Sys.readdir path
7
Added:
|> Array.iter (fun name -> remove_path (Filename.concat path name));
8
Added:
Unix.rmdir path)
9
Added:
else Sys.remove path
10
Added:
with Sys_error _ -> ()
11
Added:
12
Added:
let with_temp_file prefix suffix test =
13
Added:
let file = Filename.temp_file prefix suffix in
14
Added:
Fun.protect ~finally:(fun () -> remove_path file) (fun () -> test file)
15
Added:
16
Added:
let with_temp_directory prefix test =
17
Added:
with_temp_file prefix "" (fun root ->
18
Added:
Sys.remove root;
19
Added:
Unix.mkdir root 0o755;
20
Added:
test root)
21
Added:
22
Added:
let with_environment name value test =
23
Added:
let previous = Sys.getenv_opt name in
24
Added:
Unix.putenv name value;
25
Added:
Fun.protect
26
Added:
~finally:(fun () -> Unix.putenv name (Option.value previous ~default:""))
27
Added:
test
28
Added:
29
Added:
let fail_config_error error = failwith (Ogit.Config.load_error_to_string error)
30
Added:
1
31
let test_config_round_trip () =
2
Removed:
let file = Filename.temp_file "ogit" ".toml" in
3
Removed:
let config =
4
Removed:
Ogit.Config.
5
Removed:
{
6
Removed:
user = "alice";
7
Removed:
default_branch = "main";
8
Removed:
git_project_root = "/srv/git";
9
Removed:
commits_max_displayed = 25;
10
Removed:
host = "127.0.0.1";
11
Removed:
port = 9000;
12
Removed:
}
13
Removed:
in
14
Removed:
Ogit.Config.write_file ~file (Ogit.Config.to_table config);
15
Removed:
match Ogit.Config.read_file ~file () with
16
Removed:
| Ok config' -> assert (config' = config)
17
Removed:
| Error message -> failwith message
32
Added:
with_temp_file "ogit" ".toml" (fun file ->
33
Added:
let config =
34
Added:
Ogit.Config.
35
Added:
{
36
Added:
user = "alice";
37
Added:
default_branch = "main";
38
Added:
git_project_root = "/srv/git";
39
Added:
commits_max_displayed = 25;
40
Added:
host = "127.0.0.1";
41
Added:
port = 9000;
42
Added:
}
43
Added:
in
44
Added:
Ogit.Config.write_file ~file (Ogit.Config.to_table config);
45
Added:
match Ogit.Config.read_file ~file () with
46
Added:
| Ok config' -> assert (config' = config)
47
Added:
| Error error -> fail_config_error error)
18
48
19
49
let test_config_backward_compat () =
20
Removed:
let file = Filename.temp_file "ogit" ".toml" in
21
Removed:
let oc = open_out file in
22
Removed:
Printf.fprintf oc
23
Removed:
"user = \"bob\"\n\
24
Removed:
default_branch = \"main\"\n\
25
Removed:
git_project_root = \"/srv/git\"\n\
26
Removed:
commits_max_displayed = 10\n";
27
Removed:
close_out oc;
28
Removed:
match Ogit.Config.read_file ~file () with
29
Removed:
| Ok config ->
30
Removed:
assert (config.host = "127.0.0.1");
31
Removed:
assert (config.port = 8081)
32
Removed:
| Error message -> failwith message
50
Added:
with_temp_file "ogit" ".toml" (fun file ->
51
Added:
Out_channel.with_open_text file (fun channel ->
52
Added:
Printf.fprintf channel
53
Added:
"user = \"bob\"\n\
54
Added:
default_branch = \"main\"\n\
55
Added:
git_project_root = \"/srv/git\"\n\
56
Added:
commits_max_displayed = 10\n");
57
Added:
match Ogit.Config.read_file ~file () with
58
Added:
| Ok config ->
59
Added:
assert (config.host = "127.0.0.1");
60
Added:
assert (config.port = 8081)
61
Added:
| Error error -> fail_config_error error)
33
62
63
Added:
let test_config_errors () =
64
Added:
with_temp_file "ogit-malformed" ".toml" (fun file ->
65
Added:
Out_channel.with_open_text file (fun channel ->
66
Added:
output_string channel "user = [\n");
67
Added:
match Ogit.Config.read_file ~file () with
68
Added:
| Error (Ogit.Config.Parse_error _) -> ()
69
Added:
| Error error -> fail_config_error error
70
Added:
| Ok _ -> failwith "malformed configuration was accepted");
71
Added:
with_temp_file "ogit-invalid" ".toml" (fun file ->
72
Added:
let invalid = Ogit.Config.{ default with commits_max_displayed = 0 } in
73
Added:
Ogit.Config.write_file ~file (Ogit.Config.to_table invalid);
74
Added:
match Ogit.Config.read_file ~file () with
75
Added:
| Error (Ogit.Config.Invalid_value _) -> ()
76
Added:
| Error error -> fail_config_error error
77
Added:
| Ok _ -> failwith "invalid commit limit was accepted");
78
Added:
with_temp_directory "ogit-config-directory" (fun directory ->
79
Added:
match Ogit.Config.read_file ~file:directory () with
80
Added:
| Error (Ogit.Config.Io_error _) -> ()
81
Added:
| Error error -> fail_config_error error
82
Added:
| Ok _ -> failwith "a configuration directory was accepted as a file");
83
Added:
with_temp_directory "ogit-xdg" (fun config_home ->
84
Added:
let directory = Filename.concat config_home "ogit" in
85
Added:
Unix.mkdir directory 0o755;
86
Added:
let file = Filename.concat directory "config.toml" in
87
Added:
Out_channel.with_open_text file (fun channel ->
88
Added:
output_string channel "user = [\n");
89
Added:
with_environment "OGIT_CONFIG" "" (fun () ->
90
Added:
with_environment "XDG_CONFIG_HOME" config_home (fun () ->
91
Added:
match Ogit.Config.load () with
92
Added:
| Error (Ogit.Config.Parse_error _) -> ()
93
Added:
| Error error -> fail_config_error error
94
Added:
| Ok _ -> failwith "an invalid implicit config should fail")));
95
Added:
let missing = Filename.temp_file "ogit-missing" ".toml" in
96
Added:
Sys.remove missing;
97
Added:
with_environment "OGIT_CONFIG" missing (fun () ->
98
Added:
match Ogit.Config.load () with
99
Added:
| Error (Ogit.Config.Not_found file) -> assert (file = missing)
100
Added:
| Error error -> fail_config_error error
101
Added:
| Ok _ -> failwith "an explicitly missing config should fail")
102
Added:
34
103
let test_config_location () =
35
Removed:
if Sys.getenv_opt "OGIT_CONFIG" = None then (
36
Removed:
Unix.putenv "XDG_CONFIG_HOME" "/tmp/xdg-config";
37
Removed:
assert (
38
Removed:
Ogit.Config.locate_config_file ()
39
Removed:
= Filename.concat (Filename.concat "/tmp/xdg-config" "ogit") "config.toml"));
40
Removed:
Unix.putenv "OGIT_CONFIG" "/tmp/custom-ogit.toml";
41
Removed:
assert (Ogit.Config.locate_config_file () = "/tmp/custom-ogit.toml")
104
Added:
with_environment "OGIT_CONFIG" "" (fun () ->
105
Added:
with_environment "XDG_CONFIG_HOME" "/tmp/xdg-config" (fun () ->
106
Added:
assert (
107
Added:
Ogit.Config.locate_config_file ()
108
Added:
= Filename.concat
109
Added:
(Filename.concat "/tmp/xdg-config" "ogit")
110
Added:
"config.toml")));
111
Added:
with_environment "OGIT_CONFIG" "/tmp/custom-ogit.toml" (fun () ->
112
Added:
assert (Ogit.Config.locate_config_file () = "/tmp/custom-ogit.toml"))
42
113
43
114
let test_description_reader () =
44
Removed:
let file = Filename.temp_file "ogit-description" ".txt" in
45
Removed:
Sys.remove file;
46
Removed:
assert (
47
Removed:
Ogit.Resolvers.read_description_file file
48
Removed:
= Ogit.Resolvers.default_repo_description);
49
Removed:
Out_channel.with_open_text file (fun oc -> output_string oc "\n");
50
Removed:
assert (
51
Removed:
Ogit.Resolvers.read_description_file file
52
Removed:
= Ogit.Resolvers.default_repo_description);
53
Removed:
Out_channel.with_open_text file (fun oc ->
54
Removed:
output_string oc "A useful repository\n");
55
Removed:
assert (Ogit.Resolvers.read_description_file file = "A useful repository")
115
Added:
with_temp_file "ogit-description" ".txt" (fun file ->
116
Added:
Sys.remove file;
117
Added:
assert (
118
Added:
Ogit.Resolvers.read_description_file file
119
Added:
= Ogit.Resolvers.default_repo_description);
120
Added:
Out_channel.with_open_text file (fun _ -> ());
121
Added:
assert (
122
Added:
Ogit.Resolvers.read_description_file file
123
Added:
= Ogit.Resolvers.default_repo_description);
124
Added:
Out_channel.with_open_text file (fun channel ->
125
Added:
output_string channel "A useful repository\n");
126
Added:
assert (Ogit.Resolvers.read_description_file file = "A useful repository"))
56
127
57
128
let make_git_directory path =
58
129
Unix.mkdir path 0o755;
@@ -60,37 +131,128 @@
60
131
Unix.mkdir (Filename.concat path "objects") 0o755
61
132
62
133
let test_repository_layout () =
63
Removed:
let root = Filename.temp_file "ogit-repositories" "" in
64
Removed:
Sys.remove root;
65
Removed:
Unix.mkdir root 0o755;
66
Removed:
let bare = Filename.concat root "bare.git" in
67
Removed:
make_git_directory bare;
68
Removed:
let clone = Filename.concat root "clone" in
69
Removed:
Unix.mkdir clone 0o755;
70
Removed:
make_git_directory (Filename.concat clone ".git");
71
Removed:
let ordinary_directory = Filename.concat root "not-a-repository" in
72
Removed:
Unix.mkdir ordinary_directory 0o755;
73
Removed:
assert (Ogit.Resolvers.is_repository bare);
74
Removed:
assert (Ogit.Resolvers.is_repository clone);
75
Removed:
assert (not (Ogit.Resolvers.is_repository ordinary_directory));
76
Removed:
(match Ogit.Resolvers.repository_layout bare with
77
Removed:
| Some { worktree; git_dir } ->
78
Removed:
assert (worktree = bare);
79
Removed:
assert (git_dir = bare)
80
Removed:
| None -> failwith "expected a bare repository layout");
81
Removed:
match Ogit.Resolvers.repository_layout clone with
82
Removed:
| Some { worktree; git_dir } ->
83
Removed:
assert (worktree = clone);
84
Removed:
assert (git_dir = Filename.concat clone ".git")
85
Removed:
| None -> failwith "expected a non-bare repository layout"
134
Added:
with_temp_directory "ogit-repositories" (fun root ->
135
Added:
let bare = Filename.concat root "bare.git" in
136
Added:
make_git_directory bare;
137
Added:
let clone = Filename.concat root "clone" in
138
Added:
Unix.mkdir clone 0o755;
139
Added:
make_git_directory (Filename.concat clone ".git");
140
Added:
let ordinary_directory = Filename.concat root "not-a-repository" in
141
Added:
Unix.mkdir ordinary_directory 0o755;
142
Added:
assert (Ogit.Resolvers.is_repository bare);
143
Added:
assert (Ogit.Resolvers.is_repository clone);
144
Added:
assert (not (Ogit.Resolvers.is_repository ordinary_directory));
145
Added:
(match Ogit.Resolvers.repository_layout bare with
146
Added:
| Some { worktree; git_dir } ->
147
Added:
assert (worktree = bare);
148
Added:
assert (git_dir = bare)
149
Added:
| None -> failwith "expected a bare repository layout");
150
Added:
match Ogit.Resolvers.repository_layout clone with
151
Added:
| Some { worktree; git_dir } ->
152
Added:
assert (worktree = clone);
153
Added:
assert (git_dir = Filename.concat clone ".git")
154
Added:
| None -> failwith "expected a non-bare repository layout")
86
155
156
Added:
let test_repository_listing () =
157
Added:
with_temp_directory "ogit-listing" (fun root ->
158
Added:
make_git_directory (Filename.concat root "visible.git");
159
Added:
make_git_directory (Filename.concat root ".hidden.git");
160
Added:
let config = Ogit.Config.{ default with git_project_root = root } in
161
Added:
match Ogit.Resolvers.repositories config with
162
Added:
| Ok repositories -> assert (repositories = [ "visible.git" ])
163
Added:
| Error error ->
164
Added:
failwith (Format.asprintf "%a" Ogit.Resolvers.pp_error error))
165
Added:
87
166
let test_fallback_branch_candidates () =
88
Removed:
let names = Ogit.Resolvers.fallback_branch_candidates () in
89
Removed:
assert (List.length names >= 2);
90
Removed:
assert (List.mem "main" names);
91
Removed:
assert (List.mem "master" names);
92
Removed:
assert (List.length (List.sort_uniq String.compare names) = List.length names)
167
Added:
let config = Ogit.Config.{ default with default_branch = "trunk" } in
168
Added:
let names = Ogit.Resolvers.fallback_branch_candidates config in
169
Added:
assert (names = [ "trunk"; "main"; "master" ]);
170
Added:
let main = Ogit.Config.{ config with default_branch = "main" } in
171
Added:
assert (Ogit.Resolvers.fallback_branch_candidates main = [ "main"; "master" ])
93
172
173
Added:
let git arguments =
174
Added:
let command = "git" in
175
Added:
let arguments = Array.of_list (command :: arguments) in
176
Added:
let channel = Unix.open_process_args_in command arguments in
177
Added:
let output = In_channel.input_all channel |> String.trim in
178
Added:
match Unix.close_process_in channel with
179
Added:
| Unix.WEXITED 0 -> output
180
Added:
| Unix.WEXITED code -> failwith (Printf.sprintf "git exited with %d" code)
181
Added:
| Unix.WSIGNALED signal | Unix.WSTOPPED signal ->
182
Added:
failwith (Printf.sprintf "git stopped by signal %d" signal)
183
Added:
184
Added:
let test_repository_boundaries () =
185
Added:
with_temp_directory "ogit-tree-paths" (fun root ->
186
Added:
let name = "project" in
187
Added:
let path = Filename.concat root name in
188
Added:
Unix.mkdir path 0o755;
189
Added:
ignore (git [ "-C"; path; "init"; "-q"; "-b"; "main" ]);
190
Added:
ignore (git [ "-C"; path; "config"; "user.name"; "Test User" ]);
191
Added:
ignore
192
Added:
(git [ "-C"; path; "config"; "user.email"; "test@example.invalid" ]);
193
Added:
Out_channel.with_open_text (Filename.concat path "tracked.txt")
194
Added:
(fun channel -> output_string channel "tracked\n");
195
Added:
let nested_directory = Filename.concat path "dir" in
196
Added:
Unix.mkdir nested_directory 0o755;
197
Added:
Out_channel.with_open_text (Filename.concat nested_directory "nested.txt")
198
Added:
(fun channel -> output_string channel "nested\n");
199
Added:
ignore (git [ "-C"; path; "add"; "." ]);
200
Added:
ignore (git [ "-C"; path; "commit"; "-q"; "-m"; "initial" ]);
201
Added:
let root_tree = git [ "-C"; path; "rev-parse"; "HEAD^{tree}" ] in
202
Added:
let nested_tree = git [ "-C"; path; "rev-parse"; "HEAD:dir" ] in
203
Added:
let nested_blob =
204
Added:
git [ "-C"; path; "rev-parse"; "HEAD:dir/nested.txt" ]
205
Added:
in
206
Added:
let dangling_file = Filename.concat root "dangling.txt" in
207
Added:
Out_channel.with_open_text dangling_file (fun channel ->
208
Added:
output_string channel "dangling\n");
209
Added:
let dangling_blob =
210
Added:
git [ "-C"; path; "hash-object"; "-w"; dangling_file ]
211
Added:
in
212
Added:
let config = Ogit.Config.{ default with git_project_root = root } in
213
Added:
let repository =
214
Added:
match Lwt_main.run (Ogit.Resolvers.open_repository config name) with
215
Added:
| Ok repository -> repository
216
Added:
| Error error ->
217
Added:
failwith (Format.asprintf "%a" Ogit.Resolvers.pp_error error)
218
Added:
in
219
Added:
Fun.protect
220
Added:
~finally:(fun () ->
221
Added:
Lwt_main.run (Ogit.Resolvers.close_repository repository))
222
Added:
(fun () ->
223
Added:
(match
224
Added:
Lwt_main.run (Ogit.Resolvers.Tree.find_path repository root_tree)
225
Added:
with
226
Added:
| Ok [] -> ()
227
Added:
| Ok _ ->
228
Added:
failwith "the root tree should have an empty breadcrumb trail"
229
Added:
| Error error ->
230
Added:
failwith (Format.asprintf "%a" Ogit.Resolvers.pp_error error));
231
Added:
(match
232
Added:
Lwt_main.run (Ogit.Resolvers.Tree.find_path repository nested_blob)
233
Added:
with
234
Added:
| Ok [ ("dir", tree); ("nested.txt", blob) ] ->
235
Added:
assert (tree = nested_tree);
236
Added:
assert (blob = nested_blob)
237
Added:
| Ok _ -> failwith "unexpected nested breadcrumb trail"
238
Added:
| Error error ->
239
Added:
failwith (Format.asprintf "%a" Ogit.Resolvers.pp_error error));
240
Added:
match
241
Added:
Lwt_main.run
242
Added:
(Ogit.Resolvers.Tree.find_path repository dangling_blob)
243
Added:
with
244
Added:
| Error (Ogit.Resolvers.Not_found _) -> ()
245
Added:
| Error error ->
246
Added:
failwith (Format.asprintf "%a" Ogit.Resolvers.pp_error error)
247
Added:
| Ok _ ->
248
Added:
failwith "an unreachable object should not look like the root");
249
Added:
let request = Dream.test (Dream.router (Ogit.Handlers.routes config)) in
250
Added:
let status target = Dream.request ~target "" |> request |> Dream.status in
251
Added:
assert (status "/.hidden/summary/" = `Bad_Request);
252
Added:
assert (status "/missing/summary/" = `Not_Found);
253
Added:
assert (status "/project/commit/not-a-hash" = `Bad_Request);
254
Added:
assert (status ("/project/commit/" ^ String.make 40 'a') = `Not_Found))
255
Added:
94
256
let test_line_diff () =
95
257
let open Ogit.Resolvers.Diff in
96
258
match line_diff "first\nold\nlast\n" "first\nnew\nlast\n" with
@@ -124,6 +286,13 @@
124
286
assert (hunk.new_count = 7)
125
287
| _ -> failwith "expected one diff hunk"
126
288
289
Added:
let test_error_status () =
290
Added:
let response =
291
Added:
Ogit.Views.error_page ~status:`Not_Found ~title:"Not found" "missing"
292
Added:
|> Lwt_main.run
293
Added:
in
294
Added:
assert (Dream.status response = `Not_Found)
295
Added:
127
296
let test_static_assets () =
128
297
(match Ogit.Static_assets.read "styles.css" with
129
298
| Some content -> assert (String.length content > 0)
@@ -133,7 +302,14 @@
133
302
| None -> failwith "git_icon.svg should be embedded");
134
303
assert (Ogit.Static_assets.read "nonexistent" = None)
135
304
136
Removed:
let () =
305
Added:
let test_routes () =
306
Added:
let path route = Format.asprintf "%a" Dream_html.pp_path route in
307
Added:
assert (path Ogit.Routes.root_path = "/");
308
Added:
assert (path Ogit.Routes.repo_path = "/%s/summary/");
309
Added:
assert (path Ogit.Routes.commit_path = "/%s/commit/%s");
310
Added:
assert (path Ogit.Routes.static_path = "/static/%*s")
311
Added:
312
Added:
let test_validation () =
137
313
assert (Ogit.Resolvers.is_valid_repo_name "project.git");
138
314
assert (Ogit.Resolvers.is_valid_repo_name "project");
139
315
assert (not (Ogit.Resolvers.is_valid_repo_name ""));
@@ -149,19 +325,39 @@
149
325
assert (not (Ogit.Resolvers.is_valid_hash_hex (String.make 39 'a')));
150
326
assert (not (Ogit.Resolvers.is_valid_hash_hex (String.make 41 'a')));
151
327
assert (not (Ogit.Resolvers.is_valid_hash_hex (String.make 39 'a' ^ "x")));
328
Added:
assert (Ogit.Resolvers.short_hash "abc" = "abc");
329
Added:
assert (Ogit.Resolvers.short_hash "0123456789" = "01234567");
152
330
assert (Ogit.Resolvers.Reference.branch_name "refs/heads/main" = Some "main");
153
331
assert (
154
332
Ogit.Resolvers.Reference.branch_name "refs/heads/feature/topic"
155
333
= Some "feature/topic");
156
334
assert (Ogit.Resolvers.Reference.branch_name "HEAD" = None);
157
335
assert (Ogit.Resolvers.Reference.tag_name "refs/tags/v1.0.0" = Some "v1.0.0");
158
Removed:
assert (Ogit.Resolvers.Reference.tag_name "refs/heads/v1.0.0" = None);
159
Removed:
test_config_round_trip ();
160
Removed:
test_config_backward_compat ();
161
Removed:
test_config_location ();
162
Removed:
test_description_reader ();
163
Removed:
test_repository_layout ();
164
Removed:
test_fallback_branch_candidates ();
165
Removed:
test_line_diff ();
166
Removed:
test_diff_hunks ();
167
Removed:
test_static_assets ()
336
Added:
assert (Ogit.Resolvers.Reference.tag_name "refs/heads/v1.0.0" = None)
337
Added:
338
Added:
let tests =
339
Added:
[
340
Added:
("validation", test_validation);
341
Added:
("config round trip", test_config_round_trip);
342
Added:
("config backward compatibility", test_config_backward_compat);
343
Added:
("config errors", test_config_errors);
344
Added:
("config location", test_config_location);
345
Added:
("description reader", test_description_reader);
346
Added:
("repository layout", test_repository_layout);
347
Added:
("repository listing", test_repository_listing);
348
Added:
("fallback branches", test_fallback_branch_candidates);
349
Added:
("repository boundaries", test_repository_boundaries);
350
Added:
("line diff", test_line_diff);
351
Added:
("diff hunks", test_diff_hunks);
352
Added:
("HTTP error status", test_error_status);
353
Added:
("static assets", test_static_assets);
354
Added:
("route patterns", test_routes);
355
Added:
]
356
Added:
357
Added:
let () =
358
Added:
List.iter
359
Added:
(fun (name, test) ->
360
Added:
try test ()
361
Added:
with error ->
362
Added:
failwith (Printf.sprintf "%s: %s" name (Printexc.to_string error)))
363
Added:
tests