Repositories / gitweb2.git
src/gitweb2.ml
Clone (read-only): git clone http://git.guha-anderson.com/git/gitweb2.git
type response = {
status : int;
headers : (string * string) list;
body : string;
}
let html_headers : (string * string) list =
[ ("Cache-Control", "no-store"); ("Content-Type", "text/html; charset=utf-8") ]
let html_response (status : int) (body : string) : response =
{ status; headers = html_headers; body }
type config = {
root : string;
host : string;
port : int;
pygments_command : string;
public_url : string option;
}
type repo_info = {
key : string;
name : string;
path : string;
}
type repo_summary = {
branch : string;
summary : string;
short_id : string;
}
let default_host : string = "127.0.0.1"
let default_port : int = 8080
let default_pygments_command : string = "pygmentize"
let max_scan_depth : int = 5
let access_src =
Logs.Src.create "gitweb2.access" ~doc:"HTTP request access log (method, path, status, bytes)"
let html (value : string) : string =
let buffer = Buffer.create (String.length value) in
String.iter
(function
| '&' -> Buffer.add_string buffer "&"
| '<' -> Buffer.add_string buffer "<"
| '>' -> Buffer.add_string buffer ">"
| '"' -> Buffer.add_string buffer """
| '\'' -> Buffer.add_string buffer "'"
| char -> Buffer.add_char buffer char)
value;
Buffer.contents buffer
let url_encode (value : string) : string = Uri.pct_encode value
let url_decode (value : string) : string = Uri.pct_decode value
let join_path (base : string) (child : string) : string =
match (base, child) with
| "", child -> child
| base, "" -> base
| base, child when String.ends_with ~suffix:"/" base -> base ^ child
| base, child -> base ^ "/" ^ child
let split_path (path : string) : string list = String.split_on_char '/' path |> List.filter (( <> ) "")
let command_exists (command : string) : bool =
let executable = String.trim command |> String.split_on_char ' ' |> List.hd in
if executable = "" then false
else if String.contains executable '/' then Sys.file_exists executable
else
match Sys.getenv_opt "PATH" with
| None -> false
| Some paths ->
String.split_on_char ':' paths
|> List.exists (fun dir -> Sys.file_exists (join_path dir executable))
let read_all (channel : in_channel) : string =
let buffer = Buffer.create 4096 in
let bytes = Bytes.create 4096 in
let rec loop () =
match input channel bytes 0 (Bytes.length bytes) with
| 0 -> Buffer.contents buffer
| n ->
Buffer.add_subbytes buffer bytes 0 n;
loop ()
in
loop ()
let read_command_output ?input (command : string) : string option =
let stdout, stdin, stderr = Unix.open_process_full command (Unix.environment ()) in
Option.iter (output_string stdin) input;
close_out stdin;
let out = read_all stdout in
let err = read_all stderr in
ignore err;
match Unix.close_process_full (stdout, stdin, stderr) with
| Unix.WEXITED 0 -> Some (String.map (function '\r' -> '\n' | c -> c) out)
| _ -> None
let shell_quote : string -> string = Filename.quote
(* Pygments is optional. Rendering falls back to escaped text so repository
browsing still works on machines without the highlighter installed. *)
let file_render ?(pygments_command : string = default_pygments_command) ~(file_path : string) (text : string) : string =
let plain () = "<pre><code>" ^ html text ^ "</code></pre>" in
if not (command_exists pygments_command) then plain ()
else
let lexer =
read_command_output (pygments_command ^ " -N " ^ shell_quote file_path ^ " 2>/dev/null")
|> Option.map String.trim
in
let lexer_option =
match lexer with
| Some lexer when lexer <> "" -> "-l " ^ shell_quote lexer
| _ -> "-g"
in
let command = pygments_command ^ " -f html -O nowrap,noclasses=True " ^ lexer_option ^ " 2>/dev/null" in
match read_command_output ~input:text command with
| Some highlighted when String.trim highlighted <> "" -> "<div class=\"highlight\">" ^ highlighted ^ "</div>"
| _ -> plain ()
let is_readme (name : string) : bool = name = "README.md" || name = "README.txt" || name = "README"
let page (title : string) (body : string) : string =
let buffer = Buffer.create (String.length body + 4096) in
Buffer.add_string buffer "<!doctype html>\n<html lang=\"en\">\n<head>\n<meta charset=\"utf-8\">\n\
<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">\n<title>";
Printf.bprintf buffer [%i "{%s html title} · gitweb2</title>\n<style>\n"];
Buffer.add_string buffer
":root { color-scheme: light; --ink: #1f2428; --muted: #586069; --line: #d0d7de; --wash: #f6f8fa; --link: #0969da; --accent: #1a7f37; }\n\
* { box-sizing: border-box; }\n\
body { margin: 0; font: 15px/1.5 -apple-system, BlinkMacSystemFont, \"Segoe UI\", sans-serif; color: var(--ink); background: #fff; }\n\
a { color: var(--link); text-decoration: none; } a:hover { text-decoration: underline; }\n\
main { max-width: 1180px; margin: 0 auto; padding: 28px 20px 56px; }\n\
.hero, .repo-head { border-bottom: 1px solid var(--line); margin-bottom: 20px; padding-bottom: 16px; }\n\
.eyebrow, .repo-head p, .file-meta, .kind, small, .commits span, .repo-list span { color: var(--muted); }\n\
h1 { margin: 4px 0 8px; font-size: 28px; line-height: 1.2; overflow-wrap: anywhere; }\n\
h2 { margin: 0 0 10px; font-size: 20px; line-height: 1.25; overflow-wrap: anywhere; }\n\
.repo-list, .commits { list-style: none; margin: 0; padding: 0; border: 1px solid var(--line); border-radius: 8px; overflow: hidden; }\n\
.repo-list li, .commits li { border-top: 1px solid var(--line); } .repo-list li:first-child, .commits li:first-child { border-top: 0; }\n\
.repo-list a, .commits a { display: grid; gap: 3px; padding: 14px 16px; color: var(--ink); }\n\
.commits li:hover { background: var(--wash); }\n\
.repo-list strong, .commits strong { font-size: 16px; overflow-wrap: anywhere; } .repo-list small, .commits span { display: block; overflow-wrap: anywhere; }\n\
.panel { border: 1px solid var(--line); border-radius: 8px; overflow: hidden; }\n\
table { width: 100%; border-collapse: collapse; } td { padding: 10px 12px; border-top: 1px solid var(--line); vertical-align: top; overflow-wrap: anywhere; }\n\
tr:first-child td { border-top: 0; } .kind { width: 120px; text-align: right; }\n\
.toolbar { display: flex; align-items: center; gap: 10px; flex-wrap: wrap; margin: 12px 0; } .toolbar nav, .tabs { display: flex; gap: 8px; flex-wrap: wrap; }\n\
.toolbar a, .tabs a { border: 1px solid var(--line); border-radius: 8px; padding: 5px 9px; color: var(--ink); background: #fff; }\n\
.toolbar a.active, .tabs a.active { border-color: var(--accent); color: var(--accent); font-weight: 600; }\n\
.file pre { margin: 0; padding: 16px; overflow: auto; background: var(--wash); } .file code { font: 13px/1.45 ui-monospace, SFMono-Regular, Consolas, monospace; white-space: pre; }\n\
.highlight { margin: 0; padding: 16px; overflow: auto; background: var(--wash); } .highlight pre { margin: 0; padding: 0; background: transparent; }\n\
.highlight, .highlight pre { font: 13px/1.45 ui-monospace, SFMono-Regular, Consolas, monospace; white-space: pre; }\n\
.readme { margin-top: 24px; } .file-meta { padding: 10px 12px; border-bottom: 1px solid var(--line); background: #fff; }\n\
.notice { padding: 16px; border: 1px solid var(--line); border-radius: 8px; background: var(--wash); }\n\
.clone { margin: 6px 0 12px; color: var(--muted); } .clone code { background: var(--wash); border: 1px solid var(--line); border-radius: 6px; padding: 2px 8px; font: 13px ui-monospace, SFMono-Regular, Consolas, monospace; color: var(--ink); user-select: all; }\n\
.commit-meta { padding: 16px 18px; margin-bottom: 16px; background: #fff; }\n\
.commit-meta h2 { margin: 0 0 8px; }\n\
.commit-body { white-space: pre-wrap; background: var(--wash); border: 1px solid var(--line); border-radius: 6px; padding: 10px 12px; margin: 10px 0 14px; font: 13px/1.5 ui-monospace, SFMono-Regular, Consolas, monospace; overflow: auto; }\n\
.commit-fields { display: grid; grid-template-columns: max-content 1fr; gap: 4px 16px; margin: 0; font-size: 13px; }\n\
.commit-fields dt { color: var(--muted); } .commit-fields dd { margin: 0; overflow-wrap: anywhere; }\n\
.commit-fields code { font: 13px ui-monospace, SFMono-Regular, Consolas, monospace; }\n\
.diff-file { margin-top: 14px; }\n\
.diff-file .file-meta { font: 13px ui-monospace, SFMono-Regular, Consolas, monospace; }\n\
pre.diff { margin: 0; padding: 8px 0; background: var(--wash); overflow: auto; font: 13px/1.45 ui-monospace, SFMono-Regular, Consolas, monospace; white-space: pre; }\n\
pre.diff span { display: block; padding: 0 14px; min-height: 1.45em; }\n\
pre.diff .diff-add { background: #e6ffec; color: #1a7f37; }\n\
pre.diff .diff-del { background: #ffebe9; color: #cf222e; }\n\
pre.diff .diff-hunk { background: #ddf4ff; color: #0550ae; }\n\
pre.diff .diff-meta { color: var(--muted); }\n\
@media (max-width: 640px) { main { padding: 20px 12px 40px; } h1 { font-size: 23px; } .kind { width: 78px; } }\n\
</style>\n</head>\n<body><main>";
Buffer.add_string buffer body;
Buffer.add_string buffer "</main></body>\n</html>";
Buffer.contents buffer
let normalize_root (root : string) : string =
let expanded =
if root = "~" then Sys.getenv_opt "HOME" |> Option.value ~default:root
else if String.starts_with ~prefix:"~/" root then
match Sys.getenv_opt "HOME" with
| Some home -> home ^ "/" ^ String.sub root 2 (String.length root - 2)
| None -> root
else root
in
try Unix.realpath expanded |> String.trim with _ -> String.trim expanded
let is_git_repo (path : string) : bool =
Sys.file_exists (join_path path ".git")
|| (Sys.file_exists (join_path path "HEAD") && Sys.file_exists (join_path path "objects")
&& Sys.file_exists (join_path path "refs"))
let is_openable_git_repo (path : string) : bool =
try Ocaml_git.with_repo path (fun _ -> true) with _ -> false
(* Repository scanning intentionally stops descending once a repository is
found, matching git hosting behavior for nested working trees. *)
let discover_repos (root : string) : repo_info list =
let root = normalize_root root in
let found = ref [] in
let rec scan path relative depth =
if is_git_repo path then (
if is_openable_git_repo path then
let key = if relative = "" then Filename.basename path else relative in
found := { key; name = key; path } :: !found)
else if depth < max_scan_depth then
try
Sys.readdir path
|> Array.to_list
|> List.iter (fun name ->
if name <> "." && name <> ".." && name <> ".git" then
scan (join_path path name) (if relative = "" then name else relative ^ "/" ^ name) (depth + 1))
with _ -> ()
in
scan root "" 0;
List.sort (fun a b -> String.compare a.name b.name) !found
let local_branches (repo : Ocaml_git.t) : Ocaml_git.branch list =
Ocaml_git.branches repo |> List.filter (fun (b : Ocaml_git.branch) -> b.kind = Ocaml_git.Local)
let repo_url (repo : repo_info) (branch : string) (path : string) : string =
let prefix = "/repo/" ^ url_encode repo.key ^ "/" ^ url_encode branch in
if path = "" then prefix else prefix ^ "/" ^ (split_path path |> List.map url_encode |> String.concat "/")
let commit_url (repo : repo_info) (branch : string) (id : string) : string =
"/repo/" ^ url_encode repo.key ^ "/" ^ url_encode branch ^ "/-/commit/" ^ url_encode id
let repo_summary (repo : repo_info) : repo_summary =
try
Ocaml_git.with_repo repo.path @@ fun git ->
let branches = local_branches git in
let branch =
match List.find_opt (fun b -> b.Ocaml_git.is_head) branches with
| Some b -> b.name
| None -> (
match branches with
| b :: _ -> b.name
| [] -> "main")
in
let commit = try Some (Ocaml_git.branch_commit git branch) with _ -> None in
{
branch;
summary = (match commit with Some c -> c.summary | None -> "No commits");
short_id = (match commit with Some c -> String.sub c.id 0 (min 12 (String.length c.id)) | None -> "");
}
with _ -> { branch = "main"; summary = "Unavailable"; short_id = "" }
let entries_for_display (entries : Ocaml_git.tree_entry list) : Ocaml_git.tree_entry list =
List.sort (fun (a : Ocaml_git.tree_entry) b -> String.compare (String.lowercase_ascii a.name) (String.lowercase_ascii b.name)) entries
let clone_url (clone_base : string option) (repo : repo_info) : string option =
Option.map (fun base -> base ^ "/git/" ^ url_encode repo.key) clone_base
let repo_header ?(clone_base : string option) (repo : repo_info) (branch : string) (path : string)
(branches : Ocaml_git.branch list) (selected : string) : string =
let buffer = Buffer.create 512 in
let heading_title = if String.length path = 0 then repo.name else path in
Printf.bprintf buffer
[%i
{|<section class="repo-head"><p><a href="/">Repositories</a> / {%s html repo.name}</p><h1>{%s html heading_title}</h1>|} ];
(match clone_url clone_base repo with
| None -> ()
| Some url ->
let command = "git clone " ^ url in
Printf.bprintf buffer [%i {|<p class="clone"><span>Clone (read-only):</span> <code>{%s html command}</code></p>|} ]);
Printf.bprintf buffer [%i {|<div class="toolbar"><span>Branch</span><nav>|} ];
List.iter
(fun (item : Ocaml_git.branch) ->
let active = if item.name = branch then " class=\"active\"" else "" in
Printf.bprintf buffer [%i {|<a{%s active} href="{%s repo_url repo item.name path}">{%s html item.name}</a>|} ])
branches;
Printf.bprintf buffer [%i {|</nav></div><div class="tabs">|} ];
let tab id label href =
let active = if id = selected then " class=\"active\"" else "" in
Printf.bprintf buffer [%i {|<a{%s active} href="{%s href}">{%s label}</a>|} ]
in
tab "code" "Code" (repo_url repo branch path);
tab "history" "History" ("/repo/" ^ url_encode repo.key ^ "/" ^ url_encode branch ^ "/-/commits");
Printf.bprintf buffer [%i {|</div></section>|} ];
Buffer.contents buffer
let tree_view ?(clone_base : string option) ~(pygments_command : string) (repo : repo_info) (git : Ocaml_git.t)
(branch : string) (path : string) (branches : Ocaml_git.branch list) : string =
let commit = Ocaml_git.branch_commit git branch in
let listing = Ocaml_git.tree ~commit ~path git () in
let buffer = Buffer.create 4096 in
Buffer.add_string buffer (repo_header ?clone_base repo branch path branches "code");
Printf.bprintf buffer [%i {|<div class="panel"><table><tbody>|} ];
if String.length path <> 0 then (
let parent = try Filename.dirname path with _ -> "" in
let parent = if parent = "." then "" else parent in
Printf.bprintf buffer [%i {|<tr><td><a href="{%s repo_url repo branch parent}">..</a></td><td class="kind">tree</td></tr>|} ])
else ();
let display_entries = entries_for_display listing.entries in
List.iter
(fun (entry : Ocaml_git.tree_entry) ->
let child = join_path path entry.name in
let kind =
match entry.kind with Blob -> "blob" | Tree -> "tree" | Commit -> "commit" | Tag -> "tag" | Other -> "other"
in
Printf.bprintf buffer [%i {|<tr><td><a href="{%s repo_url repo branch child}">{%s html entry.name}</a></td><td class="kind">{%s kind}</td></tr>|} ])
display_entries;
Printf.bprintf buffer [%i {|</tbody></table></div>|} ];
(match List.find_opt (fun (entry : Ocaml_git.tree_entry) -> is_readme entry.name && entry.kind = Blob) display_entries with
| None -> ()
| Some readme ->
let readme_path = join_path path readme.name in
let blob = Ocaml_git.blob ~commit git readme_path in
if not (Ocaml_git.blob_is_binary blob) then (
Printf.bprintf buffer [%i {|<section class="readme"><h2>{%s html readme.name}</h2><div class="panel file">|} ];
Buffer.add_string buffer (file_render ~pygments_command ~file_path:(join_path repo.path readme_path) (Ocaml_git.blob_text blob));
Buffer.add_string buffer "</div></section>")
else ());
Buffer.contents buffer
let blob_view ?(clone_base : string option) ~(pygments_command : string) (repo : repo_info) (blob : Ocaml_git.blob)
(branch : string) (path : string) (branches : Ocaml_git.branch list) : string =
let buffer = Buffer.create 4096 in
Buffer.add_string buffer (repo_header ?clone_base repo branch path branches "code");
Printf.bprintf buffer [%i {|<div class="panel file"><div class="file-meta">{%d String.length blob.Ocaml_git.bytes} bytes · {%s html (String.sub blob.id 0 (min 12 (String.length blob.id)))}</div>|} ];
if Ocaml_git.blob_is_binary blob then Buffer.add_string buffer "<p class=\"notice\">Binary file</p>"
else Buffer.add_string buffer (file_render ~pygments_command ~file_path:(join_path repo.path path) (Ocaml_git.blob_text blob));
Buffer.add_string buffer "</div>";
Buffer.contents buffer
let starts_with (prefix : string) (s : string) : bool =
let lp = String.length prefix and ls = String.length s in
ls >= lp && String.sub s 0 lp = prefix
(* Best-effort path extraction from "diff --git a/foo b/foo". Falls back to the
full line if the format is unexpected (e.g. paths containing spaces). *)
let diff_header_path (line : string) : string =
match String.split_on_char ' ' line with
| _ :: _ :: _ :: b :: _ when starts_with "b/" b -> String.sub b 2 (String.length b - 2)
| _ :: _ :: a :: _ :: _ when starts_with "a/" a -> String.sub a 2 (String.length a - 2)
| _ -> line
let render_diff (text : string) : string =
let buffer = Buffer.create (String.length text + 1024) in
let in_file = ref false in
let close_file () = if !in_file then (Buffer.add_string buffer "</pre></div>"; in_file := false) in
let line_class line =
if line = "" then "diff-ctx"
else if starts_with "+++ " line || starts_with "--- " line then "diff-meta"
else if starts_with "index " line || starts_with "new file" line || starts_with "deleted file" line
|| starts_with "similarity " line || starts_with "rename " line || starts_with "copy " line
|| starts_with "old mode" line || starts_with "new mode" line
|| starts_with "Binary files" line then "diff-meta"
else if starts_with "@@" line then "diff-hunk"
else if line.[0] = '+' then "diff-add"
else if line.[0] = '-' then "diff-del"
else "diff-ctx"
in
List.iter
(fun line ->
if starts_with "diff --git " line then (
close_file ();
let path = diff_header_path line in
Printf.bprintf buffer
[%i {|<div class="diff-file panel"><div class="file-meta">{%s html path}</div><pre class="diff">|} ];
in_file := true)
else if !in_file then
let cls = line_class line in
Printf.bprintf buffer [%i {|<span class="{%s cls}">{%s html line}</span>
|} ])
(String.split_on_char '\n' text);
close_file ();
Buffer.contents buffer
let format_signature_date (sig_ : Ocaml_git.signature) : string =
let offset = sig_.timezone_offset_minutes in
let local_seconds = sig_.epoch_seconds + (offset * 60) in
let tm = Unix.gmtime (float_of_int local_seconds) in
let sign = if offset >= 0 then "+" else "-" in
let abs_offset = abs offset in
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d %s%02d%02d" (tm.Unix.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
tm.tm_hour tm.tm_min tm.tm_sec sign (abs_offset / 60) (abs_offset mod 60)
let commit_view ?(clone_base : string option) (repo : repo_info) (branch : string) (commit_id : string) : string =
Ocaml_git.with_repo repo.path @@ fun git ->
let branches = local_branches git in
let buffer = Buffer.create 8192 in
Buffer.add_string buffer (repo_header ?clone_base repo branch "" branches "history");
(match
try Some (Ocaml_git.commit_lookup git commit_id) with Ocaml_git.Git_error _ -> None
with
| None -> Printf.bprintf buffer [%i {|<p class="notice">Unknown commit {%s html commit_id}</p>|} ]
| Some commit ->
let subject = commit.summary in
(* The full message starts with the subject; strip it to get just the body. *)
let body =
let msg = String.trim commit.message in
if subject <> "" && starts_with subject msg then
String.trim (String.sub msg (String.length subject) (String.length msg - String.length subject))
else msg
in
let author = commit.author.name in
let author_email = commit.author.email in
let date = format_signature_date commit.author in
Printf.bprintf buffer [%i {|<section class="commit-meta panel"><h2>{%s html subject}</h2>|} ];
if body <> "" then Printf.bprintf buffer [%i {|<pre class="commit-body">{%s html body}</pre>|} ];
Printf.bprintf buffer
[%i
{|<dl class="commit-fields"><dt>Author</dt><dd>{%s html author} <{%s html author_email}></dd><dt>Date</dt><dd>{%s html date}</dd><dt>Commit</dt><dd><code>{%s html commit.id}</code></dd></dl></section>|} ];
Buffer.add_string buffer (render_diff (Ocaml_git.commit_diff git commit_id)));
Buffer.contents buffer
let commits_page ?(clone_base : string option) (repo : repo_info) (branch : string) : string =
Ocaml_git.with_repo repo.path @@ fun git ->
let buffer = Buffer.create 4096 in
Buffer.add_string buffer (repo_header ?clone_base repo branch "" (local_branches git) "history");
Printf.bprintf buffer [%i {|<ol class="commits">|} ];
List.iter
(fun (commit : Ocaml_git.commit) ->
let short = String.sub commit.id 0 (min 12 (String.length commit.id)) in
let href = commit_url repo branch commit.id in
Printf.bprintf buffer [%i {|<li><a href="{%s href}"><strong>{%s html commit.summary}</strong><span>{%s html short} · {%s html commit.author.name}</span></a></li>|} ])
(Ocaml_git.commits ~limit:100 git branch);
Printf.bprintf buffer [%i {|</ol>|} ];
page (branch ^ " history") (Buffer.contents buffer)
let repo_page ?(clone_base : string option) ~(pygments_command : string) (repo : repo_info) (branch : string)
(path : string) : string =
Ocaml_git.with_repo repo.path @@ fun git ->
let branches = local_branches git in
let commit = Ocaml_git.branch_commit git branch in
let entry = if path = "" then None else try Some (Ocaml_git.tree_entry ~commit git path) with _ -> None in
let content =
match entry with
| None | Some { kind = Tree; _ } -> tree_view ?clone_base ~pygments_command repo git branch path branches
| Some _ ->
blob_view ?clone_base ~pygments_command repo (Ocaml_git.blob ~commit git path) branch path branches
in
page repo.name content
let not_found (message : string) : response =
html_response 404 (page "Not found" ("<p class=\"notice\">" ^ message ^ "</p>"))
(* Route handling is kept pure so tests can cover all page decisions without
opening sockets; [start] is only responsible for adapting this to HTTP. *)
let route ?(pygments_command : string = default_pygments_command) ?(clone_base : string option)
~(root : string) (raw_path : string) : response =
let repos = discover_repos root in
let repo_by_key key = List.find_opt (fun repo -> repo.key = key) repos in
let parts = split_path raw_path in
try
match parts with
| [] ->
let buffer = Buffer.create 4096 in
Printf.bprintf buffer [%i {|<section class="hero"><p class="eyebrow">{%s html root}</p><h1>Repositories</h1></section>|} ];
if repos = [] then Buffer.add_string buffer "<p class=\"notice\">No Git repositories were found under this path.</p>"
else (
Buffer.add_string buffer "<ol class=\"repo-list\">";
List.iter
(fun repo ->
let summary = repo_summary repo in
Printf.bprintf buffer [%i {|<li><a href="{%s repo_url repo summary.branch ""}"><strong>{%s html repo.name}</strong><span>{%s html summary.branch}|} ];
if String.length summary.short_id <> 0 then Printf.bprintf buffer [%i {| · {%s html summary.short_id}|} ];
Printf.bprintf buffer [%i {|</span><small>{%s html summary.summary}</small></a></li>|} ])
repos;
Buffer.add_string buffer "</ol>");
html_response 200 (page "Repositories" (Buffer.contents buffer))
| "repo" :: repo_key :: rest -> (
let repo_key = url_decode repo_key in
match repo_by_key repo_key with
| None -> not_found ("Unknown repository " ^ html repo_key)
| Some repo -> (
match rest with
| [] ->
let branch =
Ocaml_git.with_repo repo.path @@ fun git ->
match List.find_opt (fun b -> b.Ocaml_git.is_head) (local_branches git) with
| Some b -> b.name
| None -> (
match local_branches git with
| b :: _ -> b.name
| [] -> "main")
in
html_response 200 (repo_page ?clone_base ~pygments_command repo branch "")
| branch :: "-" :: "commits" :: [] ->
html_response 200 (commits_page ?clone_base repo (url_decode branch))
| branch :: "-" :: "commit" :: id :: [] ->
let branch = url_decode branch in
let id = url_decode id in
let title = "commit " ^ String.sub id 0 (min 12 (String.length id)) in
html_response 200 (page title (commit_view ?clone_base repo branch id))
| branch :: path_parts ->
let path = path_parts |> List.map url_decode |> String.concat "/" in
html_response 200 (repo_page ?clone_base ~pygments_command repo (url_decode branch) path)))
| _ -> not_found ("No route for " ^ html raw_path)
with
| Ocaml_git.Git_error message ->
html_response 404 (page "Not found" ("<p class=\"notice\">" ^ html message ^ "</p>"))
| exn ->
html_response 500 (page "Server error" ("<p class=\"notice\">" ^ html (Printexc.to_string exn) ^ "</p>"))
(* Working trees expose their `.git/` directory; bare repositories are passed
through directly. http-backend wants GIT_PROJECT_ROOT plus a PATH_INFO that
begins with the repository's directory name. *)
let split_for_http_backend (repo : repo_info) : string * string =
if Sys.file_exists (join_path repo.path ".git") then (repo.path, ".git")
else (Filename.dirname repo.path, Filename.basename repo.path)
let cgi_split_headers_body (data : string) : (string * string) list * string =
let len = String.length data in
let rec find i =
if i + 1 >= len then None
else if data.[i] = '\n' && data.[i + 1] = '\n' then Some (i, i + 2)
else if i + 3 < len && data.[i] = '\r' && data.[i + 1] = '\n' && data.[i + 2] = '\r' && data.[i + 3] = '\n'
then Some (i, i + 4)
else find (i + 1)
in
match find 0 with
| None -> ([], data)
| Some (header_end, body_start) ->
let headers_str = String.sub data 0 header_end in
let body = String.sub data body_start (len - body_start) in
let strip_cr s =
let l = String.length s in
if l > 0 && s.[l - 1] = '\r' then String.sub s 0 (l - 1) else s
in
let lines = String.split_on_char '\n' headers_str |> List.map strip_cr in
let headers =
List.filter_map
(fun line ->
match String.index_opt line ':' with
| None -> None
| Some idx ->
let key = String.trim (String.sub line 0 idx) in
let value = String.trim (String.sub line (idx + 1) (String.length line - idx - 1)) in
if key = "" then None else Some (key, value))
lines
in
(headers, body)
let cgi_extract_status (headers : (string * string) list) : int * (string * string) list =
let is_status (key, _) = String.lowercase_ascii key = "status" in
match List.find_opt is_status headers with
| None -> (200, headers)
| Some (_, raw) ->
let value = match String.split_on_char ' ' raw with first :: _ -> first | [] -> "" in
let code = int_of_string_opt value |> Option.value ~default:200 in
(code, List.filter (fun h -> not (is_status h)) headers)
let read_fd_all (fd : Unix.file_descr) : string =
let buffer = Buffer.create 4096 in
let bytes = Bytes.create 4096 in
let rec loop () =
match Unix.read fd bytes 0 (Bytes.length bytes) with
| 0 -> ()
| n ->
Buffer.add_subbytes buffer bytes 0 n;
loop ()
| exception Unix.Unix_error (Unix.EINTR, _, _) -> loop ()
in
loop ();
Buffer.contents buffer
let write_fd_all (fd : Unix.file_descr) (data : string) : unit =
let len = String.length data in
let rec loop offset =
if offset >= len then ()
else
match Unix.write_substring fd data offset (len - offset) with
| n -> loop (offset + n)
| exception Unix.Unix_error (Unix.EINTR, _, _) -> loop offset
in
loop 0
(* Spawns `git http-backend` as a CGI process. stdin is fully written before
stdout is read, which is fine because the upload-pack request body is small
(negotiation only) and http-backend consumes it before producing output. *)
let run_http_backend ~(env : string array) ~(stdin_data : string) : int * string =
let in_r, in_w = Unix.pipe () in
let out_r, out_w = Unix.pipe () in
let err_r, err_w = Unix.pipe () in
Unix.set_close_on_exec in_w;
Unix.set_close_on_exec out_r;
Unix.set_close_on_exec err_r;
let pid = Unix.create_process_env "git" [| "git"; "http-backend" |] env in_r out_w err_w in
Unix.close in_r;
Unix.close out_w;
Unix.close err_w;
(try write_fd_all in_w stdin_data with _ -> ());
(try Unix.close in_w with _ -> ());
let output = read_fd_all out_r in
Unix.close out_r;
let _stderr = read_fd_all err_r in
Unix.close err_r;
let _, status = Unix.waitpid [] pid in
let exit_code = match status with Unix.WEXITED n -> n | _ -> -1 in
(exit_code, output)
let plain_response (status : int) (message : string) : response =
{ status; headers = [ ("Content-Type", "text/plain; charset=utf-8") ]; body = message }
(* Smart-HTTP serving for `git clone`. Read-only: write paths (receive-pack)
are not enabled because the spawned http-backend is given no env to allow
them. *)
let git_serve ~(root : string) ~(method_ : string) ~(content_type : string) ~(content_length : string)
~(query_string : string) ~(remote_addr : string) ~(request_body : string) (raw_path : string) : response =
match split_path raw_path with
| "git" :: encoded_key :: rest -> (
let key = url_decode encoded_key in
let repos = discover_repos root in
match List.find_opt (fun (r : repo_info) -> r.key = key) repos with
| None -> plain_response 404 "no such repository\n"
| Some repo ->
let project_root, base = split_for_http_backend repo in
let rest_decoded = List.map url_decode rest in
let rest_str = String.concat "/" rest_decoded in
let path_info = "/" ^ base ^ if rest_str = "" then "" else "/" ^ rest_str in
let path_env = Sys.getenv_opt "PATH" |> Option.value ~default:"/usr/local/bin:/usr/bin:/bin" in
let home_env = Sys.getenv_opt "HOME" |> Option.value ~default:"/tmp" in
let env =
[|
"GATEWAY_INTERFACE=CGI/1.1";
"SERVER_PROTOCOL=HTTP/1.1";
"REQUEST_METHOD=" ^ method_;
"GIT_PROJECT_ROOT=" ^ project_root;
"PATH_INFO=" ^ path_info;
"QUERY_STRING=" ^ query_string;
"CONTENT_TYPE=" ^ content_type;
"CONTENT_LENGTH=" ^ content_length;
"REMOTE_ADDR=" ^ remote_addr;
"GIT_HTTP_EXPORT_ALL=1";
"PATH=" ^ path_env;
"HOME=" ^ home_env;
|]
in
let exit_code, output = run_http_backend ~env ~stdin_data:request_body in
let headers, body = cgi_split_headers_body output in
let status, header_list = cgi_extract_status headers in
let status = if exit_code <> 0 && status = 200 then 500 else status in
let header_list =
if List.exists (fun (k, _) -> String.lowercase_ascii k = "content-type") header_list then header_list
else ("Content-Type", "application/octet-stream") :: header_list
in
{ status; headers = header_list; body })
| _ -> plain_response 404 "not found\n"
let start (config : config) : unit =
Logs.set_reporter (Logs_fmt.reporter ());
Logs_threaded.enable ();
Logs.Src.set_level Cohttp_eio.src (Some Logs.Info);
Logs.Src.set_level access_src (Some Logs.Info);
Eio_main.run @@ fun env ->
Eio.Switch.run @@ fun sw ->
let net = Eio.Stdenv.net env in
let ipaddr =
match config.host with
| "127.0.0.1" | "localhost" -> Eio.Net.Ipaddr.V4.loopback
| "0.0.0.0" -> Eio.Net.Ipaddr.V4.any
| "::1" -> Eio.Net.Ipaddr.V6.loopback
| "::" -> Eio.Net.Ipaddr.V6.any
| other -> invalid_arg ("unsupported listen host: " ^ other)
in
let sockaddr = `Tcp (ipaddr, config.port) in
let socket = Eio.Net.listen ~sw ~reuse_addr:true ~backlog:128 net sockaddr in
Printf.printf "gitweb2 serving repositories from %s at http://%s:%d/\n%!" config.root config.host config.port;
let server =
Cohttp_eio.Server.make
~callback:(fun conn request body ->
let client = snd (fst conn) in
let started = Unix.gettimeofday () in
let resource = Cohttp.Request.resource request in
let meth = Cohttp.Request.meth request in
let version = Cohttp.Request.version request in
let uri = Uri.of_string resource in
let path = Uri.path uri in
let query = Uri.verbatim_query uri |> Option.value ~default:"" in
let req_headers = Cohttp.Request.headers request in
let header value = Cohttp.Header.get req_headers value |> Option.value ~default:"" in
let strip_trailing_slash s =
let n = String.length s in
if n > 0 && s.[n - 1] = '/' then String.sub s 0 (n - 1) else s
in
let clone_base =
match config.public_url with
| Some url -> Some (strip_trailing_slash url)
| None ->
let host = header "host" in
if host = "" then None else Some ("http://" ^ host)
in
let response =
if String.starts_with ~prefix:"/git/" path then
let request_body =
try Eio.Buf_read.of_flow ~max_size:max_int body |> Eio.Buf_read.take_all with _ -> ""
in
let remote_addr =
match client with
| `Tcp (ip, _) -> Format.asprintf "%a" Eio.Net.Ipaddr.pp ip
| _ -> ""
in
git_serve ~root:config.root
~method_:(Cohttp.Code.string_of_method meth)
~content_type:(header "content-type")
~content_length:(header "content-length")
~query_string:query ~remote_addr ~request_body path
else route ~pygments_command:config.pygments_command ?clone_base ~root:config.root path
in
let elapsed_ms = (Unix.gettimeofday () -. started) *. 1000. in
let size = String.length response.body in
Logs.info ~src:access_src (fun m ->
m "%a \"%s %s %s\" %d %d %.1fms" Eio.Net.Sockaddr.pp client (Cohttp.Code.string_of_method meth)
resource (Cohttp.Code.string_of_version version) response.status size elapsed_ms);
let headers =
List.fold_left (fun h (k, v) -> Cohttp.Header.add h k v) (Cohttp.Header.init ()) response.headers
in
Cohttp_eio.Server.respond_string ~headers ~status:(`Code response.status) ~body:response.body ())
()
in
Cohttp_eio.Server.run socket server
~on_error:(fun exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn)))
let usage : string =
"usage: gitweb2 <repo-root> [--host 127.0.0.1] [--port 8080] [--pygments pygmentize] [--public-url \
https://git.example.com]"
let parse_args (argv : string array) : (config, string) result =
let args = Array.to_list argv |> List.tl in
match args with
| [] | ("-h" | "--help") :: _ -> Error usage
| root :: rest ->
let rec loop host port pygments public_url = function
| [] -> Ok { root; host; port; pygments_command = pygments; public_url }
| "--host" :: value :: tail -> loop value port pygments public_url tail
| "--port" :: value :: tail -> (
match int_of_string_opt value with
| Some port -> loop host port pygments public_url tail
| None -> Error "missing or invalid --port value")
| "--pygments" :: value :: tail -> loop host port value public_url tail
| "--public-url" :: value :: tail -> loop host port pygments (Some value) tail
| flag :: _ -> Error ("unknown argument " ^ flag)
in
loop default_host default_port default_pygments_command None rest
let run (argv : string array) : unit =
match parse_args argv with
| Ok config -> start config
| Error message ->
prerr_endline message;
if message <> usage then exit 2