Merge pull request #2084 from metanivek/mv-pack-key-value

src/irmin-pack/pack_key.ml

@@ -15,111 +15,15 @@
  *)
 
 open! Import
-include Pack_key_intf
-
-type 'hash state =
-  | Direct of { hash : 'hash; offset : int63; length : int }
-  | Indexed of 'hash
-
-type 'hash t = { mutable state : 'hash state }
-
-let inspect t = t.state
-let to_hash t = match t.state with Direct t -> t.hash | Indexed h -> h
-
-let promote_exn t ~offset ~length =
-  let () =
-    match t.state with
-    | Direct _ ->
-        Fmt.failwith "Attempted to promote a key that is already Direct"
-    | Indexed _ -> ()
-  in
-  t.state <- Direct { hash = to_hash t; offset; length }
-
-let t : type h. h Irmin.Type.t -> h t Irmin.Type.t =
- fun hash_t ->
-  let open Irmin.Type in
-  variant "t" (fun direct indexed t ->
-      match t.state with
-      | Direct { hash; offset; length } -> direct (hash, offset, length)
-      | Indexed x1 -> indexed x1)
-  |~ case1 "Direct" [%typ: hash * int63 * int] (fun (hash, offset, length) ->
-         { state = Direct { hash; offset; length } })
-  |~ case1 "Indexed" [%typ: hash] (fun x1 -> { state = Indexed x1 })
-  |> sealv
-
-let t (type hash) (hash_t : hash Irmin.Type.t) =
-  let module Hash = struct
-    type t = hash
-    [@@deriving irmin ~equal ~compare ~pre_hash ~encode_bin ~decode_bin]
-
-    let unboxed_encode_bin = Irmin.Type.(unstage (Unboxed.encode_bin t))
-    let unboxed_decode_bin = Irmin.Type.(unstage (Unboxed.decode_bin t))
-
-    let encoded_size =
-      match Irmin.Type.Size.of_value t with
-      | Static n -> n
-      | Dynamic _ | Unknown ->
-          Fmt.failwith "Hash must have a fixed-width binary encoding"
-  end in
-  (* Equality and ordering on keys respects {i structural} equality semantics,
-     meaning two objects (containing keys) are considered equal even if their
-     children are stored at different offsets (either as duplicates in the same
-     pack file, or inside different pack files), or with different lengths (in
-     the event that the encoding environments were different). *)
-  let equal a b = Hash.equal (to_hash a) (to_hash b) in
-  let compare a b = Hash.compare (to_hash a) (to_hash b) in
-  (* The pre-hash image of a key is just the hash of the corresponding value.
-
-     NOTE: it's particularly important that we discard the file offset when
-     computing hashes of structured values (e.g. inodes), so that this hashing
-     process is reproducible in different stores (w/ different offsets for the
-     values). *)
-  let pre_hash t f = Hash.pre_hash (to_hash t) f in
-  let encode_bin t f = Hash.encode_bin (to_hash t) f in
-  let unboxed_encode_bin t f = Hash.unboxed_encode_bin (to_hash t) f in
-  let decode_bin buf pos_ref =
-    { state = Indexed (Hash.decode_bin buf pos_ref) }
-  in
-  let unboxed_decode_bin buf pos_ref =
-    { state = Indexed (Hash.unboxed_decode_bin buf pos_ref) }
-  in
-  let size_of = Irmin.Type.Size.custom_static Hash.encoded_size in
-  Irmin.Type.like (t hash_t) ~pre_hash ~equal ~compare
-    ~bin:(encode_bin, decode_bin, size_of)
-    ~unboxed_bin:(unboxed_encode_bin, unboxed_decode_bin, size_of)
-
-let v_direct ~hash ~offset ~length = { state = Direct { hash; offset; length } }
-let v_indexed hash = { state = Indexed hash }
 
 module type S = sig
