irmin-pack-tools: Add a GUI for tezos stores

src/irmin-pack-tools/store_ui/context.ml

@@ -0,0 +1,49 @@
+open Tsdl
+open Tsdl_ttf
+open Optint
+open Sdl_util
+
+type ctx = {
+  r : Sdl.renderer;
+  w : Sdl.window;
+  wr : Sdl.rect;
+  f : Ttf.font;
+  indexes : (string * Int63.t) list;
+  store_path : string;
+  mutable drag : (int * int) option;
+  mutable current : int;
+  mutable last_refresh : float;
+  mutable updated : bool
+}
+
+let get_window_rect () =
+  let open Sdl.Rect in
+  let bounds = get @@ Sdl.get_display_bounds 0 in
+  let usable_bounds = get @@ Sdl.get_display_usable_bounds 0 in
+  let uw = w usable_bounds in
+  let uh = h usable_bounds in
+  create ~x:(w bounds - uw) ~y:(Sdl.Rect.h bounds - uh) ~w:uw ~h:uh
+
+let init_context store_path font_path i =
+  let wr = get_window_rect () in
+  let w =
+    let open Sdl.Rect in
+    get
+    @@ Sdl.create_window ~x:(x wr) ~y:(y wr) ~w:(w wr) ~h:(h wr) "Tezos store explorer" Sdl.Window.opengl
+  in
+  let r =
+    get @@ Sdl.create_renderer ~index:(-1) ~flags:Sdl.Renderer.accelerated w
+  in
+  let f =
+    get @@ Ttf.open_font font_path
+    12
+  in
+  let last_refresh = Unix.gettimeofday () in
+  let indexes = Load_tree.load_index store_path in
+  let current = i in
+  { r; w; wr; f; store_path; indexes; current; drag = None; last_refresh; updated = false }
+
+let delete_context ctx =
+  Ttf.close_font ctx.f;
+  Sdl.destroy_renderer ctx.r;
+  Sdl.destroy_window ctx.w

src/irmin-pack-tools/store_ui/dune

@@ -0,0 +1,8 @@
+(executable
+ (public_name irmin-tezos-explorer-gui)
+ (package irmin-pack-tools)
+ (name main)
+ (modules main context load_tree tree sdl_util layout loading)
+ (libraries prettree tsdl tsdl-ttf fmt irmin_pack irmin_tezos cmdliner)
+ (preprocess
+  (pps ppx_repr)))

src/irmin-pack-tools/store_ui/layout.ml

