1 (** The repository pages: summary, commit list, file tree, blob, commit detail, 2 branches and tags. 3 4 Each page is a description: it names the parts it is made of and hands them 5 to {!Layout}. Markup lives in {!Ui}, ogit's page parts in {!Components}, 6 language guessing in {!Syntax}, and date formatting in {!Time_format}. *) 7 8 type context = { repo : string; description : string; site : Layout.site } 9 (** What every repository page needs to know about its subject. *) 10 11 type commit_message = Commit_message.t = { summary : string; body : string } 12 13 let context ~site ~repo ~description = { repo; description; site } 14 15 (** {1 Commit messages} *) 16 17 let parse_commit_message = Commit_message.parse 18 let parse_conventional = Commit_message.parse_conventional 19 20 (** {1 Links into the commit list} *) 21 22 let commits_url = Components.commits_url 23 24 (** A person's name, linking to the commits attributed to them. Keeps the other 25 active filters intact so identities compose with type filters. *) 26 let identity_link ?filter_type ?author ?committer ?(show_email = false) ~role 27 repo (user : Resolvers.Commit.user) = 28 let href, role_name = 29 match role with 30 | `Author -> 31 (commits_url ?filter_type ~author:user.email ?committer repo, "author") 32 | `Committer -> 33 ( commits_url ?filter_type ?author ~committer:user.email repo, 34 "committer" ) 35 in 36 Ui.text_link ~class_:"commit-identity" 37 ~label:(Printf.sprintf "Filter commits by %s %s" role_name user.name) 38 ~href 39 (if show_email then Printf.sprintf "%s <%s>" user.name user.email 40 else user.name) 41 42 (** {1 Page shell} *) 43 44 let page_title context = context.repo ^ " — " ^ context.description 45 46 let render_page ?heading ?(toolbar = []) context ~active content = 47 Ui.respond 48 @@ Layout.render context.site ~page_title:(page_title context) 49 { 50 repo = Some context.repo; 51 title = Option.value heading ~default:context.repo; 52 subtitle = context.description; 53 active; 54 toolbar; 55 home_href = None; 56 content; 57 } 58 59 (** {1 Rows} *) 60 61 (** One line of the commit list: when it happened, what changed, and who did it. 62 63 @param hide_pill 64 suppresses the type badge when the list is already filtered to a single 65 type, where repeating it on every row adds nothing. 66 @param author 67 when filtering by author, the author column is dropped for the same 68 reason. *) 69 let commit_row ?filter_type ?author ?committer ?(hide_pill = false) repo 70 (commit : Resolvers.Commit.t) = 71 let message = parse_commit_message commit.message in 72 let commit_type, title = parse_conventional message.summary in 73 let badge = 74 match commit_type with 75 | Some commit_type when not hide_pill -> 76 Components.commit_type_badge 77 ~href:(commits_url ~filter_type:commit_type ?author ?committer repo) 78 commit_type 79 | _ -> Ui.nothing 80 in 81 Ui.item 82 [ 83 Ui.inline_text ~class_:"timestamp" 84 (Time_format.short_time commit.author.date); 85 badge; 86 Ui.inline ~class_:"commit-title" 87 [ Components.route_link (Commit (repo, commit.hash)) title ]; 88 Ui.inline_text ~class_:"commit-ago" 89 (Time_format.relative_time commit.author.date); 90 (match author with 91 | Some _ -> Ui.nothing 92 | None -> 93 Ui.inline ~class_:"commit-author" 94 [ 95 identity_link ?filter_type ?author ?committer ~role:`Author repo 96 commit.author; 97 ]); 98 ] 99 100 (** Directories with more than seven entries show three children and a link to 101 the full directory page, keeping the tree scannable without hiding anything 102 permanently. The repository root is exempt — it always shows all entries. *) 103 let tree_truncation_threshold = 7 104 105 let tree_display_limit = 3 106 107 let rec tree_row repo ~prefix (node : Resolvers.Tree.tree_node) = 108 let entry = node.entry in 109 (* Entry names may span several segments when single-child directories were 110 collapsed, so appending them to the prefix always yields the full path. *) 111 let path = if prefix = "" then entry.name else prefix ^ "/" ^ entry.name in 112 let route = Routes.File_at (repo, path) in 113 (* Dotfiles stay visible but are de-emphasised. *) 114 let modifier = 115 if String.length entry.name > 0 && entry.name.[0] = '.' then "tree-hidden" 116 else "" 117 in 118 match node.children with 119 | None -> Components.file_entry ~modifier ~route entry.name 120 | Some children -> 121 let total = List.length children in 122 let shown, omitted = 123 if total <= tree_truncation_threshold then (children, 0) 124 else 125 (List_ext.take tree_display_limit children, total - tree_display_limit) 126 in 127 let overflow = 128 if omitted = 0 then [] else [ Components.overflow_row ~route omitted ] 129 in 130 Components.directory ~modifier ~route ~name:entry.name 131 (List.map (tree_row repo ~prefix:path) shown @ overflow) 132 133 (** {1 Trails} *) 134 135 (** The path from the repository root to the entry being viewed. Each crumb 136 links to the accumulated path, so intermediate directories resolve by name 137 rather than by object id. *) 138 let path_trail repo (trail : (string * string) list) = 139 let repo_name = 140 match List.rev (String.split_on_char '/' repo) with 141 | name :: _ -> name 142 | [] -> repo 143 in 144 let root = Ui.crumb ~href:(Components.url (Files repo)) repo_name in 145 let entries = 146 let rec go prefix acc = function 147 | [] -> List.rev acc 148 | (name, _hash) :: rest -> 149 let path = if prefix = "" then name else prefix ^ "/" ^ name in 150 let crumb = 151 Ui.crumb ~href:(Components.url (File_at (repo, path))) name 152 in 153 go path (crumb :: acc) rest 154 in 155 go "" [] trail 156 in 157 Ui.breadcrumb ~class_:"path-pill" ~link_class:"path-pill-link" 158 ~separator_class:"path-pill-sep" ~separator:"/" (root :: entries) 159 160 (** {1 Pages} *) 161 162 let summary context ?readme () = 163 let readme_panel = 164 match readme with 165 | None -> Ui.nothing 166 | Some (readme : Resolvers.Readme.t) -> 167 Components.inline_readme ~filename:readme.name readme.content 168 in 169 render_page context ~active:Summary ~toolbar:[] [ readme_panel ] 170 171 let commits ?filter_type ?author ?committer ?(truncated = false) ~page_number 172 ~has_prev ~has_next context commits = 173 (* Each active filter offers a control that clears just itself, leaving the 174 others applied. *) 175 let active_filters = 176 (match filter_type with 177 | None -> [] 178 | Some commit_type -> 179 [ 180 ( "commit type", 181 commit_type, 182 commits_url ?author ?committer context.repo, 183 "commit-pill commit-pill-" ^ commit_type ); 184 ]) 185 @ (match author with 186 | None -> [] 187 | Some email -> 188 [ 189 ( "author", 190 "Author: " ^ email, 191 commits_url ?filter_type ?committer context.repo, 192 "toolbar-filter-value" ); 193 ]) 194 @ 195 match committer with 196 | None -> [] 197 | Some email -> 198 [ 199 ( "committer", 200 "Committer: " ^ email, 201 commits_url ?filter_type ?author context.repo, 202 "toolbar-filter-value" ); 203 ] 204 in 205 let filters = 206 match active_filters with 207 | [] -> [] 208 | filters -> 209 [ 210 Ui.block ~class_:"toolbar-filters" 211 (List.map 212 (fun (name, value, dismiss_href, value_class) -> 213 Ui.dismissible ~value_class ~dismiss_href 214 ~dismiss_label:(Printf.sprintf "Remove %s filter" name) 215 value) 216 filters); 217 ] 218 in 219 let page_url n = 220 commits_url ?filter_type ?author ?committer ~page_number:n context.repo 221 in 222 let pagination = 223 if not (has_prev || has_next) then [] 224 else 225 [ 226 Ui.pagination 227 ?previous_href: 228 (if has_prev then Some (page_url (page_number - 1)) else None) 229 ?next_href: 230 (if has_next then Some (page_url (page_number + 1)) else None) 231 page_number; 232 ] 233 in 234 render_page context ~active:Commits ~toolbar:(filters @ pagination) 235 [ 236 Ui.items_of ~id:"commit-list" 237 (commit_row 238 ~hide_pill:(Option.is_some filter_type) 239 ?filter_type ?author ?committer context.repo) 240 commits; 241 (if truncated then 242 Ui.paragraph_text ~class_:"commit-list-note" 243 "The search stopped before it reached the oldest history. Older \ 244 matching commits are not shown." 245 else Ui.nothing); 246 ] 247 248 let files context trail (entries : Resolvers.Tree.tree_node list) = 249 (* Rows link to their full path, so a listing below the root needs the trail 250 as the path prefix. *) 251 let prefix = String.concat "/" (List.map fst trail) in 252 render_page context ~active:Files 253 ~toolbar:[ path_trail context.repo trail ] 254 [ Ui.items_of ~id:"file-tree" (tree_row context.repo ~prefix) entries ] 255 256 let is_image_filename filename = 257 match Filename.extension filename |> String.lowercase_ascii with 258 | ".png" | ".jpg" | ".jpeg" | ".gif" | ".svg" | ".webp" | ".ico" | ".bmp" 259 | ".avif" -> 260 true 261 | _ -> false 262 263 let file context trail (blob : Resolvers.Blob.t) = 264 let filename = 265 match List.rev trail with (name, _) :: _ -> Some name | [] -> None 266 in 267 let full_path = String.concat "/" (List.map fst trail) in 268 let raw_url = 269 if full_path = "" then None 270 else Some (Components.url (Raw_at (context.repo, full_path))) 271 in 272 let raw_link = 273 match raw_url with 274 | Some href -> Ui.paragraph [ Ui.text_link ~href "View raw" ] 275 | None -> Ui.nothing 276 in 277 let body = 278 match filename with 279 | Some filename when is_image_filename filename -> 280 let src = Option.value raw_url ~default:"" in 281 Ui.block ~class_:"image-preview" 282 [ Ui.image ~class_:"file-image" ~alt:filename ~src () ] 283 | Some filename when Prose.Render.is_doc_filename filename -> 284 Prose.Render.render ~filename blob.content 285 | _ -> 286 let language = Highlight.Detect.detect ~filename blob.content in 287 let lines = Highlight.Engine.highlight ~lang:language blob.content in 288 Ui.highlighted_code_listing ~id:"blob" lines 289 in 290 let toolbar = [ path_trail context.repo trail ] in 291 render_page context ~active:Files ~toolbar [ raw_link; body ] 292 293 let commit context (commit : Resolvers.Commit.t) diff = 294 let message = parse_commit_message commit.message in 295 let commit_type, title = parse_conventional message.summary in 296 let number = function Some n -> string_of_int n | None -> "" in 297 let diff_line (line : Resolvers.Diff.line) : Ui.Diff.line = 298 { 299 before = number line.old_number; 300 after = number line.new_number; 301 change = 302 (match line.kind with 303 | Resolvers.Diff.Context -> Ui.Diff.Unchanged 304 | Resolvers.Diff.Addition -> Ui.Diff.Added 305 | Resolvers.Diff.Deletion -> Ui.Diff.Removed); 306 content = line.text; 307 } 308 in 309 let diff_section (hunk : Resolvers.Diff.hunk) : Ui.Diff.section = 310 { 311 section_heading = 312 Printf.sprintf "@@ -%d,%d +%d,%d @@" hunk.old_start hunk.old_count 313 hunk.new_start hunk.new_count; 314 lines = List.map diff_line hunk.lines; 315 } 316 in 317 let mode = function 318 | None -> "000000" 319 | Some mode -> Printf.sprintf "%06o" mode 320 in 321 let hash = function 322 | None -> "00000000" 323 | Some hash -> Resolvers.short_hash hash 324 in 325 let diff_file (file : Resolvers.Diff.file) : Ui.Diff.file = 326 { 327 path = file.path; 328 detail = 329 Printf.sprintf "index %s..%s %s..%s" (hash file.old_hash) 330 (hash file.new_hash) (mode file.old_mode) (mode file.new_mode); 331 sections = List.map diff_section file.hunks; 332 note = (if file.binary then Some "Binary files differ" else None); 333 } 334 in 335 let badge = 336 match commit_type with 337 | None -> Ui.nothing 338 | Some commit_type -> 339 Components.commit_type_badge 340 ~href:(commits_url ~filter_type:commit_type context.repo) 341 commit_type 342 in 343 let body = 344 if message.body = "" then [] 345 else [ Ui.paragraph_text ~class_:"commit-body" message.body ] 346 in 347 let timestamp date = 348 let machine, display = Time_format.exact_time date in 349 Ui.timestamp ~machine display 350 in 351 let metadata = 352 Ui.definitions ~class_:"commit-meta" 353 [ 354 ("Commit", [ Ui.text commit.hash ]); 355 ( "Author", 356 [ 357 identity_link ~show_email:true ~role:`Author context.repo 358 commit.author; 359 ] ); 360 ("Author date", [ timestamp commit.author.date ]); 361 ( "Committer", 362 [ 363 identity_link ~show_email:true ~role:`Committer context.repo 364 commit.committer; 365 ] ); 366 ("Committer date", [ timestamp commit.committer.date ]); 367 ] 368 in 369 render_page 370 ~heading:(context.repo ^ " : " ^ Resolvers.short_hash commit.hash) 371 context ~active:Commits 372 ((Ui.heading ~level:3 [ badge; Ui.text (" " ^ title) ] :: body) 373 @ [ metadata ] 374 @ Ui.Diff.view ~empty_message:"No file changes in this commit." 375 (List.map diff_file diff)) 376