-  type hash
-
-  include S with type t = hash t and type hash := hash
-end
-
-module Make (Hash : Irmin.Hash.S) = struct
-  type nonrec t = Hash.t t [@@deriving irmin]
-  type hash = Hash.t [@@deriving irmin ~of_bin_string]
+  include Irmin.Key.S
 
-  let to_hash = to_hash
-  let null_offset = Int63.minus_one
-  let null_length = -1
+  val null : t
 
-  let null =
-    let buf = String.make Hash.hash_size '\000' in
-    let hash =
-      match hash_of_bin_string buf with Ok x -> x | Error _ -> assert false
-    in
-    v_direct ~hash ~offset:null_offset ~length:null_length
-
-  let unfindable_of_hash hash =
-    v_direct ~hash ~offset:null_offset ~length:null_length
-end
-
-module type Store_spec = sig
-  type ('h, _) contents_key = 'h t
-  type 'h node_key = 'h t
-  type 'h commit_key = 'h t
+  val unfindable_of_hash : hash -> t
+  (** [unfindable_of_hash h] is a key [k] such that [to_hash k = h], with an
+      unspecified internal representation. This function enables an efficient
+      implmentation of "portable" inodes, but is otherwise unused. Attempting to
+      dereference a key constructed in this way results in undefined behaviour. *)
 end
-
-module rec Store_spec : Store_spec = Store_spec

src/irmin-pack/pack_value.ml

@@ -98,7 +98,6 @@ end
 type ('h, 'a) value = { hash : 'h; kind : Kind.t; v : 'a } [@@deriving irmin]
 
 module type S = S with type kind := Kind.t
-module type Persistent = Persistent with type kind := Kind.t
 
 let get_dynamic_sizer_exn : type a. a Irmin.Type.t -> string -> int -> int =
  fun typ ->

src/irmin-pack/pack_value_intf.ml

@@ -50,12 +50,6 @@ module type S = sig
   val decode_bin_length : string -> int -> int
 end
 
-module type Persistent = sig
-  type hash
-
-  include S with type hash := hash and type key = hash Pack_key.t
-end
-
 module type T = sig
   type t
 end
@@ -91,7 +85,6 @@ module type Sigs = sig
   end
 
   module type S = S with type kind := Kind.t
-  module type Persistent = Persistent with type kind := Kind.t
   module type Config = Config
 
   module Of_contents

src/irmin-pack/unix/ext.ml

@@ -239,9 +239,7 @@ module Maker (Config : Conf.S) = struct
               if t.during_batch then Error `Gc_forbidden_during_batch else Ok ()
             in
             let* commit_key =
-              let state : _ Irmin_pack.Pack_key.state =
-                Irmin_pack.Pack_key.inspect commit_key
-              in
+              let state : _ Pack_key.state = Pack_key.inspect commit_key in
               match state with
               | Direct _ -> Ok commit_key
               | Indexed h -> (
@@ -253,9 +251,7 @@ module Maker (Config : Conf.S) = struct
                   | Some (k, _kind) -> Ok k)
             in
             let offset =
-              let state : _ Irmin_pack.Pack_key.state =
-                Irmin_pack.Pack_key.inspect commit_key
-              in
+              let state : _ Pack_key.state = Pack_key.inspect commit_key in
               match state with
               | Direct x -> x.offset
               | Indexed _ -> assert false

src/irmin-pack/unix/gc.ml

@@ -126,7 +126,7 @@ module Worker = struct
        existing written data. *)
     let transfer_parent_commit_exn ~read_exn ~write_exn ~mapping key =
       let off, len =
-        match Irmin_pack.Pack_key.inspect key with
+        match Pack_key.inspect key with
         | Indexed _ ->
             (* As this is the second time we are reading this key, this case is
                unreachable. *)
@@ -181,9 +181,7 @@ module Worker = struct
         | Some commit -> commit
       in
       let commit_offset, _ =
-        let state : _ Irmin_pack.Pack_key.state =
-          Irmin_pack.Pack_key.inspect commit_key
-        in
+        let state : _ Pack_key.state = Pack_key.inspect commit_key in
         match state with
         | Indexed _ -> assert false
         | Direct x -> (x.offset, x.length)
@@ -202,7 +200,7 @@ module Worker = struct
            because, when decoding the [Commit_value.t] at [commit_key], the
            parents will have to be read in order to produce a key for them. *)
         let register_object_exn key =
-          match Irmin_pack.Pack_key.inspect key with
+          match Pack_key.inspect key with
           | Indexed _ ->
               raise
                 (Pack_error (`Commit_parent_key_is_indexed (string_of_key key)))