@@ -0,0 +1,154 @@
+open Tree
+open Sdl_util
+open Context
+
+type texture_data = {
+  min_w : float;
+  max_w : float;
+  min_h : float;
+  max_h : float;
+  scale_w : float;
+  scale_h : float;
+  zoom : float
+}
+
+let must_be_shown (x, y) (size_w, size_h) t =
+  x +. size_w >= t.min_w && x <= (t.max_w +. t.zoom /. t.zoom) && y +. size_h >= t.min_h && y <= (t.max_h +. t.zoom /. t.zoom)
+
+let scale_text_rect ttx_r (scale_w, scale_h) =
+  let open Tsdl in
+  let text_w = float (Sdl.Rect.w ttx_r) in
+  let text_h = float (Sdl.Rect.h ttx_r) in
+  let corrected_w = min scale_w text_w in
+  let corrected_h = min scale_h text_h in
+  Sdl.Rect.(create ~x:(x ttx_r + (int @@ (text_w -. corrected_w) /. 2.)) ~y:(y ttx_r) ~w:(int corrected_w) ~h:(int corrected_h))
+
+let render_rect renderer color size (ttx_t, ttx_r, ttx_width) current (x, y) t =
+  let scale_w, scale_h = t.scale_w *. t.zoom *. size, t.scale_h *. t.zoom *. size in
+  let x', y' = (x -. t.min_w) *. scale_w, (y -. t.min_h) *. scale_h in
+  let scale_w = scale_w *. ttx_width in
+  let must_be_shown = must_be_shown (x, y) (size *. ttx_width, size) t in
+  if must_be_shown
+  then
+    (
+    if min scale_w scale_h < 1. then draw_point renderer color (x', y')
+    else (
+      if not current then
+        fill_rect renderer light_grey (x', y') (scale_w, scale_h);
+      draw_rect renderer color (x', y') (scale_w, scale_h);
+      let center = (x' +. (scale_w /. 2.), y' +. (scale_h /. 2.)) in
+      let ttx_r  = scale_text_rect (ttx_r center) (scale_w, scale_h) in
+      render_text renderer ttx_t ttx_r));
+  (must_be_shown, (x' +. (scale_w /. 2.), y'), (x' +. (scale_w /. 2.), y' +. scale_h)), t
+
+let render_link renderer ((b1, _, bottom), _) ((b2, top, _), _) =
+  if b1 || b2
+  then draw_line renderer bottom top
+
+let get_text_texture ctx text =
+  let open Tsdl in
+  let open Tsdl_ttf in
+  let s = get @@ Ttf.render_text_solid ctx.f text black in
+  let ttf_w, ttf_h = Sdl.get_surface_size s in
+  let text_texture = get @@ Sdl.create_texture_from_surface ctx.r s in
+  Sdl.free_surface s;
+  let text_rect (c_x, c_y) =
+    Sdl.Rect.create
+      ~x:(int @@ (c_x -. (float ttf_w /. 2.)))
+      ~y:(int @@ (c_y -. (float ttf_h /. 2.)))
+      ~w:ttf_w ~h:ttf_h
+  in
+  text_texture, text_rect, float ttf_w /. 10.
+
+let layout ctx loading =
+  let rec layout_rec { depth = _; path; obj; current } =
+    let open Prettree in
+    Loading.update loading;
+    let size = 1. in
+    match obj with
+    | Leaf ->
+        loading.current.entries <- loading.current.entries + 1;
+        let text_texture, text_rect, text_width = get_text_texture ctx path in
+        Prettree.make
+          (size *. text_width, size)
+          (fun pos t ->
+            render_rect ctx.r blue size (text_texture, text_rect, text_width) current pos t)
+    | Commit None ->
+        loading.current.commits <- loading.current.commits + 1;
+        let text_texture, text_rect, text_width = get_text_texture ctx path in
+        Prettree.make
+          (size *. text_width, size)
+          (fun pos t ->
+              render_rect ctx.r red size (text_texture, text_rect, text_width) current pos t)
+    | Commit (Some child) ->
+        loading.current.commits <- loading.current.commits + 1;
+        Prettree.vert
+        @@
+        let open Prettree.Syntax in
+        let+ parent =
+        let text_texture, text_rect, text_width = get_text_texture ctx path in
+        Prettree.make
+          (size *. text_width, size)
+            (fun pos t ->
+                render_rect ctx.r red size (text_texture, text_rect, text_width) current pos t)
+        and+ () = Prettree.padding 1.
+        and+ child = layout_rec child in
+        fun t ->
+          let parent_info = parent t in
+          let child_info = child t in
+          render_link ctx.r parent_info child_info;
+          parent_info
+    | Inode i -> (
+        loading.current.inodes <- loading.current.inodes + 1;
+        match i with
+        | Values None ->
+          let text_texture, text_rect, text_width = get_text_texture ctx path in
+          Prettree.make
+            (size *. text_width, size)
+                (fun pos t ->
+                  render_rect ctx.r green size (text_texture, text_rect, text_width) current pos t)
+        | Values (Some l) ->
+            Prettree.vert
+            @@
+            let open Prettree.Syntax in
+            let+ parent =
+            let text_texture, text_rect, text_width = get_text_texture ctx path in
+            Prettree.make
+              (size *. text_width, size)
+                    (fun pos t ->
+                      render_rect ctx.r green size (text_texture, text_rect, text_width) current pos t)
+            and+ () = Prettree.padding 1.
+            and+ l = horz (list ~padding:size (List.map layout_rec l)) in
+            fun scale ->
+              let parent_pos = parent scale in
+              List.iter
+                (fun child -> render_link ctx.r parent_pos (child scale))
+                l;
+              parent_pos
+        | Tree None ->
+          let text_texture, text_rect, text_width = get_text_texture ctx path in
+          Prettree.make
+            (size *. text_width, size)
+                (fun pos t ->
+                  render_rect ctx.r purple size (text_texture, text_rect, text_width) current pos t)
+        | Tree (Some l) ->
+            Prettree.vert
+            @@
+            let open Prettree.Syntax in
+            let+ parent =
+            let text_texture, text_rect, text_width = get_text_texture ctx path in
+            Prettree.make
+              (size *. text_width, size)
+                    (fun pos t ->
+                      render_rect ctx.r purple size (text_texture, text_rect, text_width) current pos t)
+            and+ () = Prettree.padding 1.
+            and+ l = horz (list ~padding:size (List.map layout_rec l)) in
+            fun scale ->
+              let parent_pos = parent scale in
+              List.iter
+                (fun child -> render_link ctx.r parent_pos (child scale))
+                l;
+              parent_pos)
+  in
+  Loading.set_state loading Gen_layout;
+  layout_rec

