irmin-pack: Add sequential accessors & clean dispatcher

src/irmin-pack/unix/dispatcher.ml

@@ -28,7 +28,7 @@ module Make (Fm : File_manager.S with module Io = Io.Unix) :
   module Errs = Fm.Errs
   module Control = Fm.Control
 
-  type t = { fm : Fm.t; root : string }
+  type t = { fm : Fm.t }
   type location = Prefix | Suffix [@@deriving irmin]
 
   type accessor = { poff : int63; len : int; location : location }
@@ -40,8 +40,8 @@ module Make (Fm : File_manager.S with module Io = Io.Unix) :
 
       [location] is a file identifier. *)
 
-  let v ~root fm =
-    let t = { fm; root } in
+  let v fm =
+    let t = { fm } in
     Ok t
 
   let get_prefix t =
@@ -250,4 +250,72 @@ module Make (Fm : File_manager.S with module Io = Io.Unix) :
   let shrink_accessor_exn a ~new_len =
     if new_len > a.len then failwith "shrink_accessor_exn to larger accessor";
     { a with len = new_len }
+
+  let create_sequential_accessor_exn location rem_len ~poff ~len =
+    if len > rem_len then raise (Errors.Pack_error `Read_out_of_bounds)
+    else { poff; len; location }
+
+  let create_sequential_accessor_from_range_exn location rem_len ~poff ~min_len
+      ~max_len =
+    let len =
+      if rem_len < min_len then raise (Errors.Pack_error `Read_out_of_bounds)
+      else if rem_len > max_len then max_len
+      else rem_len
+    in
+    { poff; len; location }
+
+  let create_sequential_accessor_seq t ~min_header_len ~max_header_len ~read_len
+      =
+    let preffix_chunks =
+      match Fm.mapping t.fm with
+      | Some mapping ->
+          let preffix_chunks = ref [] in
+          Mapping_file.iter mapping (fun ~off ~len ->
+              preffix_chunks := (off, len) :: !preffix_chunks)
+          |> Errs.raise_if_error;
+          List.rev !preffix_chunks
+      | None -> []
+    in
+    let suffix_end_offset = Fm.Suffix.end_offset (Fm.suffix t.fm) in
+    let entry_offset_suffix_start = entry_offset_suffix_start t in
+    let get_entry_accessor rem_len location poff =
+      let accessor =
+        create_sequential_accessor_from_range_exn location rem_len ~poff
+          ~min_len:min_header_len ~max_len:max_header_len
+      in
+      let buf = Bytes.create max_header_len in
+      read_exn t accessor buf;
+      let entry_len = read_len buf in
+      ( entry_len,
+        create_sequential_accessor_exn location rem_len ~poff ~len:entry_len )
+    in
+    let rec suffix_accessors poff () =
+      let open Seq in
+      let open Int63.Syntax in
+      if poff >= suffix_end_offset then Nil
+      else
+        let rem_len = Int63.to_int (suffix_end_offset - poff) in
+        let entry_len, accessor = get_entry_accessor rem_len Suffix poff in
+        let r = (entry_offset_suffix_start + poff, accessor) in
+        let poff = poff + Int63.of_int entry_len in
+        let f = suffix_accessors poff in
+        Cons (r, f)
+    in
+    let rec prefix_accessors poff acc () =
+      let open Seq in
+      match acc with
+      | [] -> suffix_accessors Int63.zero ()
+      | (off, rem_len) :: acc ->
+          if rem_len <= 0 then prefix_accessors poff acc ()
+          else
+            let entry_len, accessor = get_entry_accessor rem_len Suffix poff in
+            let r = (off, accessor) in
+            let rem_len = rem_len - entry_len in
+            let open Int63.Syntax in
+            let poff = poff + Int63.of_int entry_len in
+            let off = off + Int63.of_int entry_len in
+            let f = prefix_accessors poff ((off, rem_len) :: acc) in
+            Cons (r, f)
+    in
+    prefix_accessors Int63.zero preffix_chunks
 end

src/irmin-pack/unix/dispatcher_intf.ml

@@ -31,7 +31,7 @@ module type S = sig
       finalisation, an accessor could no longer point to a valid area because
       the GC changes the domain of valid readable areas) *)
 
