ocaml-git / lib / tree.ml

(* Copyright (c) 2013-2017 Thomas Gazagnaire <[e-mail]>
   Copyright (c) 2017-2024 Romain Calascibetta <[e-mail]>
   Copyright (c) 2024-2026 Thomas Gazagnaire <[e-mail]>

   Permission to use, copy, modify, and distribute this software for any
   purpose with or without fee is hereby granted, provided that the above
   copyright notice and this permission notice appear in all copies.

   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
   WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
   MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
   ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
   WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
   ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
   OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)

(** Git tree objects (directory listings). *)

type perm = [ `Normal | `Everybody | `Exec | `Link | `Dir | `Commit ]

let perm_to_string = function
  | `Normal -> "100644"
  | `Everybody -> "100664"
  | `Exec -> "100755"
  | `Link -> "120000"
  | `Dir -> "40000"
  | `Commit -> "160000"

let perm_of_string = function
  | "44" | "100644" -> Ok `Normal
  | "100664" -> Ok `Everybody
  | "100755" -> Ok `Exec
  | "120000" -> Ok `Link
  | "40000" | "040000" -> Ok `Dir
  | "160000" -> Ok `Commit
  | v -> Error (`Msg ("Invalid permission: " ^ v))

let perm_of_string_exn s =
  match perm_of_string s with Ok p -> p | Error (`Msg m) -> invalid_arg m

type entry = { perm : perm; name : string; hash : Hash.t }

let entry ~perm ~name hash =
  if String.contains name '\x00' then invalid_arg "Invalid entry name";
  { perm; name; hash }

let pp_entry ppf { perm; name; hash } =
  Fmt.pf ppf "%s %s %a" (perm_to_string perm) name Hash.pp hash

type t = entry list

let empty = []
let is_empty t = t = []

let v entries =
  (* Git sorts tree entries in a specific way *)
  let name_with_suffix e =
    match e.perm with `Dir -> e.name ^ "/" | _ -> e.name
  in
  List.sort
    (fun a b -> String.compare (name_with_suffix a) (name_with_suffix b))
    entries

let add entry t =
  v (entry :: List.filter (fun e -> not (String.equal e.name entry.name)) t)

let remove ~name t = List.filter (fun e -> not (String.equal e.name name)) t
let find ~name t = List.find_opt (fun e -> String.equal e.name name) t
let to_list t = t
let of_list entries = v entries
let hashes t = List.map (fun e -> e.hash) t
let iter f t = List.iter f t
let pp ppf t = Fmt.(list ~sep:(any "@,") pp_entry) ppf t

let equal a b = List.equal (fun x y -> compare x y = 0) a b

and compare a b =
  let rec loop a b =
    match (a, b) with
    | [], [] -> 0
    | [], _ -> -1
    | _, [] -> 1
    | x :: xs, y :: ys ->
        let c = String.compare x.name y.name in
        if c <> 0 then c else loop xs ys
  in
  loop a b

let hash t = Hashtbl.hash t

(** Encode tree to git format. Format: "mode name\x00<20-byte-hash>" repeated *)
let to_string t =
  let buf = Buffer.create 256 in
  List.iter
    (fun { perm; name; hash } ->
      (* Git uses octal mode without leading zeros for dirs *)
      let mode = match perm with `Dir -> "40000" | _ -> perm_to_string perm in
      Buffer.add_string buf mode;
      Buffer.add_char buf ' ';
      Buffer.add_string buf name;
      Buffer.add_char buf '\x00';
      Buffer.add_string buf (Hash.to_raw_string hash))
    t;
  Buffer.contents buf