src/irmin-pack-tools/store_ui/load_tree.ml

@@ -0,0 +1,180 @@
+open Optint
+module Kind = Irmin_pack.Pack_value.Kind
+module Conf = Irmin_tezos.Conf
+module Schema = Irmin_tezos.Schema
+module Maker = Irmin_pack_unix.Maker (Conf)
+module Store = Maker.Make (Schema)
+module Hash = Store.Hash
+module Key = Irmin_pack_unix.Pack_key.Make (Hash)
+module Io = Irmin_pack_unix.Io.Unix
+module Errs = Irmin_pack_unix.Io_errors.Make (Io)
+module Index = Irmin_pack_unix.Index.Make (Hash)
+module File_manager = Irmin_pack_unix.File_manager.Make (Io) (Index) (Errs)
+module Dispatcher = Irmin_pack_unix.Dispatcher.Make (File_manager)
+
+module Inode = struct
+  module Value = Schema.Node (Key) (Key)
+  include Irmin_pack.Inode.Make_internal (Conf) (Hash) (Key) (Value)
+
+  type compress = Compress.t [@@deriving repr ~decode_bin]
+end
+
+module Commit = struct
+  module Value = struct
+    include Schema.Commit (Key) (Key)
+    module Info = Schema.Info
+  end
+
+  include Irmin_pack.Pack_value.Of_commit (Hash) (Key) (Value)
+
+  type compress = Commit_direct.t [@@deriving repr ~decode_bin]
+end
+
+module Varint = struct
+  type t = int [@@deriving repr ~decode_bin ~encode_bin]
+
+  let max_encoded_size = 9
+end
+
+let max_bytes_needed_to_discover_length =
+  Hash.hash_size + 1 + Varint.max_encoded_size
+
+let min_bytes_needed_to_discover_length = Hash.hash_size + 1
+
+let decode_entry_header buffer =
+  let buffer = Bytes.unsafe_to_string buffer in
+  let i0 = 0 in
+
+  let imagic = i0 + Hash.hash_size in
+  let kind = Kind.of_magic_exn buffer.[imagic] in
+
+  let ilength = i0 + Hash.hash_size + 1 in
+  let pos_ref = ref ilength in
+  let suffix_length = Varint.decode_bin buffer pos_ref in
+  let length_length = !pos_ref - ilength in
+
+  (kind, Hash.hash_size + 1 + length_length + suffix_length)
+
+let decode_entry dispatcher buffer off =
+  let _ =
+    Dispatcher.read_range_exn dispatcher ~off
+      ~min_len:min_bytes_needed_to_discover_length
+      ~max_len:max_bytes_needed_to_discover_length buffer
+  in
+  let kind, len = decode_entry_header buffer in
+  let _ = Dispatcher.read_exn dispatcher ~off ~len:Hash.hash_size buffer in
+  let hash = Bytes.sub_string buffer 0 Hash.hash_size in
+  let _ = Dispatcher.read_exn dispatcher ~off ~len buffer in
+  let content = Bytes.sub_string buffer 0 len in
+  (hash, kind, len, content)
+
+exception Commit of string * Int63.t
+
+let buffer = Bytes.create (4096 * 4096)
+
+let get_entry dispatcher off =
+  let _, _, _, contents = decode_entry dispatcher buffer off in
+  contents
+
+open Tree
+
+let load_inode dispatcher addr =
+  let contents = get_entry dispatcher addr in
+  contents
+
+let load_commit dispatcher addr =
+  let contents = get_entry dispatcher addr in
+  let entry_header = Hash.hash_size + 2 in
+  let contents_len = String.length contents - entry_header in
+  let contents = String.sub contents entry_header contents_len in
+  contents
+
+let get_name dict (n : Inode.Compress.name) =
+  match n with
+  | Indirect dict_key ->
+      let key = File_manager.Dict.find dict dict_key in
+      Option.get key
+  | Direct step -> step
+
+let get_tree_from_commit (loading : Loading.t) dispatcher dict max_depth
+    last_commit_off commit_hash =
+  let rec get_commit_tree depth (commit : Commit.Commit_direct.t) =
+    loading.max.commits <- loading.max.commits + 1;
+    Loading.update loading;
+    if depth <> max_depth then
+      match commit.node_offset with
+      | Offset addr ->
+          let current = addr > last_commit_off in
+          let contents = load_inode dispatcher addr in
+          let inode = Inode.decode_bin_compress contents (ref 0) in
+          {
+            depth;
+            path = commit_hash;
+            obj = Commit (Some (get_node_tree (depth + 1) "root" inode current));
+            current = true;
+          }
+      | Hash _hash -> assert false
+    else { depth; path = commit_hash; obj = Commit None; current = true }
+  and get_node_tree depth name (inode : Inode.compress) current =
+    let addr_show name (addr : Inode.Compress.address) =
+      match addr with
+      | Offset addr ->
+          let current = addr > last_commit_off in
+          let contents = load_inode dispatcher addr in
+          let inode = Inode.decode_bin_compress contents (ref 0) in
+          get_node_tree (depth + 1) name inode current
+      | Hash _hash -> assert false
+    in
+    let value (v : Inode.Compress.value) =
+      match v with
+      | Contents (n, addr, ()) -> (
+          match addr with
+          | Offset addr ->
+              let current = addr > last_commit_off in
+              loading.max.entries <- loading.max.entries + 1;
+              Loading.update loading;
+              { depth = depth + 1; path = get_name dict n; obj = Leaf; current }
+          | Hash _hash -> assert false)
+      | Node (n, addr) -> addr_show (get_name dict n) addr
+    in
+    let ptr (p : Inode.Compress.ptr) =
+      addr_show (string_of_int p.index) p.hash
+    in
+    let tree (t : Inode.Compress.tree) = List.map ptr t.entries in
+    let v (tv : Inode.Compress.v) =
+      if depth <> max_depth && current then
+        match tv with
+        | Values l -> Tree.Values (Some (List.map value l))
+        | Tree t -> Tree (Some (tree t))
+      else match tv with Values _ -> Tree.Values None | Tree _ -> Tree None
+    in
+    let l =
+      match inode.tv with
+      | V1_stable tv | V1_unstable tv -> v tv
+      | V2_root tv | V2_nonroot tv -> v tv.v
+    in
+    loading.max.inodes <- loading.max.inodes + 1;
+    Loading.update loading;
+    { depth; path = name; obj = Inode l; current }
+  in
+  get_commit_tree 0
+
+let load_tree loading store_path ~max_depth (hash, off) last_commit_off =
+  Loading.set_state loading Load_tree;
+  let conf = Irmin_pack.Conf.init store_path in
+  let fm = Errs.raise_if_error @@ File_manager.open_ro conf in
+  let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in
+  let dict = File_manager.dict fm in
+  let contents = load_commit dispatcher off in
+  let commit = Commit.decode_bin_compress contents (ref 0) in
+  get_tree_from_commit loading dispatcher dict max_depth last_commit_off hash
+    commit
+
+let load_index store_path =
+  let index = Index.v_exn ~readonly:true ~log_size:500_000 store_path in
+  let l = ref [] in
+  Index.iter
+    (fun h (off, _, _) -> l := (string_of_int @@ Hash.short_hash h, off) :: !l)
+    index;
+  let cmp (_, off1) (_, off2) = Int63.(to_int @@ sub off1 off2) in
+  List.sort cmp !l