ocaml-git / lib / value.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 values (union of all object types). *)

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

type t = Blob of Blob.t | Commit of Commit.t | Tree of Tree.t | Tag of Tag.t

let blob b = Blob b
let commit c = Commit c
let tree t = Tree t
let tag t = Tag t

let kind = function
  | Blob _ -> `Blob
  | Commit _ -> `Commit
  | Tree _ -> `Tree
  | Tag _ -> `Tag

let pp ppf = function
  | Blob b -> Fmt.pf ppf "(Blob %a)" Blob.pp b
  | Commit c -> Fmt.pf ppf "(Commit %a)" Commit.pp c
  | Tree t -> Fmt.pf ppf "(Tree %a)" Tree.pp t
  | Tag t -> Fmt.pf ppf "(Tag %a)" Tag.pp t

let equal a b =
  match (a, b) with
  | Blob a, Blob b -> Blob.equal a b
  | Commit a, Commit b -> Commit.equal a b
  | Tree a, Tree b -> Tree.equal a b
  | Tag a, Tag b -> Tag.equal a b
  | _ -> false

let compare a b =
  match (a, b) with
  | Blob a, Blob b -> Blob.compare a b
  | Commit a, Commit b -> Commit.compare a b
  | Tree a, Tree b -> Tree.compare a b
  | Tag a, Tag b -> Tag.compare a b
  | Blob _, _ -> -1
  | _, Blob _ -> 1
  | Commit _, _ -> -1
  | _, Commit _ -> 1
  | Tree _, _ -> -1
  | _, Tree _ -> 1

let hash = function
  | Blob b -> Blob.hash b
  | Commit c -> Commit.hash c
  | Tree t -> Tree.hash t
  | Tag t -> Tag.hash t

let digest = function
  | Blob b -> Blob.digest b
  | Commit c -> Commit.digest c
  | Tree t -> Tree.digest t
  | Tag t -> Tag.digest t

(** Get the raw content of a value (without header). *)
let to_string_without_header = function
  | Blob b -> Blob.to_string b
  | Commit c -> Commit.to_string c
  | Tree t -> Tree.to_string t
  | Tag t -> Tag.to_string t

let length v = String.length (to_string_without_header v)

(** Get the raw content of a value with git header. Format: "type
    length\x00content" *)
let to_string v =
  let content = to_string_without_header v in
  let kind_str =
    match kind v with
    | `Blob -> "blob"
    | `Commit -> "commit"
    | `Tree -> "tree"
    | `Tag -> "tag"
  in
  Fmt.str "%s %d\x00%s" kind_str (String.length content) content

(** Parse a value from raw content (without header). *)
let of_string ~kind content =
  match kind with
  | `Blob -> Ok (Blob (Blob.of_string content))
  | `Commit -> Result.map commit (Commit.of_string content)
  | `Tree -> Result.map tree (Tree.of_string content)
  | `Tag -> Result.map tag (Tag.of_string content)

let of_string_exn ~kind content =
  match of_string ~kind content with Ok v -> v | Error (`Msg m) -> failwith m

(** Parse a value from raw content with git header. *)
let of_string_with_header s =
  (* Find the space after type *)
  match String.index_opt s ' ' with
  | None -> Error (`Msg "Invalid git object: missing space after type")
  | Some sp_pos -> (
      let type_str = String.sub s 0 sp_pos in
      (* Find the null byte after length *)
      match String.index_from_opt s (sp_pos + 1) '\x00' with
      | None -> Error (`Msg "Invalid git object: missing null after length")
      | Some null_pos -> (
          let length_str = String.sub s (sp_pos + 1) (null_pos - sp_pos - 1) in
          let content_start = null_pos + 1 in
          let content =
            String.sub s content_start (String.length s - content_start)
          in
          (* Verify length *)
          match int_of_string_opt length_str with
          | None -> Error (`Msg ("Invalid length: " ^ length_str))
          | Some expected_len ->
              if String.length content <> expected_len then
                Error
                  (`Msg
                     (Fmt.str "Length mismatch: expected %d, got %d"
                        expected_len (String.length content)))
              else
                let kind =
                  match type_str with
                  | "blob" -> Ok `Blob
                  | "commit" -> Ok `Commit
                  | "tree" -> Ok `Tree
                  | "tag" -> Ok `Tag
                  | _ -> Error (`Msg ("Unknown object type: " ^ type_str))
                in
                Result.bind kind (fun kind -> of_string ~kind content)))

let of_string_with_header_exn s =
  match of_string_with_header s with Ok v -> v | Error (`Msg m) -> failwith m

(** {1 Bytesrw support} *)

(** Read until a specific byte is found *)
let read_until reader byte =
  let buf = Buffer.create 64 in
  let rec loop () =
    match Reader.read reader with
    | slice when Slice.is_eod slice -> Error (`Msg "unexpected end of data")
    | slice -> (
        let str = Slice.to_string slice in
        match String.index_opt str byte with
        | Some pos ->
            Buffer.add_substring buf str 0 pos;
            if pos + 1 < String.length str then begin
              let leftover =
                String.sub str (pos + 1) (String.length str - pos - 1)
              in
              Reader.push_back reader (Slice.of_string leftover)
            end;
            Ok (Buffer.contents buf)
        | None ->
            Buffer.add_string buf str;
            loop ())
  in
  loop ()

(** Read a git object from a reader. Returns (kind, length, content). *)
let read_header reader =
  let open Result.Syntax in
  let* type_str = read_until reader ' ' in
  let* length_str = read_until reader '\x00' in
  let* kind =
    match type_str with
    | "blob" -> Ok `Blob
    | "commit" -> Ok `Commit
    | "tree" -> Ok `Tree
    | "tag" -> Ok `Tag
    | _ -> Error (`Msg ("Unknown object type: " ^ type_str))
  in
  let* length =
    match int_of_string_opt length_str with
    | Some n -> Ok n
    | None -> Error (`Msg ("Invalid length: " ^ length_str))
  in
  Ok (kind, length)

(** Parse from a reader, dispatching to reader-based parsers for commit and tree
    to avoid materialising the full content string. Blobs and tags still go
    through [of_string] (blobs are opaque bytes; tags are rare). *)
let of_reader ~kind reader =
  match kind with
  | `Commit -> Result.map commit (Commit.of_reader reader)
  | `Tree -> Result.map tree (Tree.of_reader reader)
  | `Blob ->
      let content = Reader.to_string reader in
      Ok (Blob (Blob.of_string content))
  | `Tag ->
      let content = Reader.to_string reader in
      Result.map tag (Tag.of_string content)

(** Read a git object from a bytesrw reader. *)
let read reader =
  let open Result.Syntax in
  let* kind, _length = read_header reader in
  of_reader ~kind reader

(** Write a git object to a bytesrw writer. *)
let write writer v =
  let content = to_string_without_header v in
  let kind_str =
    match kind v with
    | `Blob -> "blob"
    | `Commit -> "commit"
    | `Tree -> "tree"
    | `Tag -> "tag"
  in
  let header = Fmt.str "%s %d\x00" kind_str (String.length content) in
  Writer.write writer (Slice.of_string header);
  Writer.write writer (Slice.of_string content)

(** Write only the content (without header) to a bytesrw writer. *)
let write_content writer v =
  let content = to_string_without_header v in
  Writer.write writer (Slice.of_string content)

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)