1 (** Request handlers: the seam between Git data and rendered pages. 2 3 Each handler opens exactly one repository context, reads what its page 4 needs, renders it, and closes the context — so the Git store, resolved 5 metadata and default-branch policy are shared by every operation in a 6 request instead of being reopened per query. 7 8 Errors keep the category {!module:Resolvers} gave them until they reach 9 {!error_response}, which is the single place a category becomes an HTTP 10 status: malformed input is [400], a missing repository or object is [404], 11 and storage failures are [500]. Handlers therefore never choose a status 12 themselves. 13 14 This is also the only layer allowed to touch both configuration and the 15 filesystem; views receive plain values. *) 16 17 (** Map a resolver failure to the status and wording shown to the reader. 18 Internal failures are deliberately vague, since their detail is for the 19 server log rather than the visitor. *) 20 let error_response error = 21 let status, title, message = 22 match error with 23 | Resolvers.Bad_request raw -> (`Bad_Request, "Bad request", raw) 24 | Resolvers.Not_found raw -> (`Not_Found, "Not found", raw) 25 | Resolvers.Store_error _ -> 26 ( `Internal_Server_Error, 27 "Internal server error", 28 "An unexpected error occurred while reading repository data." ) 29 | Resolvers.Internal _ -> 30 ( `Internal_Server_Error, 31 "Internal server error", 32 "An unexpected error occurred." ) 33 in 34 Views.error_page ~status ~title message 35 36 (* The configured title wins; otherwise derive one from the user name. Named for 37 the resolution it performs, to distinguish it from the [root_title] fields it 38 reads and writes. *) 39 let resolve_root_title config = 40 if config.Config.root_title = "" then 41 if config.Config.user_name = "" then "Repositories" 42 else "Repositories for " ^ config.Config.user_name 43 else config.Config.root_title 44 45 let site config = 46 Layout.site ~user_name:config.Config.user_name 47 ~root_title:(resolve_root_title config) 48 ~nav_logo:config.Config.nav_logo 49 50 let collect_repo_paths ?(prefix = "") nodes = 51 let rec walk current_prefix acc = function 52 | Resolvers.Repo { repo_name; _ } -> 53 let full = 54 if current_prefix = "" then repo_name 55 else current_prefix ^ "/" ^ repo_name 56 in 57 full :: acc 58 | Resolvers.Directory (dir_name, children) -> 59 let p = 60 if current_prefix = "" then dir_name 61 else current_prefix ^ "/" ^ dir_name 62 in 63 List.fold_left (walk p) acc children 64 in 65 List.fold_left (walk prefix) [] nodes |> List.rev 66 67 (* Head commit dates for the repository list pages, keyed by (path, head 68 hash). Any new commit changes the key, so an entry can never go stale. *) 69 let date_cache : (int64 * Git.User.tz_offset option) option Cache.t = 70 Cache.create ~capacity:1024 71 72 let fetch_repo_dates config repo_paths = 73 let open Lwt.Syntax in 74 let fetch path = 75 Lwt.bind (Resolvers.open_repository config path) @@ function 76 | Error _ -> Lwt.return None 77 | Ok repository -> 78 let* date = Resolvers.head_commit_date repository in 79 let* () = Resolvers.close_repository repository in 80 Lwt.return date 81 in 82 Lwt_list.map_p 83 (fun path -> 84 match Resolvers.head_hash_hint config path with 85 | None -> 86 let* date = fetch path in 87 Lwt.return (path, date) 88 | Some head -> ( 89 let key = path ^ "\x00" ^ head in 90 match Cache.find date_cache key with 91 | Some date -> Lwt.return (path, date) 92 | None -> 93 let* date = fetch path in 94 Cache.add date_cache key date; 95 Lwt.return (path, date))) 96 repo_paths 97 98 let root config _request = 99 match Resolvers.scan_project_root config with 100 | Ok nodes -> 101 let open Lwt.Syntax in 102 let repo_paths = collect_repo_paths nodes in 103 let* dates = fetch_repo_dates config repo_paths in 104 let node_name = function 105 | Resolvers.Repo { repo_name; _ } -> repo_name 106 | Resolvers.Directory (dir_name, _) -> dir_name ^ "/" 107 in 108 let strip_dot_git name = 109 if String.ends_with ~suffix:".git" name then 110 String.sub name 0 (String.length name - 4) 111 else name 112 in 113 let name_matches config_entry node_name = 114 (* Directories end with '/' — match exactly *) 115 if String.ends_with ~suffix:"/" node_name then node_name = config_entry 116 else 117 (* Repos: match with or without .git suffix *) 118 strip_dot_git node_name = strip_dot_git config_entry 119 in 120 let is_in_list config_list node = 121 let name = node_name node in 122 List.exists (fun entry -> name_matches entry name) config_list 123 in 124 let is_favorite node = 125 is_in_list config.Config.favorite_repositories node 126 in 127 let is_archived node = 128 is_in_list config.Config.archived_repositories node 129 in 130 let favorites, rest = List.partition is_favorite nodes in 131 let archived, regular = List.partition is_archived rest in 132 (* Preserve the order specified in the config for favorites *) 133 let sorted_favorites = 134 List.filter_map 135 (fun entry -> 136 List.find_opt (fun n -> name_matches entry (node_name n)) favorites) 137 config.Config.favorite_repositories 138 in 139 let readme = Resolvers.read_root_readme config in 140 Views.root (site config) ~dates ~favorites:sorted_favorites ~archived 141 ?readme regular 142 | Error error -> error_response error 143 144 module Repo = struct 145 let ( let* ) result continue = 146 Lwt.bind result @@ function 147 | Ok value -> continue value 148 | Error error -> error_response error 149 150 let view_context config repository = 151 Views.Repo.context ~site:(site config) 152 ~repo:(Resolvers.repository_name repository) 153 ~description:(Resolvers.repository_description repository) 154 155 let with_repository config name continue = 156 Lwt.bind (Resolvers.open_repository config name) @@ function 157 | Error error -> error_response error 158 | Ok repository -> 159 let context = view_context config repository in 160 Lwt.finalize 161 (fun () -> continue repository context) 162 (fun () -> Resolvers.close_repository repository) 163 164 let summary _config repository context = 165 let* readme = Resolvers.Repo.readme repository in 166 Views.Repo.summary context ?readme () 167 168 let commit_matches ?filter_type ?author ?committer 169 (commit : Resolvers.Commit.t) = 170 let type_matches = 171 match filter_type with 172 | None -> true 173 | Some expected -> 174 let summary = 175 match commit.message with 176 | None -> "" 177 | Some message -> ( 178 match String.split_on_char '\n' message with 179 | [] -> "" 180 | summary :: _ -> summary) 181 in 182 let commit_type, _ = Commit_message.parse_conventional summary in 183 commit_type = Some expected 184 in 185 let author_matches = 186 match author with 187 | None -> true 188 | Some email -> String.equal commit.author.email email 189 in 190 let committer_matches = 191 match committer with 192 | None -> true 193 | Some email -> String.equal commit.committer.email email 194 in 195 type_matches && author_matches && committer_matches 196 197 let commits config request repository context = 198 let page_size = config.Config.commits_max_displayed in 199 let filter_type = Dream.query request "type" in 200 let author = Dream.query request "author" in 201 let committer = Dream.query request "committer" in 202 (* The query parameter keeps its short name; the binding says what it is. *) 203 let page_number = 204 let ( >>= ) = Option.bind in 205 Dream.query request "page" >>= int_of_string_opt 206 >>= (fun p -> if p > 0 then Some p else None) 207 |> Option.value ~default:1 208 in 209 let offset = (page_number - 1) * page_size in 210 (* Fetch one beyond orphan threshold to detect whether more exist *) 211 let fetch_count = offset + page_size + 11 in 212 let predicate = commit_matches ?filter_type ?author ?committer in 213 let* all_commits, truncated = 214 Resolvers.Commit.recent_matching repository fetch_count predicate 215 in 216 let total = List.length all_commits in 217 let after_offset = 218 if offset >= total then [] else List_ext.drop offset all_commits 219 in 220 let remaining = List.length after_offset in 221 (* Avoid a final page with fewer than 10 items — absorb them into this 222 page instead, so users don't paginate for a near-empty last page. *) 223 let effective_size = 224 if remaining > page_size && remaining <= page_size + 10 then remaining 225 else page_size 226 in 227 let page_commits = List_ext.take effective_size after_offset in 228 let has_next = remaining > effective_size in 229 let has_prev = page_number > 1 in 230 Views.Repo.commits ?filter_type ?author ?committer ~truncated ~page_number 231 ~has_prev ~has_next context page_commits 232 233 let commits_branch config repository context branch = 234 let page_size = config.Config.commits_max_displayed in 235 let* reference = Resolvers.Reference.of_id repository branch in 236 let fetch_count = page_size + 11 in 237 let* commits = 238 Resolvers.Commit.recent_from repository reference.hash fetch_count 239 in 240 let remaining = List.length commits in 241 let effective_size = 242 if remaining > page_size && remaining <= page_size + 10 then remaining 243 else page_size 244 in 245 let page_commits = List_ext.take effective_size commits in 246 let has_next = remaining > effective_size in 247 Views.Repo.commits ~page_number:1 ~has_prev:false ~has_next context 248 page_commits 249 250 let commit_id repository context id = 251 let* commit = Resolvers.Commit.of_id repository id in 252 let* diff = Resolvers.Diff.of_commit repository commit in 253 Views.Repo.commit context commit diff 254 255 let files_at_head repository context = 256 let* tree = Resolvers.Tree.head repository in 257 let* nodes = Resolvers.Tree.expand repository tree in 258 Views.Repo.files context [] nodes 259 260 let file_id repository context id = 261 let* trail = Resolvers.Tree.find_path repository id in 262 let* object_ = Resolvers.blob_or_tree repository id in 263 match object_ with 264 | `Tree tree -> 265 let* nodes = Resolvers.Tree.expand repository tree in 266 Views.Repo.files context trail nodes 267 | `Blob blob -> Views.Repo.file context trail blob 268 269 let file_at repository context path = 270 let* object_, trail = Resolvers.object_at_path repository path in 271 match object_ with 272 | `Tree tree -> 273 let* nodes = Resolvers.Tree.expand repository tree in 274 Views.Repo.files context trail nodes 275 | `Blob blob -> Views.Repo.file context trail blob 276 277 let mime_of_filename filename = 278 match Filename.extension filename |> String.lowercase_ascii with 279 | ".png" -> "image/png" 280 | ".jpg" | ".jpeg" -> "image/jpeg" 281 | ".gif" -> "image/gif" 282 | ".svg" -> "image/svg+xml" 283 | ".webp" -> "image/webp" 284 | ".ico" -> "image/x-icon" 285 | ".bmp" -> "image/bmp" 286 | ".avif" -> "image/avif" 287 | _ -> "text/plain; charset=utf-8" 288 289 (* Raw blobs are repository content served from ogit's own origin. The 290 sandbox policy stops any active content — an SVG carrying a script is the 291 canonical case — from running with the site's authority, and [nosniff] 292 stops browsers from promoting text/plain to something executable. *) 293 let raw_headers content_type = 294 [ 295 ("Content-Type", content_type); 296 ("Content-Security-Policy", "sandbox"); 297 ("X-Content-Type-Options", "nosniff"); 298 ] 299 300 let raw_file repository _context id = 301 let* trail = Resolvers.Tree.find_path repository id in 302 let* object_ = Resolvers.blob_or_tree repository id in 303 match object_ with 304 | `Blob blob -> 305 let content_type = 306 match List.rev trail with 307 | (name, _) :: _ -> mime_of_filename name 308 | [] -> "text/plain; charset=utf-8" 309 in 310 Lwt.return 311 (Dream.response ~headers:(raw_headers content_type) blob.content) 312 | `Tree _ -> 313 error_response (Resolvers.Bad_request "object is a tree, not a blob") 314 315 let raw_at repository _context path = 316 let* object_, _trail = Resolvers.object_at_path repository path in 317 match object_ with 318 | `Blob blob -> 319 let content_type = 320 match List.rev (String.split_on_char '/' path) with 321 | name :: _ -> mime_of_filename name 322 | [] -> "text/plain; charset=utf-8" 323 in 324 Lwt.return 325 (Dream.response ~headers:(raw_headers content_type) blob.content) 326 | `Tree _ -> 327 error_response (Resolvers.Bad_request "path names a tree, not a file") 328 end 329 330 let project_dir config subdir = 331 match Resolvers.scan_subdirectory config subdir with 332 | Ok nodes -> 333 let open Lwt.Syntax in 334 let repo_paths = collect_repo_paths ~prefix:subdir nodes in 335 let* dates = fetch_repo_dates config repo_paths in 336 let readme = Resolvers.read_subdir_readme config subdir in 337 Views.root (site config) ~dates ~prefix:subdir ?readme nodes 338 | Error error -> error_response error 339 340 (* Rendered pages are memoized per repository head: the key embeds the hash 341 HEAD names, so any new commit changes the key and an entry can never serve 342 a moved branch's old content. What CAN go stale until eviction is metadata 343 outside the object store — the description file — which is accepted. 344 Requests whose head cannot be resolved cheaply are served uncached. *) 345 let page_cache : (Dream.status * (string * string) list * string) Cache.t = 346 Cache.create ~capacity:256 347 348 (* Raw blobs pass through here too; the size cap keeps a handful of large 349 files from occupying the whole cache. *) 350 let max_cacheable_body_bytes = 512 * 1024 351 352 let respond_cached config name request serve = 353 match Resolvers.head_hash_hint config name with 354 | None -> serve () 355 | Some head -> ( 356 let key = String.concat "\x00" [ name; head; Dream.target request ] in 357 match Cache.find page_cache key with 358 | Some (status, headers, body) -> 359 Lwt.return (Dream.response ~status ~headers body) 360 | None -> 361 let open Lwt.Syntax in 362 let* response = serve () in 363 let* body = Dream.body response in 364 let status = Dream.status response in 365 let headers = Dream.all_headers response in 366 if 367 Dream.status_to_int status = 200 368 && String.length body <= max_cacheable_body_bytes 369 then Cache.add page_cache key (status, headers, body); 370 Lwt.return (Dream.response ~status ~headers body)) 371 372 (* The repository a route is scoped to, or [None] for the root page, which 373 depends on every repository and is not cached. *) 374 let route_repo = function 375 | Routes.Root -> None 376 | Routes.Project_dir name 377 | Routes.Repo name 378 | Routes.Commits name 379 | Routes.Commits_branch (name, _) 380 | Routes.Commit (name, _) 381 | Routes.Files name 382 | Routes.File (name, _) 383 | Routes.File_at (name, _) 384 | Routes.Raw_file (name, _) 385 | Routes.Raw_at (name, _) -> 386 Some name 387 388 let routes config = 389 let repo_dispatcher request = 390 let path = Dream.target request in 391 (* Strip leading slash and query string *) 392 let path = 393 if String.starts_with ~prefix:"/" path then 394 String.sub path 1 (String.length path - 1) 395 else path 396 in 397 let path = 398 match String.index_opt path '?' with 399 | None -> path 400 | Some i -> String.sub path 0 i 401 in 402 (* A path without a reserved segment names either a repository (serve its 403 summary) or a directory of repositories (serve the listing). The 404 filesystem decides: a name that opens as a repository is one. *) 405 let summary_or_directory name = 406 Lwt.bind (Resolvers.open_repository config name) (function 407 | Error (Resolvers.Not_found _) -> project_dir config name 408 | Error error -> error_response error 409 | Ok repository -> 410 let context = Repo.view_context config repository in 411 Lwt.finalize 412 (fun () -> Repo.summary config repository context) 413 (fun () -> Resolvers.close_repository repository)) 414 in 415 match Routes.dispatch path with 416 | None -> error_response (Not_found ("not found: " ^ Dream.target request)) 417 | Some route -> ( 418 let serve () = 419 match route with 420 | Routes.Root -> root config request 421 | Routes.Project_dir name | Routes.Repo name -> 422 summary_or_directory name 423 | Routes.Commits name -> 424 Repo.with_repository config name (fun repository context -> 425 Repo.commits config request repository context) 426 | Routes.Commits_branch (name, branch) -> 427 Repo.with_repository config name (fun repository context -> 428 Repo.commits_branch config repository context branch) 429 | Routes.Commit (name, hash) -> 430 Repo.with_repository config name (fun repository context -> 431 Repo.commit_id repository context hash) 432 | Routes.Files name -> 433 Repo.with_repository config name Repo.files_at_head 434 | Routes.File (name, hash) -> 435 Repo.with_repository config name (fun repository context -> 436 Repo.file_id repository context hash) 437 | Routes.File_at (name, path) -> 438 Repo.with_repository config name (fun repository context -> 439 Repo.file_at repository context path) 440 | Routes.Raw_file (name, hash) -> 441 Repo.with_repository config name (fun repository context -> 442 Repo.raw_file repository context hash) 443 | Routes.Raw_at (name, path) -> 444 Repo.with_repository config name (fun repository context -> 445 Repo.raw_at repository context path) 446 in 447 match route_repo route with 448 | None -> serve () 449 | Some name -> respond_cached config name request serve) 450 in 451 [ 452 Dream.get "/" (root config); 453 Dream.get "/static/**" Static_handler.handler; 454 Dream.get "/**" repo_dispatcher; 455 ] 456