-  val v : root:string -> Fm.t -> (t, [> Fm.Errs.t ]) result
+  val v : Fm.t -> (t, [> Fm.Errs.t ]) result
 
   val create_accessor_exn : t -> off:int63 -> len:int -> accessor
   (** [create_accessor_exn] returns an accessor if [off] and [len] designate a
@@ -50,6 +50,20 @@ module type S = sig
   (** [shrink_accessor_exn a ~new_len] is [a] where the length is smaller than
       in [a].*)
 
+  val create_sequential_accessor_seq :
+    t ->
+    min_header_len:int ->
+    max_header_len:int ->
+    read_len:(bytes -> int) ->
+    (int63 * accessor) Seq.t
+  (** [create_sequential_accessor_seq ~min_header_len ~max_header_len ~read_len]
+      returns a sequence of accessors, which simulates iterating sequentially
+      trough the entries of a pack file. [min_header_len] & [max_header_len]
+      represents the minimum & maximum lengths required to read the header of an
+      entry. [read_len] will then be called with a buffer containing the header
+      of the entry and should return the total length of the entry (the length
+      of he header plus the length of the payload)*)
+
   val read_exn : t -> accessor -> bytes -> unit
   (** [read_exn] either reads in the prefix or the suffix file, depending on
       [accessor]. *)

src/irmin-pack/unix/ext.ml

@@ -187,7 +187,7 @@ module Maker (Config : Conf.S) = struct
               | (`File | `Other), _ -> Errs.raise_error (`Not_a_directory root)
           in
           let dict = Dict.v fm |> Errs.raise_if_error in
-          let dispatcher = Dispatcher.v ~root fm |> Errs.raise_if_error in
+          let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in
           let contents = Contents.CA.v ~config ~fm ~dict ~dispatcher in
           let node = Node.CA.v ~config ~fm ~dict ~dispatcher in
           let commit = Commit.CA.v ~config ~fm ~dict ~dispatcher in

src/irmin-pack/unix/gc.ml

@@ -163,7 +163,7 @@ module Worker = struct
           Fm.close fm |> Errs.log_if_error "GC: Close File_manager")
       @@ fun () ->
       let dict = Dict.v fm |> Errs.raise_if_error in
-      let dispatcher = Dispatcher.v ~root fm |> Errs.raise_if_error in
+      let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in
       let node_store = Node_store.v ~config ~fm ~dict ~dispatcher in
       let commit_store = Commit_store.v ~config ~fm ~dict ~dispatcher in
 

src/irmin-pack/unix/snapshot.ml

@@ -60,10 +60,7 @@ module Make (Args : Args) = struct
          files: suffix and control. We just open the file manager for
          simplicity. *)
       let fm = Fm.open_ro config |> Fm.Errs.raise_if_error in
-      let dispatcher =
-        let root = Conf.root config in
-        Dispatcher.v ~root fm |> Fm.Errs.raise_if_error
-      in
+      let dispatcher = Dispatcher.v fm |> Fm.Errs.raise_if_error in
       let log_size = Conf.index_log_size config in
       { fm; dispatcher; log_size; inode_pack; contents_pack }
 

test/irmin-pack/common.ml

@@ -153,7 +153,7 @@ struct
     let f = ref (fun () -> ()) in
     let config = config ~readonly ~fresh name in
     let fm = get_fm config in
-    let dispatcher = Dispatcher.v ~root:name fm |> Errs.raise_if_error in
+    let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in
     (* open the index created by the fm. *)
     let index = File_manager.index fm in
     let dict = Dict.v fm |> Errs.raise_if_error in

test/irmin-pack/test_inode.ml

@@ -120,7 +120,7 @@ struct
       let config = config ~indexing_strategy ~readonly:false ~fresh:true root in
       let fm = get_fm config in
       let dict = Dict.v fm |> Errs.raise_if_error in
-      let dispatcher = Dispatcher.v ~root fm |> Errs.raise_if_error in
+      let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in
       let store = Inode.v ~config ~fm ~dict ~dispatcher in
       let store_contents = Contents_store.v ~config ~fm ~dict ~dispatcher in
       let+ foo, bar =