1 module Store = Git_unix.Store 2 open Lwt_result.Syntax 3 4 type error = 5 | Bad_request of string 6 | Not_found of string 7 | Store_error of Store.error 8 | Internal of string 9 10 let pp_error formatter = function 11 | Bad_request message -> Format.fprintf formatter "%s" message 12 | Not_found message -> Format.fprintf formatter "%s" message 13 | Store_error error -> Store.pp_error formatter error 14 | Internal message -> Format.fprintf formatter "%s" message 15 16 let map_store promise = 17 Lwt.map (Result.map_error (fun error -> Store_error error)) promise 18 19 let is_hex_digit = function 20 | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true 21 | _ -> false 22 23 let is_valid_hash_hex hash = 24 String.length hash = Store.Hash.length * 2 && String.for_all is_hex_digit hash 25 26 let hash_of_hex hash = 27 if is_valid_hash_hex hash then Lwt_result.return (Store.Hash.of_hex hash) 28 else Lwt_result.fail (Bad_request ("invalid object id " ^ hash)) 29 30 let is_valid_repo_name repo = 31 let invalid_char = function '\\' | '\x00' -> true | _ -> false in 32 let valid_segment s = 33 s <> "" && s <> "." && s <> ".." && not (String.starts_with ~prefix:"." s) 34 in 35 repo <> "" 36 && (not (String.exists invalid_char repo)) 37 && String.split_on_char '/' repo |> List.for_all valid_segment 38 39 let validate_repo_name repo = 40 if is_valid_repo_name repo then Lwt_result.return repo 41 else Lwt_result.fail (Bad_request ("invalid repository name " ^ repo)) 42 43 type repository_layout = { worktree : string; git_dir : string } 44 45 let filesystem_error path error = 46 Internal (Printf.sprintf "%s: %s" path (Unix.error_message error)) 47 48 (* These report filesystem failures rather than hiding them, so that a directory 49 made unreadable by permissions is distinguishable from one that is simply not 50 a repository. A missing path is not a failure: it answers the question with 51 [false]. 52 53 The plain names belong to these error-preserving functions. It is 54 [repository_layout_or_none] below, which discards the distinction, that 55 carries the qualifier — the surprising behaviour is the one worth naming. *) 56 57 let is_directory path = 58 try Ok ((Unix.stat path).st_kind = Unix.S_DIR) with 59 | Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> Ok false 60 | Unix.Unix_error (error, _, _) -> Error (filesystem_error path error) 61 62 let file_exists path = 63 try 64 ignore (Unix.stat path); 65 Ok true 66 with 67 | Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> Ok false 68 | Unix.Unix_error (error, _, _) -> Error (filesystem_error path error) 69 70 (* A directory is a Git directory when it holds both HEAD and objects/. *) 71 let is_git_directory path = 72 let ( let* ) = Result.bind in 73 let* directory = is_directory path in 74 if not directory then Ok false 75 else 76 let* has_head = file_exists (Filename.concat path "HEAD") in 77 let* has_objects = is_directory (Filename.concat path "objects") in 78 Ok (has_head && has_objects) 79 80 (* [Ok None] means "readable, but not a repository"; [Error _] means "could not 81 tell". Keeping them apart is the whole point of this layer. *) 82 let repository_layout path = 83 let ( let* ) = Result.bind in 84 let dotgit = Filename.concat path ".git" in 85 let* worktree = is_directory path in 86 if not worktree then Ok None 87 else 88 let* non_bare = is_git_directory dotgit in 89 if non_bare then Ok (Some { worktree = path; git_dir = dotgit }) 90 else 91 let* bare = is_git_directory path in 92 if bare then Ok (Some { worktree = path; git_dir = path }) else Ok None 93 94 (** Collapse an unreadable path to [None], for the callers that cannot act on 95 the difference anyway. Prefer {!repository_layout} where the distinction 96 between "not a repository" and "could not tell" matters. *) 97 let repository_layout_or_none path = 98 match repository_layout path with Ok layout -> layout | Error _ -> None 99 100 let is_repository path = Option.is_some (repository_layout_or_none path) 101 102 let repositories config = 103 try 104 let names = Sys.readdir config.Config.git_project_root |> Array.to_list in 105 let ( let* ) = Result.bind in 106 let rec collect repositories = function 107 | [] -> Ok (List.sort String.compare repositories) 108 | name :: rest when String.starts_with ~prefix:"." name -> 109 collect repositories rest 110 | name :: rest -> 111 let path = Filename.concat config.Config.git_project_root name in 112 let* layout = repository_layout path in 113 collect 114 (if Option.is_some layout then name :: repositories 115 else repositories) 116 rest 117 in 118 collect [] names 119 with Sys_error message -> Error (Internal message) 120 121 type repo_info = { repo_name : string; description : string } 122 type fs_node = Repo of repo_info | Directory of string * fs_node list 123 124 let default_repo_description = "Unnamed repository" 125 126 let read_description_file description_path = 127 try 128 match 129 In_channel.with_open_text description_path In_channel.input_all 130 |> String.trim 131 with 132 | "" -> default_repo_description 133 | description -> description 134 with Sys_error _ -> default_repo_description 135 136 let description_of_layout { git_dir; _ } = 137 Filename.concat git_dir "description" |> read_description_file 138 139 let scan_directory root_path = 140 let ( let* ) = Result.bind in 141 let rec scan dir_path = 142 try 143 let names = 144 Sys.readdir dir_path |> Array.to_list |> List.sort String.compare 145 in 146 let rec collect acc = function 147 | [] -> Ok (List.rev acc) 148 | name :: rest when String.starts_with ~prefix:"." name -> 149 collect acc rest 150 | name :: rest -> ( 151 let path = Filename.concat dir_path name in 152 let* is_dir = is_directory path in 153 if not is_dir then collect acc rest 154 else 155 let* layout = repository_layout path in 156 match layout with 157 | Some layout -> 158 let description = description_of_layout layout in 159 collect (Repo { repo_name = name; description } :: acc) rest 160 | None -> 161 let* children = scan path in 162 if children = [] then collect acc rest 163 else collect (Directory (name, children) :: acc) rest) 164 in 165 collect [] names 166 with Sys_error message -> Error (Internal message) 167 in 168 scan root_path 169 170 let scan_project_root config = scan_directory config.Config.git_project_root 171 172 type repository = { 173 name : string; 174 store : Store.t; 175 description : string; 176 default_branch : string; 177 } 178 179 let open_repository config name = 180 let* name = validate_repo_name name in 181 let path = Filename.concat config.Config.git_project_root name in 182 match repository_layout path with 183 | Error error -> Lwt_result.fail error 184 | Ok None -> Lwt_result.fail (Not_found ("not a Git repository " ^ name)) 185 | Ok (Some ({ worktree; git_dir } as layout)) -> 186 (* ocaml-git's Store.v expects a tmp/ directory inside the git directory 187 and fails if it cannot create one. Since ogit only reads repositories, 188 we ensure the directory exists beforehand so that Store.v succeeds even 189 when the process lacks write access to the repository root. *) 190 (let tmp = Filename.concat git_dir "tmp" in 191 try Unix.mkdir tmp 0o755 with Unix.Unix_error _ -> ()); 192 let* store = 193 map_store (Store.v ~dotgit:(Fpath.v git_dir) (Fpath.v worktree)) 194 in 195 Lwt_result.return 196 { 197 name; 198 store; 199 description = description_of_layout layout; 200 default_branch = config.Config.default_branch; 201 } 202 203 let repository_name repository = repository.name 204 let repository_description repository = repository.description 205 let close_repository repository = Store.close_pack_files repository.store 206 let short_hash hash = String.sub hash 0 (min 8 (String.length hash)) 207 let branch_ref name = Git.Reference.v ("refs/heads/" ^ name) 208 209 let fallback_branch_candidates_for default_branch = 210 List.fold_left 211 (fun candidates name -> 212 if List.mem name candidates then candidates else candidates @ [ name ]) 213 [] 214 [ default_branch; "main"; "master" ] 215 216 let fallback_branch_candidates config = 217 fallback_branch_candidates_for config.Config.default_branch 218 219 (** Parse a [packed-refs] file and return all entries as [(hex, refname)] 220 pairs. This is the shared primitive used both by [resolve_head_hash] (which 221 needs branch references for its fallback) and by [Reference.refs_by_prefix] 222 (which enumerates branches and tags for the UI). 223 224 [Store.Ref.list] only walks the filesystem for loose reference files; when a 225 repository has been garbage-collected or was received as a pack, all refs 226 live exclusively in [packed-refs] and are invisible to it. *) 227 let read_packed_refs_at git_dir = 228 let path = Filename.concat git_dir "packed-refs" in 229 try 230 In_channel.with_open_text path @@ fun ic -> 231 let rec collect acc = 232 match In_channel.input_line ic with 233 | None -> List.rev acc 234 | Some line when String.length line = 0 -> collect acc 235 | Some line when line.[0] = '#' || line.[0] = '^' -> collect acc 236 | Some line -> ( 237 match String.index_opt line ' ' with 238 | None -> collect acc 239 | Some i -> 240 let hex = String.sub line 0 i in 241 let refname = 242 String.sub line (i + 1) (String.length line - i - 1) 243 in 244 collect ((hex, refname) :: acc)) 245 in 246 collect [] 247 with Sys_error _ -> [] 248 249 let read_packed_refs store = 250 read_packed_refs_at (Fpath.to_string (Store.dotgit store)) 251 252 (** Cheaply resolve the commit hash that HEAD names, using plain file reads and 253 no object store: HEAD itself, then one loose reference file, then 254 [packed-refs]. [None] means "could not tell cheaply" — callers must fall 255 back to opening the repository rather than conclude anything. *) 256 let head_hash_hint config name = 257 let path = Filename.concat config.Config.git_project_root name in 258 match repository_layout_or_none path with 259 | None -> None 260 | Some { git_dir; _ } -> ( 261 let first_line file = 262 try In_channel.with_open_text file In_channel.input_line 263 with Sys_error _ -> None 264 in 265 match first_line (Filename.concat git_dir "HEAD") with 266 | None -> None 267 | Some line -> ( 268 let line = String.trim line in 269 if String.starts_with ~prefix:"ref: " line then 270 let refname = 271 String.trim (String.sub line 5 (String.length line - 5)) 272 in 273 match first_line (Filename.concat git_dir refname) with 274 | Some hex when is_valid_hash_hex (String.trim hex) -> 275 Some (String.trim hex) 276 | _ -> 277 read_packed_refs_at git_dir 278 |> List.find_opt (fun (_, packed_name) -> 279 packed_name = refname) 280 |> Option.map fst 281 else if is_valid_hash_hex line then Some line 282 else None)) 283 284 (** Branch entries from [packed-refs], returned as [(full_refname, reference)] 285 pairs suitable for [try_references]. *) 286 let packed_refs_branches store = 287 read_packed_refs store 288 |> List.filter_map (fun (_hex, refname) -> 289 if String.starts_with ~prefix:"refs/heads/" refname then 290 Some (refname, Git.Reference.v refname) 291 else None) 292 293 let resolve_head_hash repository = 294 let resolve reference = 295 map_store (Store.Ref.resolve repository.store reference) 296 in 297 let rec try_references = function 298 | [] -> 299 let open Lwt.Syntax in 300 let* references = Store.Ref.list repository.store in 301 let branches = 302 references |> List.map fst 303 |> List.filter_map (fun reference -> 304 let name = Git.Reference.to_string reference in 305 if String.starts_with ~prefix:"refs/heads/" name then 306 Some (name, reference) 307 else None) 308 in 309 (* When the store lists no loose branches, also consult packed-refs 310 so that repositories with only packed references are handled. *) 311 let branches = 312 if branches = [] then packed_refs_branches repository.store 313 else branches 314 in 315 let branches = 316 List.sort 317 (fun (left, _) (right, _) -> String.compare left right) 318 branches 319 in 320 let rec try_branches = function 321 | [] -> 322 Lwt_result.fail 323 (Not_found "no branch could be resolved for repository") 324 | (_, reference) :: rest -> ( 325 Lwt.bind (resolve reference) @@ function 326 | Ok hash -> Lwt_result.return hash 327 | Error (Store_error (`Reference_not_found _)) -> 328 try_branches rest 329 | Error error -> Lwt_result.fail error) 330 in 331 try_branches branches 332 | reference :: rest -> ( 333 Lwt.bind (resolve reference) @@ function 334 | Ok hash -> Lwt_result.return hash 335 | Error (Store_error (`Reference_not_found _)) -> try_references rest 336 | Error error -> Lwt_result.fail error) 337 in 338 Lwt.bind (resolve Git.Reference.head) @@ function 339 | Ok hash -> Lwt_result.return hash 340 | Error (Store_error (`Reference_not_found _)) -> 341 fallback_branch_candidates_for repository.default_branch 342 |> List.map branch_ref |> try_references 343 | Error error -> Lwt_result.fail error 344 345 let read_value repository hash = 346 Lwt.bind (Store.read repository.store hash) @@ function 347 | Error (`Not_found _) -> 348 Lwt_result.fail 349 (Not_found ("no object matches id " ^ Store.Hash.to_hex hash)) 350 | Error error -> Lwt_result.fail (Store_error error) 351 | Ok value -> Lwt_result.return value 352 353 let head_commit_date repository = 354 let open Lwt.Syntax in 355 let* result = 356 Lwt_result.bind (resolve_head_hash repository) @@ fun hash -> 357 Lwt.bind (Store.read repository.store hash) @@ function 358 | Error _ -> Lwt_result.return None 359 | Ok value -> ( 360 match value with 361 | Git.Value.Commit commit -> 362 let author = Store.Value.Commit.author commit in 363 Lwt_result.return (Some author.Git.User.date) 364 | _ -> Lwt_result.return None) 365 in 366 Lwt.return (Result.value result ~default:None) 367 368 module Commit = struct 369 type user = Git.User.t 370 371 type t = { 372 hash : string; 373 tree : string; 374 parents : string list; 375 author : user; 376 committer : user; 377 message : string option; 378 } 379 380 let to_t commit = 381 Store. 382 { 383 hash = Value.Commit.digest commit |> Hash.to_hex; 384 tree = Value.Commit.tree commit |> Hash.to_hex; 385 parents = Value.Commit.parents commit |> List.map Hash.to_hex; 386 author = Value.Commit.author commit; 387 committer = Value.Commit.committer commit; 388 message = Value.Commit.message commit; 389 } 390 391 let of_hash repository hash = 392 Lwt_result.bind (read_value repository hash) @@ function 393 | Git.Value.Commit commit -> Lwt_result.return (to_t commit) 394 | _ -> 395 Store.Hash.to_hex hash |> Printf.sprintf "no commit matches id %s" 396 |> fun message -> Lwt_result.fail (Not_found message) 397 398 let of_id repository id = 399 let* hash = hash_of_hex id in 400 of_hash repository hash 401 402 (* A filtered walk with a rare predicate would otherwise traverse the whole 403 history on every request. The cap bounds that work; callers learn through 404 the second component of the result that older matches may exist beyond 405 it. *) 406 let default_max_examined = 5_000 407 408 let recent_matching_from ?(max_examined = default_max_examined) repository 409 hash count predicate = 410 (* BFS traversal following all parents, ordered by author date descending. 411 The queue is kept sorted via List.merge on insertion. This is O(n) per 412 insert, but the queue length is bounded by the branch factor × count, 413 which is small in practice (most commits have 1-2 parents). *) 414 let module S = Set.Make (String) in 415 let rec walk collected seen queue remaining examined = 416 if remaining <= 0 then Lwt_result.return (List.rev collected, false) 417 else if examined >= max_examined then 418 (* Unexplored parents remain: the history was not exhausted. *) 419 Lwt_result.return (List.rev collected, queue <> []) 420 else 421 match queue with 422 | [] -> Lwt_result.return (List.rev collected, false) 423 | (_, h) :: rest -> 424 if S.mem h seen then walk collected seen rest remaining examined 425 else 426 let seen = S.add h seen in 427 let* commit = of_id repository h in 428 (* Enqueue all parents *) 429 let new_queue = 430 List.filter_map 431 (fun p -> 432 if S.mem p seen then None 433 else Some (commit.author.Git.User.date, p)) 434 commit.parents 435 in 436 (* Merge into queue sorted by date descending *) 437 let queue = 438 List.merge 439 (fun ((a_ts, _), _) ((b_ts, _), _) -> Int64.compare b_ts a_ts) 440 rest new_queue 441 in 442 let collected, remaining = 443 if predicate commit then (commit :: collected, remaining - 1) 444 else (collected, remaining) 445 in 446 walk collected seen queue remaining (examined + 1) 447 in 448 walk [] S.empty [ ((Int64.max_int, None), hash) ] count 0 449 450 let recent_from repository hash count = 451 Lwt_result.map fst 452 (recent_matching_from repository hash count (Fun.const true)) 453 454 let recent_matching ?max_examined repository count predicate = 455 let* head_hash = resolve_head_hash repository in 456 recent_matching_from ?max_examined repository 457 (Store.Hash.to_hex head_hash) 458 count predicate 459 end 460 461 module Reference = struct 462 type t = { name : string; hash : string } 463 464 let drop_prefix ~prefix name = 465 if String.starts_with ~prefix name then 466 Some 467 (String.sub name (String.length prefix) 468 (String.length name - String.length prefix)) 469 else None 470 471 let branch_name name = drop_prefix ~prefix:"refs/heads/" name 472 let tag_name name = drop_prefix ~prefix:"refs/tags/" name 473 let to_t_with_name name (_, hash) = { name; hash = Store.Hash.to_hex hash } 474 475 (** Enumerate references matching a given prefix, combining both loose 476 references (from [Store.Ref.list]) and packed references read directly 477 from the [packed-refs] file. Duplicates are removed by preferring the 478 loose entry (which takes precedence in git's resolution order). *) 479 let refs_by_prefix repository name_of_reference = 480 let open Lwt.Syntax in 481 let* references = Store.Ref.list repository.store in 482 let from_loose = 483 references 484 |> List.filter_map (fun ((reference, _) as raw) -> 485 Git.Reference.to_string reference 486 |> name_of_reference 487 |> Option.map (fun name -> to_t_with_name name raw)) 488 in 489 let from_packed = 490 read_packed_refs repository.store 491 |> List.filter_map (fun (hex, refname) -> 492 name_of_reference refname 493 |> Option.map (fun name -> { name; hash = hex })) 494 in 495 (* Merge: loose refs win over packed refs for the same name *) 496 let loose_names = List.map (fun r -> r.name) from_loose in 497 let merged = 498 from_loose 499 @ List.filter (fun r -> not (List.mem r.name loose_names)) from_packed 500 in 501 merged 502 |> List.sort (fun left right -> String.compare left.name right.name) 503 |> Lwt_result.return 504 505 let branches repository = refs_by_prefix repository branch_name 506 507 let of_id repository id = 508 let* branches = branches repository in 509 match List.find_opt (fun branch -> branch.name = id) branches with 510 | Some branch -> Lwt_result.return branch 511 | None -> Lwt_result.fail (Not_found ("no reference matches id " ^ id)) 512 end 513 514 let mode_of_perm : Git.Tree.perm -> int = function 515 | `Commit -> 0o160000 516 | `Dir -> 0o040000 517 | `Everybody -> 0o100664 518 | `Exec -> 0o100755 519 | `Link -> 0o120000 520 | `Normal -> 0o100644 521 522 module Entry = struct 523 type perm = Dir | File | Exec | Link | Submodule 524 type t = { hash : string; name : string; perm : perm } 525 526 let perm_of_git : Git.Tree.perm -> perm = function 527 | `Dir -> Dir 528 | `Exec -> Exec 529 | `Link -> Link 530 | `Commit -> Submodule 531 | `Normal | `Everybody -> File 532 533 let to_t (entry : Store.Value.Tree.entry) = 534 { 535 hash = Store.Hash.to_hex entry.node; 536 name = entry.name; 537 perm = perm_of_git entry.perm; 538 } 539 540 let is_readme { name; _ } = 541 String.(lowercase_ascii name |> starts_with ~prefix:"readme") 542 end 543 544 module Tree = struct 545 type t = { entries : Entry.t list } 546 type tree_node = { entry : Entry.t; children : tree_node list option } 547 548 let to_t tree = 549 { entries = Store.Value.Tree.to_list tree |> List.map Entry.to_t } 550 551 let of_hash repository hash = 552 Lwt_result.bind (read_value repository hash) @@ function 553 | Git.Value.Tree tree -> Lwt_result.return (to_t tree) 554 | _ -> 555 Store.Hash.to_hex hash |> Printf.sprintf "no tree matches id %s" 556 |> fun message -> Lwt_result.fail (Not_found message) 557 558 let head_tree_hash repository = 559 let* hash = resolve_head_hash repository in 560 Lwt_result.bind (read_value repository hash) @@ function 561 | Git.Value.Commit commit -> 562 Lwt_result.return (Store.Value.Commit.tree commit) 563 | _ -> Lwt_result.fail (Internal "HEAD does not point to a commit") 564 565 let head repository = 566 let* hash = head_tree_hash repository in 567 of_hash repository hash 568 569 let expand repository tree = 570 let rec expand_entry (entry : Entry.t) = 571 if entry.perm <> Entry.Dir then 572 Lwt_result.return { entry; children = None } 573 else collapse_single_subdirs entry.name entry.hash 574 and collapse_single_subdirs prefix hash_hex = 575 let* hash = hash_of_hex hash_hex in 576 let* subtree = 577 Lwt_result.bind (read_value repository hash) @@ function 578 | Git.Value.Tree t -> Lwt_result.return (to_t t) 579 | _ -> Lwt_result.return { entries = [] } 580 in 581 let entries = subtree.entries in 582 match entries with 583 | [ single ] when single.perm = Entry.Dir -> 584 (* Single subdir — collapse into parent name and recurse *) 585 let combined_name = prefix ^ "/" ^ single.name in 586 collapse_single_subdirs combined_name single.hash 587 | [ single ] when single.perm <> Entry.Dir -> 588 (* Single file — present as a file with combined path name *) 589 let combined_entry = 590 { 591 Entry.hash = single.hash; 592 name = prefix ^ "/" ^ single.name; 593 perm = single.perm; 594 } 595 in 596 Lwt_result.return { entry = combined_entry; children = None } 597 | _ -> 598 let collapsed_entry = 599 { Entry.hash = hash_hex; name = prefix; perm = Entry.Dir } 600 in 601 let* children = expand_entries entries in 602 Lwt_result.return 603 { entry = collapsed_entry; children = Some children } 604 and expand_entries entries = 605 let is_hidden (e : Entry.t) = 606 String.length e.name > 0 && e.name.[0] = '.' 607 in 608 let sorted = 609 List.sort 610 (fun (a : Entry.t) (b : Entry.t) -> 611 match (a.perm, b.perm) with 612 | Entry.Dir, Entry.Dir -> 613 let ha = is_hidden a and hb = is_hidden b in 614 if ha = hb then String.compare a.name b.name 615 else if ha then 1 616 else -1 617 | Entry.Dir, _ -> -1 618 | _, Entry.Dir -> 1 619 | _, _ -> 620 let ha = is_hidden a and hb = is_hidden b in 621 if ha = hb then String.compare a.name b.name 622 else if ha then 1 623 else -1) 624 entries 625 in 626 let rec go acc = function 627 | [] -> Lwt_result.return (List.rev acc) 628 | e :: rest -> 629 let* pe = expand_entry e in 630 go (pe :: acc) rest 631 in 632 go [] sorted 633 in 634 expand_entries tree.entries 635 636 let find_path repository target_hash = 637 let* target = hash_of_hex target_hash in 638 let* root = head_tree_hash repository in 639 if Store.Hash.equal root target then Lwt_result.return [] 640 else 641 let rec search trail tree_hash = 642 Lwt_result.bind (read_value repository tree_hash) @@ function 643 | Git.Value.Tree tree -> 644 let rec try_entries = function 645 | [] -> Lwt_result.return None 646 | (entry : Store.Value.Tree.entry) :: rest -> 647 let step = (entry.name, Store.Hash.to_hex entry.node) in 648 if Store.Hash.equal entry.node target then 649 Lwt_result.return (Some (List.rev (step :: trail))) 650 else if entry.perm = `Dir then 651 let* found = search (step :: trail) entry.node in 652 match found with 653 | Some _ -> Lwt_result.return found 654 | None -> try_entries rest 655 else try_entries rest 656 in 657 try_entries (Store.Value.Tree.to_list tree) 658 | _ -> Lwt_result.return None 659 in 660 let* result = search [] root in 661 match result with 662 | Some trail -> Lwt_result.return trail 663 | None -> 664 Lwt_result.fail 665 (Not_found ("object is not reachable from HEAD: " ^ target_hash)) 666 end 667 668 module Blob = struct 669 type t = { content : string } 670 671 let to_t blob = { content = Store.Value.Blob.to_string blob } 672 end 673 674 module Diff = struct 675 module Path_map = Map.Make (String) 676 include Line_diff 677 678 type tree_file = { hash : string; perm : Git.Tree.perm } 679 680 let rec flatten_tree repository prefix tree_hash files = 681 let* hash = hash_of_hex tree_hash in 682 Lwt_result.bind (read_value repository hash) @@ function 683 | Git.Value.Tree tree -> 684 let rec add_entries files = function 685 | [] -> Lwt_result.return files 686 | (entry : Store.Value.Tree.entry) :: entries -> 687 let path = 688 if prefix = "" then entry.name 689 else Filename.concat prefix entry.name 690 in 691 let hash = Store.Hash.to_hex entry.node in 692 let* files = 693 match entry.perm with 694 | `Dir -> flatten_tree repository path hash files 695 | (`Commit | `Everybody | `Exec | `Link | `Normal) as perm -> 696 Lwt_result.return (Path_map.add path { hash; perm } files) 697 in 698 add_entries files entries 699 in 700 add_entries files (Store.Value.Tree.to_list tree) 701 | _ -> Lwt_result.fail (Not_found ("no tree matches id " ^ tree_hash)) 702 703 let read_file repository = function 704 | None -> Lwt_result.return "" 705 | Some { hash; perm = `Commit } -> 706 Lwt_result.return ("Subproject commit " ^ hash ^ "\n") 707 | Some { hash; _ } -> ( 708 let* hash = hash_of_hex hash in 709 Lwt_result.bind (read_value repository hash) @@ function 710 | Git.Value.Blob blob -> 711 Lwt_result.return (Store.Value.Blob.to_string blob) 712 | _ -> Lwt_result.fail (Internal "file entry does not point to a blob")) 713 714 let of_commit repository (commit : Commit.t) = 715 let* new_files = flatten_tree repository "" commit.tree Path_map.empty in 716 let* old_files = 717 match commit.parents with 718 | [] -> Lwt_result.return Path_map.empty 719 | parent :: _ -> ( 720 let* parent_hash = hash_of_hex parent in 721 Lwt_result.bind (read_value repository parent_hash) @@ function 722 | Git.Value.Commit parent_commit -> 723 Store.Value.Commit.tree parent_commit |> Store.Hash.to_hex 724 |> fun tree -> flatten_tree repository "" tree Path_map.empty 725 | _ -> Lwt_result.fail (Internal ("parent is not a commit " ^ parent)) 726 ) 727 in 728 let changed_files = 729 Path_map.merge 730 (fun _ old_file new_file -> 731 match (old_file, new_file) with 732 | Some old_file, Some new_file 733 when old_file.hash = new_file.hash && old_file.perm = new_file.perm 734 -> 735 None 736 | None, None -> None 737 | _ -> Some (old_file, new_file)) 738 old_files new_files 739 |> Path_map.bindings 740 in 741 let rec build files = function 742 | [] -> Lwt_result.return (List.rev files) 743 | (path, (old_file, new_file)) :: rest -> 744 let* old_content = read_file repository old_file in 745 let* new_content = read_file repository new_file in 746 let binary = 747 String.contains old_content '\x00' 748 || String.contains new_content '\x00' 749 in 750 let file = 751 { 752 path; 753 old_hash = Option.map (fun file -> file.hash) old_file; 754 new_hash = Option.map (fun file -> file.hash) new_file; 755 old_mode = 756 Option.map (fun file -> mode_of_perm file.perm) old_file; 757 new_mode = 758 Option.map (fun file -> mode_of_perm file.perm) new_file; 759 binary; 760 hunks = 761 (if binary then [] 762 else 763 Line_diff.of_contents old_content new_content 764 |> Line_diff.hunks); 765 } 766 in 767 build (file :: files) rest 768 in 769 build [] changed_files 770 end 771 772 let blob_or_tree repository id = 773 let* hash = hash_of_hex id in 774 Lwt_result.bind (read_value repository hash) @@ function 775 | Git.Value.Tree tree -> Lwt_result.return (`Tree (Tree.to_t tree)) 776 | Git.Value.Blob blob -> Lwt_result.return (`Blob (Blob.to_t blob)) 777 | _ -> Lwt_result.fail (Not_found ("no tree or blob matches id " ^ id)) 778 779 (* Resolving by path walks at most one tree per segment, unlike 780 [Tree.find_path], which searches the whole tree for a hash. *) 781 let object_at_path repository path = 782 let segments = 783 String.split_on_char '/' path |> List.filter (fun s -> s <> "") 784 in 785 let missing () = Lwt_result.fail (Not_found ("no such path: " ^ path)) in 786 if segments = [] then 787 Lwt_result.fail (Bad_request "empty path in repository") 788 else 789 let* root = Tree.head_tree_hash repository in 790 let rec walk trail tree_hash = function 791 | [] -> missing () 792 | segment :: rest -> ( 793 Lwt_result.bind (read_value repository tree_hash) @@ function 794 | Git.Value.Tree tree -> ( 795 let entries = Store.Value.Tree.to_list tree in 796 match 797 List.find_opt 798 (fun (entry : Store.Value.Tree.entry) -> 799 entry.name = segment) 800 entries 801 with 802 | None -> missing () 803 | Some entry -> 804 let step = (entry.name, Store.Hash.to_hex entry.node) in 805 let trail = step :: trail in 806 if rest = [] then 807 Lwt_result.bind (read_value repository entry.node) 808 @@ function 809 | Git.Value.Blob blob -> 810 Lwt_result.return 811 (`Blob (Blob.to_t blob), List.rev trail) 812 | Git.Value.Tree tree -> 813 Lwt_result.return 814 (`Tree (Tree.to_t tree), List.rev trail) 815 | _ -> missing () 816 else walk trail entry.node rest) 817 | _ -> missing ()) 818 in 819 walk [] root segments 820 821 module Readme = struct 822 type t = { name : string; content : string } 823 end 824 825 module Repo = struct 826 let readme repository = 827 let* tree = Tree.head repository in 828 match List.find_opt Entry.is_readme tree.entries with 829 | None -> Lwt_result.return None 830 | Some entry -> ( 831 let* hash = hash_of_hex entry.hash in 832 Lwt_result.bind (read_value repository hash) @@ function 833 | Git.Value.Blob blob -> 834 Lwt_result.return 835 (Some 836 Readme. 837 { 838 name = entry.name; 839 content = Store.Value.Blob.to_string blob; 840 }) 841 | _ -> Lwt_result.fail (Internal ("could not read file " ^ entry.name))) 842 end 843 844 let read_readme_in dir = 845 let readme_candidates = 846 [ "README"; "README.md"; "README.org"; "README.txt" ] 847 in 848 let rec try_candidates = function 849 | [] -> None 850 | name :: rest -> ( 851 let path = Filename.concat dir name in 852 try 853 let content = In_channel.with_open_text path In_channel.input_all in 854 Some { Blob.content } 855 with Sys_error _ -> try_candidates rest) 856 in 857 try_candidates readme_candidates 858 859 let read_root_readme config = read_readme_in config.Config.git_project_root 860 861 let scan_subdirectory config subdir = 862 let full_path = Filename.concat config.Config.git_project_root subdir in 863 if not (Sys.file_exists full_path && Sys.is_directory full_path) then 864 Error (Not_found ("directory not found: " ^ subdir)) 865 else scan_directory full_path 866 867 let read_subdir_readme config subdir = 868 read_readme_in (Filename.concat config.Config.git_project_root subdir) 869