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,77 @@ 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 }
+
+  module Sequential = struct
+    let create_accessor_exn prefix_len suffix_len ~off ~len =
+      let open Int63.Syntax in
+      if off >= prefix_len then
+        let off = off - prefix_len in
+        let entry_end_offset = off + Int63.of_int len in
+        if entry_end_offset > suffix_len then
+          raise (Errors.Pack_error `Read_out_of_bounds)
+        else { poff = off; len; location = Suffix }
+      else
+        let entry_end_offset = off + Int63.of_int len in
+        if entry_end_offset > prefix_len then
+          raise (Errors.Pack_error `Read_out_of_bounds)
+        else { poff = off; len; location = Prefix }
+
+    let create_accessor_from_range_exn prefix_len suffix_len ~off ~min_len
+        ~max_len =
+      let open Int63.Syntax in
+      if off >= prefix_len then
+        let off = off - prefix_len in
+        let max_entry_len = suffix_len - off in
+        let len =
+          let min_len = Int63.of_int min_len in
+          let max_len = Int63.of_int max_len in
+          if suffix_len < min_len then
+            raise (Errors.Pack_error `Read_out_of_bounds)
+          else if max_entry_len > max_len then max_len
+          else max_entry_len
+        in
+        let len = Int63.to_int len in
+        { poff = off; len; location = Suffix }
+      else
+        let max_entry_len = prefix_len - off in
+        let len =
+          let min_len = Int63.of_int min_len in
+          let max_len = Int63.of_int max_len in
+          if prefix_len < min_len then
+            raise (Errors.Pack_error `Read_out_of_bounds)
+          else if max_entry_len > max_len then max_len
+          else max_entry_len
+        in
+        let len = Int63.to_int len in
+        { poff = off; len; location = Prefix }
+
+    let create_accessor_seq t ~min_header_len ~max_header_len ~read_len =
+      let open Int63.Syntax in
+      let buf = Bytes.create max_header_len in
+      let prefix_len =
+        match Fm.prefix t.fm with
+        | Some prefix -> (
+            match Io.read_size prefix with
+            | Ok len -> len
+            | Error _ -> Int63.zero)
+        | None -> Int63.zero
+      in
+      let suffix_len = Fm.Suffix.end_offset (Fm.suffix t.fm) in
+      let end_offset = prefix_len + suffix_len in
+      let f off =
+        if off < end_offset then (
+          let accessor =
+            create_accessor_from_range_exn prefix_len suffix_len ~off
+              ~min_len:min_header_len ~max_len:max_header_len
+          in
+          read_exn t accessor buf;
+          let len = read_len buf in
+          Some
+            ( (off, create_accessor_exn prefix_len suffix_len ~off ~len),
+              Int63.(add off (of_int len)) ))
+        else None
+      in
+      Seq.unfold f Int63.zero
+  end
 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,38 @@ module type S = sig
   (** [shrink_accessor_exn a ~new_len] is [a] where the length is smaller than
       in [a].*)
 
+  module Sequential : sig
+    val create_accessor_exn : int63 -> int63 -> off:int63 -> len:int -> accessor
+    (** [create_accessor_exn prefix_len suffix_len ~off ~len] returns an
+        accessor if [off] and [len] designate a readable area of the pack
+        files, otherwise it raises one of [Errors.Pack_error `Read_out_of_bounds].
+        [prefix_len] and [suffix_len] are directly given to the function as they
+        are computed by costly functions to call.
+        In the contrary of the above create_accessor_exn function, it does not
+        take "virtual" lengths (aka. lengths taking gc'ed chunks into account),
+        but physical lengths in argument. *)
+
+    val create_accessor_from_range_exn :
+      int63 -> int63 -> off:int63 -> min_len:int -> max_len:int -> accessor
+    (** [create_accessor_from_range_exn] is similar to
+        [create_accessor_exn] except that the precise length of the span will be
+        decided during the call. *)
+
+    val create_accessor_seq :
+      t ->
+      min_header_len:int ->
+      max_header_len:int ->
+      read_len:(bytes -> int) ->
+      (int63 * accessor) Seq.t
+    (** [create_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)*)
+  end
+
   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 =