irmin-pack: Strengthen crash and SWMR consistencies

src/irmin-pack/atomic_write.ml

@@ -121,14 +121,8 @@ module Make_persistent (K : Irmin.Type.S) (V : Value) = struct
     in
     aux ()
 
-  let sync_offset t =
-    let former_offset = IO.offset t.block in
-    let offset = IO.force_offset t.block in
-    if offset > former_offset then refill t ~to_:offset ~from:former_offset
-
   let unsafe_find t k =
     [%log.debug "[branches] find %a" pp_key k];
-    if IO.readonly t.block then sync_offset t;
     try Some (Tbl.find t.cache k) with Not_found -> None
 
   let find t k = Lwt.return (unsafe_find t k)
@@ -234,7 +228,11 @@ module Make_persistent (K : Irmin.Type.S) (V : Value) = struct
     else Lwt.return_unit
 
   let close t = unsafe_close t
-  let flush t = IO.flush t.block
+
+  let sync t =
+    let former_offset = IO.offset t.block in
+    let offset = IO.force_offset t.block in
+    if offset > former_offset then refill t ~to_:offset ~from:former_offset
 end
 
 (* FIXME: remove code duplication with irmin/atomic_write *)
@@ -295,7 +293,7 @@ module Closeable (AW : S) = struct
     check_not_closed t;
     AW.clear t.t
 
-  let flush t =
+  let sync t =
     check_not_closed t;
-    AW.flush t.t
+    AW.sync t.t
 end

src/irmin-pack/atomic_write_intf.ml

@@ -17,7 +17,7 @@
 module type S = sig
   include Irmin.Atomic_write.S
 
-  val flush : t -> unit
+  val sync : t -> unit
 end
 
 module type Persistent = sig

src/irmin-pack/dict.ml

@@ -93,9 +93,9 @@ module Make (IO : IO.S) : S = struct
     t
 
   let close t =
+    (* If called from ext, flush was already called *)
     t.open_instances <- t.open_instances - 1;
     if t.open_instances = 0 then (
-      if not (IO.readonly t.io) then flush t;
       IO.close t.io;
       Hashtbl.reset t.cache;
       Hashtbl.reset t.index)

src/irmin-pack/ext.ml

@@ -127,6 +127,8 @@ module Maker (Config : Conf.S) = struct
         let branch_t t = t.branch
 
         let batch t f =
