irmin-pack: throw exception for readonly batch

src/irmin-pack/unix/ext.ml

@@ -321,42 +321,45 @@ module Maker (Config : Conf.S) = struct
 
         let batch t f =
           [%log.debug "[pack] batch start"];
-          let c0 = Mtime_clock.counter () in
-          let try_finalise () = Gc.try_auto_finalise_exn t in
-          let* _ = try_finalise () in
-          t.during_batch <- true;
-          let contents = Contents.CA.cast t.contents in
-          let node = Node.CA.Pack.cast t.node in
-          let commit = Commit.CA.cast t.commit in
-          let contents : 'a Contents.t = contents in
-          let node : 'a Node.t = (contents, node) in
-          let commit : 'a Commit.t = (node, commit) in
-          let on_success res =
-            let s = Mtime_clock.count c0 |> Mtime.Span.to_s in
-            [%log.info "[pack] batch completed in %.6fs" s];
-            t.during_batch <- false;
-            File_manager.flush t.fm |> Errs.raise_if_error;
+          let readonly = Irmin_pack.Conf.readonly t.config in
+          if readonly then Errs.raise_error `Ro_not_allowed
+          else
+            let c0 = Mtime_clock.counter () in
+            let try_finalise () = Gc.try_auto_finalise_exn t in
             let* _ = try_finalise () in
-            Lwt.return res
-          in
-          let on_fail exn =
-            t.during_batch <- false;
-            [%log.info
-              "[pack] batch failed. calling flush. (%s)"
-                (Printexc.to_string exn)];
-            let () =
-              match File_manager.flush t.fm with
-              | Ok () -> ()
-              | Error err ->
-                  [%log.err
-                    "[pack] batch failed and flush failed. Silencing flush \
-                     fail. (%a)"
-                    Errs.pp err]
+            t.during_batch <- true;
+            let contents = Contents.CA.cast t.contents in
+            let node = Node.CA.Pack.cast t.node in
+            let commit = Commit.CA.cast t.commit in
+            let contents : 'a Contents.t = contents in
+            let node : 'a Node.t = (contents, node) in
+            let commit : 'a Commit.t = (node, commit) in
+            let on_success res =
+              let s = Mtime_clock.count c0 |> Mtime.Span.to_s in
+              [%log.info "[pack] batch completed in %.6fs" s];
+              t.during_batch <- false;
+              File_manager.flush t.fm |> Errs.raise_if_error;
+              let* _ = try_finalise () in
+              Lwt.return res
             in
-            (* Kill gc process in at_exit. *)
-            raise exn
-          in
-          Lwt.try_bind (fun () -> f contents node commit) on_success on_fail
+            let on_fail exn =
+              t.during_batch <- false;
+              [%log.info
+                "[pack] batch failed. calling flush. (%s)"
+                  (Printexc.to_string exn)];
+              let () =
+                match File_manager.flush t.fm with
+                | Ok () -> ()
+                | Error err ->
+                    [%log.err
+                      "[pack] batch failed and flush failed. Silencing flush \
+                       fail. (%a)"
+                      Errs.pp err]
+              in
+              (* Kill gc process in at_exit. *)
+              raise exn
+            in
+            Lwt.try_bind (fun () -> f contents node commit) on_success on_fail
 
         let close t =
           (* Step 1 - Kill the gc process if it is running *)

test/irmin-pack/dune

@@ -2,7 +2,7 @@
  (name test_pack)
  (modules
   test_pack
-  multiple_instances
+  test_readonly
   test_existing_stores
   test_inode
   test_tree

test/irmin-pack/test_pack.ml

@@ -501,7 +501,7 @@ let misc =
     ("dict-files", Dict.tests);
     ("pack-files", Pack.tests);
     ("branch-files", Branch.tests);
-    ("instances", Multiple_instances.tests);
+    ("read-only", Test_readonly.tests);
     ("existing stores", Test_existing_stores.tests);
     ("inodes", Test_inode.tests);
     ("trees", Test_tree.tests);

test/irmin-pack/multiple_instances.ml → test/irmin-pack/test_readonly.ml

@@ -17,8 +17,8 @@
 open! Import
 open Common
 
-let root = Filename.concat "_build" "test-instances"
-let src = Logs.Src.create "tests.instances" ~doc:"Tests"
+let root = Filename.concat "_build" "test-readonly"
+let src = Logs.Src.create "tests.readonly" ~doc:"Tests read-only stores"
 
 module Log = (val Logs.src_log src : Logs.LOG)
 
@@ -105,10 +105,20 @@ let ro_reload_after_close () =
   S.reload ro;
   binding (check_binding ro c1) >>= fun () -> S.Repo.close ro
 
+let ro_batch () =
+  let* rw = S.Repo.v (config ~readonly:false ~fresh:true root) in
+  let* ro = S.Repo.v (config ~readonly:true ~fresh:false root) in
+  Alcotest.check_raises_lwt "Read-only store throws RO_not_allowed exception"
+    Irmin_pack_unix.Errors.RO_not_allowed (fun () ->
+      S.Backend.Repo.batch ro (fun _ _ _ -> Lwt.return_unit))
+  >>= fun () ->
+  S.Repo.close ro >>= fun () -> S.Repo.close rw
+
 let tests =
   let tc name test = Alcotest_lwt.test_case name `Quick (fun _switch -> test) in
   [
     tc "Test open ro after rw closed" open_ro_after_rw_closed;
     tc "Test ro reload after add" ro_reload_after_add;
     tc "Test ro reload after close" ro_reload_after_close;
+    tc "Test ro batch" ro_batch;
   ]