Source file commit_tree.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2021 DaiLambda, Inc. <contact@dailambda.jp>                 *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Utils
open Lwt.Syntax
open Result_lwt.Syntax

type entry =
  { parent : Commit_hash.t option
  ; index : Index.t (* The index in the context for Commit..t *)
  }

let segment_of_hash hp =
  let s = Commit_hash.to_string hp in
  Segment.unsafe_of_bits (String.length s * 8) s

let hash_of_segment seg =
  let len, s = Segment.to_bits seg in
  assert (len mod 8 = 0);
  Commit_hash.of_string s

(** Particia tree of commits *)
module P = struct
  type key = Commit_hash.t
  type value = entry

  let equal_value { parent= hp1; index= i1} { parent= hp2; index= i2} =
    hp1 = hp2 && i1 = i2

  let pp_value ppf ({parent= h; index= i} : value) =
    Format.fprintf ppf "(%a, %a)"
      (Format.option Commit_hash.pp) h
      Index.pp i

  let bytes_per_cell = 40

  let config =
    Storage.{
      head_string = "PLEBEIA ROOTS\000\000\000\000\000\000\000";
      version = 1;
      bytes_per_cell;
      max_index = Index.(max_int - Unsafe.of_int 256)
    }

  open Storage
  module B = Mmap.Buffer

  let pos_flags = bytes_per_cell - 1
  let pos_meta = bytes_per_cell - 4
  let pos_index = bytes_per_cell - 8

  let get_hash buf pos =
    let h = Commit_hash.of_string @@ B.copy buf pos 32 in
    if Commit_hash.is_zero h then None else Some h

  let set_hash buf off hpo =
    let hp = Option.default Commit_hash.zero hpo in
    B.write_string (Commit_hash.to_string hp) buf off

  let parse_segments buf =
    let lenLbytes = B.get_uint8 buf 0 in
    let segL = Segment.Serialization.decode_exn (B.copy buf 1 lenLbytes) in
    let lenRbytes = B.get_uint8 buf (lenLbytes + 1) in
    let segR = Segment.Serialization.decode_exn (B.copy buf (lenLbytes + 2) lenRbytes) in
    segL, segR

  let parse storage i =
    let buf = get_cell storage i in
    let flags = B.get_uint8 buf pos_flags in
    match flags land 0x01 with
    | 0 ->
        (* leaf *)
        let h = get_hash buf 0 in
        let index = B.get_index buf pos_index in
        `Leaf {parent= h; index}
    | _ ->
        (* internal *)
        let index1, segs_buf =
          match flags land 0x02 with
          | 0 -> Index.pred i, buf
          | _ ->
              let i' = Index.pred i in
              Index.pred i', get_cell2 storage i'
        in
        let index2 = B.get_index buf pos_index in
        let segL, segR = parse_segments segs_buf in
        match flags land 0x04 with
        | 0 ->
            (* index is for Left.  Right is in the previous cell *)
            `Internal (segL, index2, segR, index1)
        | _ ->
            (* index is for Right.  Left is in the previous cell *)
            `Internal (segL, index1, segR, index2)

  (*
    |<- hash 32B ->|<- tree index 4B ->|<- meta 4B ->|
                                                    k  kind flag
  *)
  let write_leaf storage {parent= h; index} =
    let+? i = new_index storage in
    let buf = get_cell storage i in
    set_hash buf 0 h;
    B.set_index buf pos_index index;
    B.set_uint32 buf pos_meta 0;
    B.set_uint8 buf pos_flags 0;
    i

  (*
   |<-- Segments (32 or more)   -->|<-- index 4B -->|<- meta 4B ->|
                                                              s    side flag
                                                               z   size flag
                                                                k  kind flag

   If the segment encoding > 32bytes, then another cell is used.
   The maximum segment encoding is 66bytes.  The whole fits in 2 cells:
     66 + 4 + 4 = 74

   Segments

   |lenL(1B)|<-- segment L (upto 32B) -->|lenR(1B)|<-- segment R (upto 32B) -->|
   lenL, lenR : nBytes of encodings
  *)
  let write_internal storage (segL, iL, segR, iR) =
    let strL = Segment.Serialization.encode segL in
    let strR = Segment.Serialization.encode segR in
    let large (* requires 2 cells? *) =
      String.length strL
      + String.length strR
      + 2
      > 32
    in
    let ncells = if large then 2 else 1 in
    let+? i = new_indices storage ncells in
    let buf = get_bytes storage i (bytes_per_cell * ncells) in
    B.set_uint8 buf 0 (String.length strL);
    B.write_string strL buf 1;
    B.set_uint8 buf (String.length strL + 1) (String.length strR);
    B.write_string strR buf (String.length strL + 2);
    let i' = Index.pred i in
    let index, side =
      if iL = i' then iR, true
      else if iR = i' then iL, false
      else begin
        Format.eprintf "ncells %d iL %a iR %a i %a i' %a@." ncells Index.pp iL Index.pp iR Index.pp i Index.pp i';
        assert false
      end
    in
    let iLatter = if large then Index.succ i else i in
    let buf = get_cell storage iLatter in
    B.set_index buf pos_index index;
    B.set_uint32 buf pos_meta 0;
    B.set_uint8 buf pos_flags
      (match large (*0x02*), side (*0x04*) with
       | true, false -> 0x03
       | true, true -> 0x07
       | false, false -> 0x01
       | false, true -> 0x05);
    iLatter

  let segment_of_key = segment_of_hash
  let key_of_segment s = Some (hash_of_segment s)
end

include Patricia_storage.Make(P)

let open_for_write ?resize_step_bytes ~key fn =
  open_for_write ?resize_step_bytes ~config:P.config ~key fn

let children t =
  let tbl = Hashtbl.create 100 in
  let+ () =
    iter (fun ch ({parent=pcho; _} as ent) ->
        Lwt.return @@ match pcho with
        | None -> ()
        | Some pch -> Hashtbl.add tbl pch (ch,ent)) t
  in
  Hashtbl.find_all tbl

let geneses t =
  fold (fun key entry acc ->
      Lwt.return @@
      match entry.parent with
      | None -> (key,entry) :: acc
      | Some _ -> acc) t []

let ordered_fold f t acc =
  let tbl = Hashtbl.create 100 in
  let* start =
    fold (fun ch ({index= _; parent=pcho} as ent) acc ->
        Lwt.return @@
        match pcho with
        | None -> (ch,ent)::acc
        | Some pch when not @@ mem t pch -> (ch,ent)::acc
        | Some pch -> Hashtbl.add tbl pch (ch, ent); acc)
      t []
  in
  let children = Hashtbl.find_all tbl in
  let rec loop acc = function
    | [] -> Lwt.return acc
    | (ch,ent)::xs ->
        let hents = children ch in
        let* acc = f ch ent ~children:hents acc in
        loop acc (hents @ xs)
  in
  loop acc start