irmin: add a Repo.close operation to the high-level API

src/irmin-chunk/irmin_chunk.ml

@@ -210,6 +210,8 @@ struct
     CA.v config >|= fun db ->
     { chunking; db; chunk_size; max_children; max_data }
 
+  let close _ = Lwt.return_unit
+
   let batch t f = CA.batch t.db (fun db -> f { t with db })
 
   let find_leaves t key =

src/irmin-fs/irmin_fs.ml

@@ -86,6 +86,8 @@ struct
     let path = get_path config in
     IO.mkdir path >|= fun () -> { path }
 
+  let close _ = Lwt.return_unit
+
   let cast t = (t :> [ `Read | `Write ] t)
 
   let batch t f = f (cast t)
@@ -201,6 +203,8 @@ struct
     in
     { t; w }
 
+  let close t = W.clear t.w >>= fun () -> RO.close t.t
+
   let find t = RO.find t.t
 
   let mem t = RO.mem t.t

src/irmin-git/irmin_git.ml

@@ -929,6 +929,8 @@ struct
         G.v ?dotgit ?compression:level ?buffers root >>= function
         | Error e -> Fmt.kstrf Lwt.fail_with "%a" G.pp_error e
         | Ok g -> R.v ~head ~bare g >|= fun b -> { g; b; config = conf }
+
+      let close _ = Lwt.return_unit
     end
   end
 

src/irmin-http/irmin_http.ml

@@ -494,6 +494,8 @@ module Client (Client : HTTP_CLIENT) (S : Irmin.S) = struct
         Branch.v ?ctx uri >|= fun branch ->
         let commit = (node, commit) in
         { contents; node; commit; branch; config }
+
+      let close _ = Lwt.return_unit
     end
   end
 

src/irmin-mem/irmin_mem.ml

@@ -37,6 +37,10 @@ module Read_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct
 
   let v _config = Lwt.return map
 
+  let close t =
+    t.t <- KMap.empty;
+    Lwt.return_unit
+
   let cast t = (t :> [ `Read | `Write ] t)
 
   let batch t f = f (cast t)
@@ -80,6 +84,8 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Type.S) = struct
 
   let v config = RO.v config >>= fun t -> Lwt.return { t; w = watches; lock }
 
+  let close t = W.clear t.w >>= fun () -> RO.close t.t
+
   let find t = RO.find t.t
 
   let mem t = RO.mem t.t

src/irmin-pack/irmin_pack.ml

@@ -399,6 +399,8 @@ struct
         Commit.CA.v ~fresh ~readonly ~lru_size ~index root >>= fun commit ->
         Branch.v ~fresh ~readonly root >|= fun branch ->
         { contents; node; commit; branch; config; index }
+
+      let close _ = Lwt.return_unit
     end
   end
 
@@ -431,7 +433,7 @@ struct
             let _, capability = X.Repo.commit_t t in
             X.Commit.CA.integrity_check ~offset ~length k capability;
             count_increment commits
-        | _ -> invalid_arg "unknown content type" )
+        | _ -> invalid_arg "unknown content type")
       t.index;
     pr_stats ()
 

src/irmin/irmin.ml

@@ -54,6 +54,118 @@ module Path = struct
   module type S = S.PATH
 end
 
+exception Closed
+
+module CA_check_closed (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER) :
+  S.CONTENT_ADDRESSABLE_STORE_MAKER =
+functor
+  (K : S.HASH)
+  (V : Type.S)
+  ->
+  struct
+    module S = CA (K) (V)
+
+    type 'a t = { closed : bool ref; t : 'a S.t }
+
+    type key = S.key
+
+    type value = S.value
+
+    let check_closed t = if !(t.closed) then raise Closed
+
+    let mem t k =
+      check_closed t;
+      S.mem t.t k
+
+    let find t k =
+      check_closed t;
+      S.find t.t k
+
+    let add t v =
+      check_closed t;
+      S.add t.t v
+
+    let unsafe_add t k v =
+      check_closed t;
+      S.unsafe_add t.t k v
+
+    let batch t f =
+      check_closed t;
+      S.batch t.t (fun w -> f { t = w; closed = t.closed })
+
+    let v conf = S.v conf >|= fun t -> { closed = ref false; t }
+
+    let close t =
+      if !(t.closed) then Lwt.return_unit
+      else (
+        t.closed := true;
+        S.close t.t )
+  end
+
+module AW_check_closed (AW : S.ATOMIC_WRITE_STORE_MAKER) :
+  S.ATOMIC_WRITE_STORE_MAKER =
+functor
+  (K : Type.S)
+  (V : Type.S)
+  ->
+  struct
+    module S = AW (K) (V)
+
+    type t = { closed : bool ref; t : S.t }
+
+    type key = S.key
+
+    type value = S.value
+
+    let check_closed t = if !(t.closed) then raise Closed
+
+    let mem t k =
+      check_closed t;
+      S.mem t.t k
+
+    let find t k =
+      check_closed t;
+      S.find t.t k
+
+    let set t k v =
+      check_closed t;
+      S.set t.t k v
+
+    let test_and_set t k ~test ~set =
+      check_closed t;
+      S.test_and_set t.t k ~test ~set
+
+    let remove t k =
+      check_closed t;
+      S.remove t.t k
+
+    let list t =
+      check_closed t;
+      S.list t.t
+
+    type watch = S.watch
+
+    let watch t ?init f =
+      check_closed t;
+      S.watch t.t ?init f
+
+    let watch_key t k ?init f =
+      check_closed t;
+      S.watch_key t.t k ?init f
+
+    let unwatch t w =
+      check_closed t;
+      S.unwatch t.t w
+
+    let v conf = S.v conf >|= fun t -> { closed = ref false; t }
+
+    let close t =
+      if !(t.closed) then Lwt.return_unit
+      else (
+        t.closed := true;
+        S.close t.t )
+  end
+
 module Make_ext
     (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER)
     (AW : S.ATOMIC_WRITE_STORE_MAKER)
