(* -*- mode: tuareg; -*- *)
open Dream_html
open Config
type body_data = {
title : string;
subtitle : string;
topnav : Dream_html.node;
content : Dream_html.node list;
}
module Components = struct
module Topnav = struct
type t = None | Summary | Log | Files | Refs
let v ?(active_path = None) repo =
let open HTML in
let nav_items =
[
(Routes.Repo repo, "Summary", Summary);
(Routes.Log repo, "Log", Log);
(Routes.Files repo, "Files", Files);
(Routes.Refs repo, "Refs", Refs);
]
in
let li_of_item (route, text, path) =
let is_active = path = active_path in
let attrs = if is_active then [ id "active" ] else [] in
HTML.li attrs [ Routes.link_to route (txt "%s" text) ]
in
nav [ id "top" ] [ ul [] @@ List.map li_of_item nav_items ]
end
end
module Page = struct
let page_header header1 header2 =
let header2 =
if String.starts_with ~prefix:"Unnamed repository" header2 then ""
else header2
in
HTML.(null [ h1 [] [ txt "%s" header1 ]; h2 [] [ txt "%s" header2 ] ])
let page_footer () =
let today = Unix.localtime (Unix.time ()) in
let year = string_of_int (today.Unix.tm_year + 1900) in
let footer_text = Printf.sprintf "Copyright %s %s" year config.user in
HTML.footer [] [ txt "%s" footer_text ]
let render ?(page_title = "Ogit") body_data =
let open HTML in
html []
[
head []
[
title [] "%s" page_title;
link [ rel "stylesheet"; href "/static/styles.css" ];
link
[ rel "icon"; type_ "image/x-icon"; href "/static/git_icon.svg" ];
];
body []
[
page_header body_data.title body_data.subtitle;
body_data.topnav;
div [ id "main" ] body_data.content;
page_footer ();
];
]
end
let root () =
let all_repositories =
let repos =
Sys.readdir config.git_project_root
|> Array.to_list |> List.sort String.compare
in
let li_of_repo repo =
HTML.li [] [ Routes.link_to (Routes.Repo repo) (txt "%s" repo) ]
in
HTML.(div [ id "repositories" ] [ ul [] @@ List.map li_of_repo repos ])
in
let body_data =
{
title = "Ogit";
subtitle = "Repositories for " ^ config.user;
topnav = HTML.null [];
content = [ all_repositories ];
}
in
respond @@ Page.render body_data
module Repo = struct
let page_title repo =
Printf.sprintf "%s — %s" repo (Resolvers.repo_description repo)
let li_of_author author = HTML.(li [] [ txt "%s" author ])
(* let li_of_branch repo (branch : Resolvers.Branch.t) = *)
(* HTML.(li [] [ Routes.link_to (Refs repo) (txt "%s" branch.name) ]) *)
let li_of_commit repo (commit : Resolvers.Commit.t) =
let open HTML in
let short_hash = Resolvers.short_hash commit.hash in
match commit.message with
| None -> li [] [ txt "%s" short_hash ]
| Some msg ->
li []
[
Routes.link_to
(Commit (repo, commit.hash))
(null
[
span [ class_ "commit-hash" ] [ txt "%s" short_hash ];
txt " — %s" msg;
]);
]
let li_of_entry repo (entry : Resolvers.Entry.t) =
let display_name =
if entry.perm = 0o040000 then entry.name ^ "/" else entry.name
in
let route =
if entry.perm = 0o040000 then Routes.Files repo
else Routes.File (repo, entry.hash)
in
HTML.(li [] [ Routes.link_to route @@ txt "%s" display_name ])
let summary repo _branches commits authors =
let content =
HTML.
[
h3 [] [ txt "Branches" ];
(* ul [] (List.map (li_of_branch repo) branches); *)
h3 [] [ txt "Latest commits" ];
ul [] (List.map (li_of_commit repo) commits);
h3 [] [ txt "Authors" ];
ul [] (List.map li_of_author authors);
]
in
respond
@@ Page.render ~page_title:(page_title repo)
{
title = repo;
subtitle = Resolvers.repo_description repo;
topnav = Components.Topnav.(v ~active_path:Summary repo);
content;
}
let refs repo _branches =
let content =
HTML.
[
h3 [] [ txt "Branches" ];
(* ul [] (List.map (li_of_branch repo) branches); *)
]
in
respond
@@ Page.render ~page_title:(page_title repo)
{
title = repo;
subtitle = Resolvers.repo_description repo;
topnav = Components.Topnav.(v ~active_path:Refs repo);
content;
}
let log repo commits =
let content =
HTML.
[
h3 [] [ txt "All commits" ];
ul [] (List.map (li_of_commit repo) commits);
]
in
respond
@@ Page.render ~page_title:(page_title repo)
{
title = repo;
subtitle = Resolvers.repo_description repo;
topnav = Components.Topnav.(v ~active_path:Log repo);
content;
}
let files repo (tree : Resolvers.Tree.t) =
let content =
HTML.
[
h3 [] [ txt "Files %s" @@ Resolvers.short_hash tree.hash ];
ul [] (List.map (li_of_entry repo) tree.entries);
]
in
respond
@@ Page.render ~page_title:(page_title repo)
{
title = Printf.sprintf "%s" repo;
subtitle = Resolvers.repo_description repo;
topnav = Components.Topnav.(v ~active_path:Files repo);
content;
}
let file repo (blob : Resolvers.Blob.t) =
let title = Printf.sprintf "%s" repo in
let to_numbered_line number line =
let n = number + 1 in
HTML.
[
a [ id "%d" n; class_ "line-anchor"; href "#%d" n ] [ txt "%d" n ];
span [ class_ "line" ] [ txt "\t%s\n" line ];
]
in
let formatted_blob =
String.split_on_char '\n' blob.content
|> List.mapi to_numbered_line |> List.flatten
in
let content =
HTML.[ h3 [] [ txt "File" ]; div [ id "blob" ] formatted_blob ]
in
respond
@@ Page.render ~page_title:(page_title repo)
{
title;
subtitle = Resolvers.repo_description repo;
topnav = Components.Topnav.(v ~active_path:Files repo);
content;
}
let commit repo (commit : Resolvers.Commit.t) =
let message = match commit.message with Some msg -> msg | None -> "" in
let title =
Printf.sprintf "%s : %s" repo @@ Resolvers.short_hash commit.hash
in
let content = HTML.[ h3 [] [ txt "%s" message ] ] in
respond
@@ Page.render ~page_title:(page_title repo)
{
title;
subtitle = Resolvers.repo_description repo;
topnav = Components.Topnav.v repo;
content;
}
end
let error_page message =
let open HTML in
respond
@@ html []
[
head []
[
title [] "Fatal error";
link [ rel "stylesheet"; href "/static/styles.css" ];
link
[ rel "icon"; type_ "image/x-icon"; href "/static/git_icon.svg" ];
];
body []
[
h1 [] [ txt "Fatal Error" ];
div
[ id "main" ]
[
p [] [ b [] [ txt "%s" message ] ];
p []
[
txt
"Your best course of action is to press the 'back' \
button in your browser.";
];
];
];
]