+          let readonly = Conf.readonly t.config in
+          if readonly then failwith "Can't batch an RO pack store";
           Commit.CA.batch t.commit (fun commit ->
               Node.CA.batch t.node (fun node ->
                   Contents.CA.batch t.contents (fun contents ->
@@ -169,12 +171,6 @@ module Maker (Config : Conf.S) = struct
           (f := fun () -> Contents.CA.flush ~index:false contents);
           { contents; node; commit; branch; config; index }
 
-        let close t =
-          Index.close t.index;
-          Contents.CA.close (contents_t t) >>= fun () ->
-          Node.CA.close (snd (node_t t)) >>= fun () ->
-          Commit.CA.close (snd (commit_t t)) >>= fun () -> Branch.close t.branch
-
         let v config =
           Lwt.catch
             (fun () -> unsafe_v config)
@@ -187,12 +183,64 @@ module Maker (Config : Conf.S) = struct
                   Lwt.fail e
               | e -> Lwt.fail e)
 
-        (** Stores share instances in memory, one sync is enough. *)
-        let sync t = Contents.CA.sync (contents_t t)
+        (** For crash consistency and SWMR consistency, the order in which we
+            [flush], [sync] and [clear] the various files should carefuly chosen
+            in order to avoid introducing dangling references from file to file.
+
+            There are 4 types of files (called components below), the ones in
+            index, the dict, the pack file and the branch one. Here are the
+            relations between them:
+
+            - the branch store references commit hashes in index,
+            - index references pack entries,
+            - the pack file references dict entries and
+            - the dict references nothing.
+
+            In case of crash (or an ro instance that concurrently syncs), the
+            [clear] the order should be: branch, index, pack and dict.
+
+            In case an rw instance concurrently flushes, the [sync] the order
+            should be: branch, index, pack and dict.
+
+            In case of new data in the 4 components that reference one another
+            and in case of crash (or an ro instance that concurrently syncs),
+            the [flush] order should be: dict, pack, index and branch.
+
+            It is expected that the branch store is always in a flushed state
+            and that it doesn't reference commits that weren't flushed to index.
+            For each operation:
+
+            - Irmin core should ensure that [clear] is applied on the branch
+              store before the others.
+            - [sync] below ensures that the branch store is synced before the
+              others.
+            - Irmin core should ensure that the branch store never [flush]es
+              during a [batch] (because we only add entries to the 3 other
+              components during [batch] and because we flush them at the end of
+              it). *)
+        let sync t =
+          let readonly = Conf.readonly t.config in
+          if not readonly then failwith "Can't sync a RW pack store";
+          Branch.sync t.branch;
+          (* Contents/Commit/Node stores share instances in memory, one sync is
+             enough. *)
+          Contents.CA.sync (contents_t t)
 
         let flush t =
-          Contents.CA.flush (contents_t t);
-          Branch.flush t.branch
+          let readonly = Conf.readonly t.config in
+          if readonly then failwith "Can't flush an RO pack store";
+          (* Contents/Commit/Node stores share instances in memory, one flush is
+             enough. *)
+          Contents.CA.flush (contents_t t)
+
+        let close t =
+          let readonly = Conf.readonly t.config in
+          if not readonly then flush t;
+          (* As we've flushed, close order doesn't matter *)
+          Index.close t.index;
+          Contents.CA.close (contents_t t) >>= fun () ->
+          Node.CA.close (snd (node_t t)) >>= fun () ->
+          Commit.CA.close (snd (commit_t t)) >>= fun () -> Branch.close t.branch
       end
     end
 

src/irmin-pack/mem/irmin_pack_mem.ml

@@ -21,7 +21,7 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct
   include AW
 
   let v () = AW.v (Irmin_mem.config ())
-  let flush _t = ()
+  let sync _t = ()
 end
 
 module Indexable_mem

src/irmin-pack/pack_store.ml

@@ -108,9 +108,13 @@ module Maker (Index : Pack_index.S) (K : Irmin.Hash.S with type t = Index.key) :
   let close t =
     t.open_instances <- t.open_instances - 1;
     if t.open_instances = 0 then (
-      if not (IO.readonly t.block) then IO.flush t.block;
-      IO.close t.block;
-      Dict.close t.dict)
+      Dict.close t.dict;
+      IO.close t.block)
+
+  let clear t =
+    Index.clear t.index;
+    IO.truncate t.block;
+    Dict.truncate t.dict
 
   module Make_without_close_checks
       (Val : Pack_value.Persistent with type hash := K.t and type key := Key.t) =
@@ -140,11 +144,6 @@ module Maker (Index : Pack_index.S) (K : Irmin.Hash.S with type t = Index.key) :
 
     let index t hash = Lwt.return (index_direct t hash)
 
-    let clear t =
-      if IO.offset t.block <> Int63.zero then (
-        Index.clear t.index;
-        IO.truncate t.block)
-
     let unsafe_clear t =
       clear t.pack;
       Tbl.clear t.staging;
@@ -162,9 +161,9 @@ module Maker (Index : Pack_index.S) (K : Irmin.Hash.S with type t = Index.key) :
       else false
 
     let flush ?(index = true) ?(index_merge = false) t =
-      if index_merge then Index.merge t.pack.index;
       Dict.flush t.pack.dict;
       IO.flush t.pack.block;
+      if index_merge then Index.merge t.pack.index;
       if index then Index.flush t.pack.index;
       Tbl.clear t.staging
 
@@ -449,6 +448,8 @@ module Maker (Index : Pack_index.S) (K : Irmin.Hash.S with type t = Index.key) :
       let* r = f (cast t) in
       if Tbl.length t.staging = 0 then Lwt.return r
       else (
+        (* Since [batch] doesn't act on the branch store, it is ok to flush
+           here without worrying about it. *)
         flush t;
         Lwt.return r)
 
@@ -517,6 +518,11 @@ module Maker (Index : Pack_index.S) (K : Irmin.Hash.S with type t = Index.key) :
         close t.pack)
 
     let close t =
+      (* It is expected that a flush was performed before [close]. Otherwise
+         data is lost. (ext takes care about it).
+
+         This function does not flush because index is expected to already be
+         closed. *)
       unsafe_close t;
       Lwt.return_unit
 
@@ -529,11 +535,10 @@ module Maker (Index : Pack_index.S) (K : Irmin.Hash.S with type t = Index.key) :
       Lru.clear t.lru
 
     let sync t =
+      Index.sync t.pack.index;
       let former_offset = IO.offset t.pack.block in
       let offset = IO.force_offset t.pack.block in
-      if offset > former_offset then (
-        Dict.sync t.pack.dict;
-        Index.sync t.pack.index)
+      if offset > former_offset then Dict.sync t.pack.dict
 
     let offset t = IO.offset t.pack.block
   end