@@ -68,6 +180,9 @@ module Make_ext
             and type step = P.step)
     (CT : S.COMMIT with type hash = H.t) =
 struct
+  module CA = CA_check_closed (CA)
+  module AW = AW_check_closed (AW)
+
   module X = struct
     module Hash = H
 
@@ -144,6 +259,11 @@ struct
         let commits = (nodes, commits) in
         Branch.v config >|= fun branch ->
         { contents; nodes; commits; branch; config }
+
+      let close t =
+        Contents.CA.close t.contents >>= fun () ->
+        Node.CA.close (snd t.nodes) >>= fun () ->
+        Commit.CA.close (snd t.commits) >>= fun () -> Branch.close t.branch
     end
   end
 

src/irmin/irmin.mli

@@ -2081,6 +2081,8 @@ module Private : sig
 
       val v : config -> t Lwt.t
 
+      val close : t -> unit Lwt.t
+
       val contents_t : t -> [ `Read ] Contents.t
 
       val node_t : t -> [ `Read ] Node.t
@@ -2206,6 +2208,10 @@ module type S = sig
     (** [v config] connects to a repository in a backend-specific
         manner. *)
 
+    val close : t -> unit Lwt.t
+    (** [close t] frees up all resources associated with [t]. Any
+        operations run on a closed repository will raise [Closed]. *)
+
     val heads : t -> commit list Lwt.t
     (** [heads] is {!Head.list}. *)
 
@@ -3601,6 +3607,10 @@ module type APPEND_ONLY_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig
   val v : config -> [ `Read ] t Lwt.t
   (** [v config] is a function returning fresh store handles, with the
       configuration [config], which is provided by the backend. *)
+
+  val close : 'a t -> unit Lwt.t
+  (** [close t] frees up all the resources associated to [t]. Any
+      operations run on a closed store will raise [Closed].*)
 end
 
 (** [CONTENT_ADDRESSABLE_STOREMAKER] is the signature exposed by
@@ -3619,6 +3629,10 @@ module type CONTENT_ADDRESSABLE_STORE_MAKER = functor
   val v : config -> [ `Read ] t Lwt.t
   (** [v config] is a function returning fresh store handles, with the
       configuration [config], which is provided by the backend. *)
+
+  val close : 'a t -> unit Lwt.t
+  (** [close t] frees up all the resources associated to [t]. Any
+      operations run on a closed store will raise [Closed].*)
 end
 
 module Content_addressable
@@ -3633,11 +3647,15 @@ module Content_addressable
 
   val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t
   (** [batch t f] applies the writes in [f] in a separate batch. The
-     exact guarantees depends on the backends. *)
+      exact guarantees depends on the backends. *)
 
   val v : config -> [ `Read ] t Lwt.t
   (** [v config] is a function returning fresh store handles, with the
       configuration [config], which is provided by the backend. *)
+
+  val close : 'a t -> unit Lwt.t
+  (** [close t] frees up all the resources associated to [t]. Any
+      operations run on a closed store will raise [Closed]. *)
 end
 
 (** [ATOMIC_WRITE_STORE_MAKER] is the signature exposed by atomic-write
@@ -3649,6 +3667,10 @@ module type ATOMIC_WRITE_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig
   val v : config -> t Lwt.t
   (** [v config] is a function returning fresh store handles, with the
       configuration [config], which is provided by the backend. *)
+
+  val close : t -> unit Lwt.t
+  (** [close t] frees up all the resources associated to [t]. Any
+      operations run on a closed store will raise [Closed]. *)
 end
 
 module Make

src/irmin/s.ml

@@ -99,6 +99,8 @@ module type CONTENT_ADDRESSABLE_STORE_MAKER = functor
   val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t
 
   val v : Conf.t -> [ `Read ] t Lwt.t
+
+  val close : 'a t -> unit Lwt.t
 end
 
 module type APPEND_ONLY_STORE = sig
@@ -121,6 +123,8 @@ module type APPEND_ONLY_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig
   val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t
 
   val v : Conf.t -> [ `Read ] t Lwt.t
+
+  val close : 'a t -> unit Lwt.t
 end
 
 module type METADATA = sig
@@ -403,6 +407,8 @@ module type ATOMIC_WRITE_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig
   include ATOMIC_WRITE_STORE with type key = K.t and type value = V.t
 
   val v : Conf.t -> t Lwt.t
+
+  val close : t -> unit Lwt.t
 end
 
 module type BRANCH_STORE = sig
@@ -463,6 +469,8 @@ module type PRIVATE = sig
 
     val v : Conf.t -> t Lwt.t
 
+    val close : t -> unit Lwt.t
+
     val contents_t : t -> [ `Read ] Contents.t
 
     val node_t : t -> [ `Read ] Node.t
@@ -647,6 +655,8 @@ module type STORE = sig
 
     val v : config -> t Lwt.t
 
+    val close : t -> unit Lwt.t
+
     val heads : t -> commit list Lwt.t
 
     val branches : t -> branch list Lwt.t

src/irmin/store.ml

@@ -192,6 +192,8 @@ module Make (P : S.PRIVATE) = struct
 
     let v = P.Repo.v
 
+    let close = P.Repo.close
+
     let graph_t t = P.Repo.node_t t
 
     let history_t t = P.Repo.commit_t t

src/irmin/store.mli

@@ -43,4 +43,6 @@ module Content_addressable
   val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t
 
   val v : Conf.t -> [ `Read ] t Lwt.t
+
+  val close : 'a t -> unit Lwt.t
 end