(** Parse tree from git format. *)
let of_string s =
  let len = String.length s in
  let rec loop acc pos =
    if pos >= len then Ok (v (List.rev acc))
    else
      (* Find the space after mode *)
      match String.index_from_opt s pos ' ' with
      | None -> Error (`Msg "Invalid tree: missing space after mode")
      | Some sp_pos -> (
          let mode = String.sub s pos (sp_pos - pos) in
          match perm_of_string mode with
          | Error _ as e -> e
          | Ok perm -> (
              (* Find the null byte after name *)
              match String.index_from_opt s (sp_pos + 1) '\x00' with
              | None -> Error (`Msg "Invalid tree: missing null after name")
              | Some null_pos ->
                  let name =
                    String.sub s (sp_pos + 1) (null_pos - sp_pos - 1)
                  in
                  let hash_start = null_pos + 1 in
                  if hash_start + Hash.digest_size > len then
                    Error (`Msg "Invalid tree: truncated hash")
                  else
                    let hash_str = String.sub s hash_start Hash.digest_size in
                    let hash = Hash.of_raw_string hash_str in
                    let entry = { perm; name; hash } in
                    loop (entry :: acc) (hash_start + Hash.digest_size)))
  in
  loop [] 0

let of_string_exn s =
  match of_string s with Ok t -> t | Error (`Msg m) -> failwith m

(** {1 Reader-based parsing}

    Parse directly from a {!Bytesrw.Bytes.Reader.t} without materialising the
    full object into a string. The reader must be positioned at the start of the
    tree body. *)

module Reader = Bytesrw.Bytes.Reader
module Slice = Bytesrw.Bytes.Slice

(** Read until [delim] from a reader. Returns the bytes before the delimiter;
    the delimiter is consumed. Returns [None] at end-of-data. *)
let read_until_byte reader delim =
  let buf = Buffer.create 64 in
  let rec loop () =
    match Reader.read reader with
    | slice when Slice.is_eod slice ->
        if Buffer.length buf = 0 then None else Some (Buffer.contents buf)
    | slice ->
        let bytes = Slice.bytes slice in
        let first = Slice.first slice in
        let len = Slice.length slice in
        let rec scan i =
          if i >= first + len then begin
            Buffer.add_subbytes buf bytes first len;
            loop ()
          end
          else if Bytes.get_uint8 bytes i = Char.code delim then begin
            Buffer.add_subbytes buf bytes first (i - first);
            let rest_off = i + 1 in
            let rest_len = first + len - rest_off in
            if rest_len > 0 then
              Reader.push_back reader
                (Slice.make bytes ~first:rest_off ~length:rest_len);
            Some (Buffer.contents buf)
          end
          else scan (i + 1)
        in
        scan first
  in
  loop ()

(** Read exactly [n] bytes from a reader. Works at the slice level to avoid
    intermediate string allocation. *)
let read_exactly_bytes reader n =
  let buf = Bytes.create n in
  let rec loop off remaining =
    if remaining = 0 then Ok buf
    else
      match Reader.read reader with
      | slice when Slice.is_eod slice ->
          Error (`Msg "Unexpected end of tree data")
      | slice ->
          let src = Slice.bytes slice in
          let src_off = Slice.first slice in
          let available = Slice.length slice in
          let to_copy = min available remaining in
          Bytes.blit src src_off buf off to_copy;
          if to_copy < available then begin
            let rest_off = src_off + to_copy in
            let rest_len = available - to_copy in
            Reader.push_back reader
              (Slice.make src ~first:rest_off ~length:rest_len)
          end;
          loop (off + to_copy) (remaining - to_copy)
  in
  loop 0 n

let of_reader reader =
  let rec loop acc =
    match read_until_byte reader ' ' with
    | None ->
        (* End of data — return accumulated entries *)
        Ok (v (List.rev acc))
    | Some mode -> (
        match perm_of_string mode with
        | Error _ as e -> e
        | Ok perm -> (
            match read_until_byte reader '\x00' with
            | None -> Error (`Msg "Invalid tree: missing null after name")
            | Some name -> (
                match read_exactly_bytes reader Hash.digest_size with
                | Error _ as e -> e
                | Ok hash_bytes ->
                    let hash =
                      Hash.of_raw_string (Bytes.unsafe_to_string hash_bytes)
                    in
                    let entry = { perm; name; hash } in
                    loop (entry :: acc))))
  in
  loop []

let digest t =
  let s = to_string t in
  Hash.digest_string ~kind:`Tree s

module Set = Set.Make (struct
  type nonrec t = t

  let compare = compare
end)

module Map = Map.Make (struct
  type nonrec t = t

  let compare = compare
end)