@@ -213,7 +211,7 @@ module Worker = struct
 
         (* Step 3.3 Put the nodes and contents in the reachable file. *)
         let register_object_exn key =
-          match Irmin_pack.Pack_key.inspect key with
+          match Pack_key.inspect key with
           | Indexed _ ->
               raise
                 (Pack_error

src/irmin-pack/unix/gc_intf.ml

@@ -24,7 +24,7 @@ module type Args = sig
   module Dispatcher : Dispatcher.S with module Fm = Fm
 
   type hash
-  type key = hash Irmin_pack.Pack_key.t [@@deriving irmin]
+  type key = hash Pack_key.t [@@deriving irmin]
 
   module Hash : sig
     val hash_size : int

src/irmin-pack/unix/import.ml

@@ -40,14 +40,12 @@ end
 
 type int63 = Int63.t [@@deriving irmin]
 
-module Pack_value = Irmin_pack.Pack_value
 module Version = Irmin_pack.Version
 
 module type S = Irmin_pack.S
 
 module Conf = Irmin_pack.Conf
 module Layout = Irmin_pack.Layout
-module Pack_key = Irmin_pack.Pack_key
 module Stats = Stats
 module Indexable = Irmin_pack.Indexable
 

src/irmin-pack/unix/inode.ml

@@ -14,7 +14,6 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
-open Import
 include Irmin_pack.Inode
 include Inode_intf
 

src/irmin-pack/unix/irmin_pack_unix.ml

@@ -18,6 +18,8 @@ module Stats = Stats
 module Index = Pack_index
 module Inode = Inode
 module Pack_store = Pack_store
+module Pack_key = Pack_key
+module Pack_value = Pack_value
 module Io_legacy = Io_legacy
 module Checks = Checks
 module Atomic_write = Atomic_write
@@ -40,7 +42,7 @@ module KV (Config : Irmin_pack.Conf.S) = struct
   type endpoint = unit
   type hash = Irmin.Schema.default_hash
 
-  include Irmin_pack.Pack_key.Store_spec
+  include Pack_key.Store_spec
   module Maker = Maker (Config)
 
   type metadata = Irmin.Metadata.None.t

src/irmin-pack/unix/pack_key.ml

@@ -0,0 +1,125 @@
+(*
+ * Copyright (c) 2018-2022 Tarides <contact@tarides.com>
+ *
+ * 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.
+ *)
+
+open! Import
+include Pack_key_intf
+
+type 'hash state =
+  | Direct of { hash : 'hash; offset : int63; length : int }
+  | Indexed of 'hash
+
+type 'hash t = { mutable state : 'hash state }
+
+let inspect t = t.state
+let to_hash t = match t.state with Direct t -> t.hash | Indexed h -> h
+
+let promote_exn t ~offset ~length =
+  let () =
+    match t.state with
+    | Direct _ ->
+        Fmt.failwith "Attempted to promote a key that is already Direct"
+    | Indexed _ -> ()
+  in
+  t.state <- Direct { hash = to_hash t; offset; length }
+
+let t : type h. h Irmin.Type.t -> h t Irmin.Type.t =
+ fun hash_t ->
+  let open Irmin.Type in
+  variant "t" (fun direct indexed t ->
+      match t.state with
+      | Direct { hash; offset; length } -> direct (hash, offset, length)
+      | Indexed x1 -> indexed x1)
+  |~ case1 "Direct" [%typ: hash * int63 * int] (fun (hash, offset, length) ->
+         { state = Direct { hash; offset; length } })
+  |~ case1 "Indexed" [%typ: hash] (fun x1 -> { state = Indexed x1 })
+  |> sealv
+
+let t (type hash) (hash_t : hash Irmin.Type.t) =
+  let module Hash = struct
+    type t = hash
+    [@@deriving irmin ~equal ~compare ~pre_hash ~encode_bin ~decode_bin]
+
+    let unboxed_encode_bin = Irmin.Type.(unstage (Unboxed.encode_bin t))
+    let unboxed_decode_bin = Irmin.Type.(unstage (Unboxed.decode_bin t))
+
+    let encoded_size =
+      match Irmin.Type.Size.of_value t with
+      | Static n -> n
+      | Dynamic _ | Unknown ->
+          Fmt.failwith "Hash must have a fixed-width binary encoding"
+  end in
+  (* Equality and ordering on keys respects {i structural} equality semantics,
+     meaning two objects (containing keys) are considered equal even if their
+     children are stored at different offsets (either as duplicates in the same
+     pack file, or inside different pack files), or with different lengths (in
+     the event that the encoding environments were different). *)
+  let equal a b = Hash.equal (to_hash a) (to_hash b) in
+  let compare a b = Hash.compare (to_hash a) (to_hash b) in
+  (* The pre-hash image of a key is just the hash of the corresponding value.
+
+     NOTE: it's particularly important that we discard the file offset when
+     computing hashes of structured values (e.g. inodes), so that this hashing
+     process is reproducible in different stores (w/ different offsets for the
+     values). *)
+  let pre_hash t f = Hash.pre_hash (to_hash t) f in
+  let encode_bin t f = Hash.encode_bin (to_hash t) f in
+  let unboxed_encode_bin t f = Hash.unboxed_encode_bin (to_hash t) f in
+  let decode_bin buf pos_ref =
+    { state = Indexed (Hash.decode_bin buf pos_ref) }
+  in
+  let unboxed_decode_bin buf pos_ref =
+    { state = Indexed (Hash.unboxed_decode_bin buf pos_ref) }
+  in
+  let size_of = Irmin.Type.Size.custom_static Hash.encoded_size in
+  Irmin.Type.like (t hash_t) ~pre_hash ~equal ~compare
+    ~bin:(encode_bin, decode_bin, size_of)
+    ~unboxed_bin:(unboxed_encode_bin, unboxed_decode_bin, size_of)
+
+let v_direct ~hash ~offset ~length = { state = Direct { hash; offset; length } }
+let v_indexed hash = { state = Indexed hash }
+
+module type S = sig
+  type hash
+
+  include Irmin_pack.Pack_key.S with type t = hash t and type hash := hash
+end
+
+module Make (Hash : Irmin.Hash.S) = struct
+  type nonrec t = Hash.t t [@@deriving irmin]
+  type hash = Hash.t [@@deriving irmin ~of_bin_string]
+
+  let to_hash = to_hash
+  let null_offset = Int63.minus_one
+  let null_length = -1
+
+  let null =
+    let buf = String.make Hash.hash_size '\000' in
+    let hash =
+      match hash_of_bin_string buf with Ok x -> x | Error _ -> assert false
+    in
+    v_direct ~hash ~offset:null_offset ~length:null_length
+
+  let unfindable_of_hash hash =
+    v_direct ~hash ~offset:null_offset ~length:null_length
+end
+
+module type Store_spec = sig
+  type ('h, _) contents_key = 'h t
+  type 'h node_key = 'h t
+  type 'h commit_key = 'h t
+end
+
+module rec Store_spec : Store_spec = Store_spec