ocaml-git / lib / commit.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 commit objects. *)

type t = {
  tree : Hash.t;
  parents : Hash.t list;
  author : User.t;
  committer : User.t;
  extra : (string * string list) list;
  message : string option;
}

let v ~tree ~author ~committer ?(parents = []) ?(extra = []) message =
  { tree; parents; author; committer; extra; message }

let tree t = t.tree
let parents t = t.parents
let author t = t.author
let committer t = t.committer
let message t = t.message
let extra t = t.extra

let pp ppf t =
  Fmt.pf ppf "@[<v>tree %a@," Hash.pp t.tree;
  List.iter (fun p -> Fmt.pf ppf "parent %a@," Hash.pp p) t.parents;
  Fmt.pf ppf "author %a@," User.pp t.author;
  Fmt.pf ppf "committer %a@," User.pp t.committer;
  List.iter
    (fun (k, vs) -> List.iter (fun v -> Fmt.pf ppf "%s %s@," k v) vs)
    t.extra;
  (match t.message with Some msg -> Fmt.pf ppf "@,%s" msg | None -> ());
  Fmt.pf ppf "@]"

let equal a b =
  Hash.equal a.tree b.tree
  && List.equal Hash.equal a.parents b.parents
  && User.equal a.author b.author
  && User.equal a.committer b.committer

let compare a b =
  match Hash.compare a.tree b.tree with
  | 0 -> (
      match List.compare Hash.compare a.parents b.parents with
      | 0 -> User.compare a.author b.author
      | n -> n)
  | n -> n

let hash t = Hashtbl.hash t

let compare_by_date a b =
  Int64.compare (User.date a.author) (User.date b.author)

(** Encode commit to git format. *)
let to_string t =
  let buf = Buffer.create 512 in
  Buffer.add_string buf "tree ";
  Buffer.add_string buf (Hash.to_hex t.tree);
  Buffer.add_char buf '\n';
  List.iter
    (fun p ->
      Buffer.add_string buf "parent ";
      Buffer.add_string buf (Hash.to_hex p);
      Buffer.add_char buf '\n')
    t.parents;
  Buffer.add_string buf "author ";
  Buffer.add_string buf (User.to_string t.author);
  Buffer.add_char buf '\n';
  Buffer.add_string buf "committer ";
  Buffer.add_string buf (User.to_string t.committer);
  Buffer.add_char buf '\n';
  List.iter
    (fun (key, values) ->
      List.iter
        (fun value ->
          Buffer.add_string buf key;
          Buffer.add_char buf ' ';
          Buffer.add_string buf value;
          Buffer.add_char buf '\n')
        values)
    t.extra;
  (match t.message with
  | Some msg ->
      Buffer.add_char buf '\n';
      Buffer.add_string buf msg
  | None -> ());
  Buffer.contents buf

(** Parse a single header line. *)
let parse_header line =
  match String.index_opt line ' ' with
  | None -> None
  | Some pos ->
      let key = String.sub line 0 pos in
      let value = String.sub line (pos + 1) (String.length line - pos - 1) in
      Some (key, value)

(** Parse commit from git format. *)
let of_string s =
  let lines = String.split_on_char '\n' s in
  let rec parse_headers acc tree parents author committer extra = function
    | [] -> Error (`Msg "Unexpected end of commit")
    | "" :: rest -> (
        (* Empty line marks start of message *)
        let message =
          match rest with [] -> None | _ -> Some (String.concat "\n" rest)
        in
        match (tree, author, committer) with
        | Some tree, Some author, Some committer ->
            Ok
              {
                tree;
                parents = List.rev parents;
                author;
                committer;
                extra = List.rev extra;
                message;
              }
        | None, _, _ -> Error (`Msg "Missing tree in commit")
        | _, None, _ -> Error (`Msg "Missing author in commit")
        | _, _, None -> Error (`Msg "Missing committer in commit"))
    | line :: rest -> (
        match parse_header line with
        | None -> Error (`Msg ("Invalid header line: " ^ line))
        | Some ("tree", hex) ->
            let tree = Hash.of_hex hex in
            parse_headers acc (Some tree) parents author committer extra rest
        | Some ("parent", hex) ->
            let parent = Hash.of_hex hex in
            parse_headers acc tree (parent :: parents) author committer extra
              rest
        | Some ("author", user_str) -> (
            match User.of_string user_str with
            | Ok user ->
                parse_headers acc tree parents (Some user) committer extra rest
            | Error _ as e -> e)
        | Some ("committer", user_str) -> (
            match User.of_string user_str with
            | Ok user ->
                parse_headers acc tree parents author (Some user) extra rest
            | Error _ as e -> e)
        | Some (key, value) ->
            (* Handle extra headers like gpgsig *)
            let extra =
              match List.assoc_opt key extra with
              | Some values ->
                  (key, values @ [ value ]) :: List.remove_assoc key extra
              | None -> (key, [ value ]) :: extra
            in
            parse_headers acc tree parents author committer extra rest)
  in
  parse_headers [] None [] None None [] lines

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
    commit body (after the loose-object header, if any). *)

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. *)
let read_until reader delim =
  let buf = Buffer.create 128 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 Char.code delim = Bytes.get_uint8 bytes i then begin
            Buffer.add_subbytes buf bytes first (i - first);
            (* Push back the remaining bytes after the delimiter *)
            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 all remaining bytes from a reader. *)
let read_rest reader =
  let buf = Buffer.create 256 in
  Reader.add_to_buffer buf reader;
  if Buffer.length buf = 0 then None else Some (Buffer.contents buf)

let of_reader reader =
  let rec parse_headers tree parents author committer extra =
    match read_until reader '\n' with
    | None -> Error (`Msg "Unexpected end of commit")
    | Some "" -> (
        (* Empty line marks start of message *)
        let message = read_rest reader in
        match (tree, author, committer) with
        | Some tree, Some author, Some committer ->
            Ok
              {
                tree;
                parents = List.rev parents;
                author;
                committer;
                extra = List.rev extra;
                message;
              }
        | None, _, _ -> Error (`Msg "Missing tree in commit")
        | _, None, _ -> Error (`Msg "Missing author in commit")
        | _, _, None -> Error (`Msg "Missing committer in commit"))
    | Some line -> (
        match parse_header line with
        | None -> Error (`Msg ("Invalid header line: " ^ line))
        | Some ("tree", hex) ->
            let tree = Hash.of_hex hex in
            parse_headers (Some tree) parents author committer extra
        | Some ("parent", hex) ->
            let parent = Hash.of_hex hex in
            parse_headers tree (parent :: parents) author committer extra
        | Some ("author", user_str) -> (
            match User.of_string user_str with
            | Ok user -> parse_headers tree parents (Some user) committer extra
            | Error _ as e -> e)
        | Some ("committer", user_str) -> (
            match User.of_string user_str with
            | Ok user -> parse_headers tree parents author (Some user) extra
            | Error _ as e -> e)
        | Some (key, value) ->
            let extra =
              match List.assoc_opt key extra with
              | Some values ->
                  (key, values @ [ value ]) :: List.remove_assoc key extra
              | None -> (key, [ value ]) :: extra
            in
            parse_headers tree parents author committer extra)
  in
  parse_headers None [] None None []

let digest t =
  let s = to_string t in
  Hash.digest_string ~kind:`Commit 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)