irmin-pack: fix snapshot export

GC-based snapshot export did not work if called with a commit that is
older than the latest GC commit.

src/irmin-pack/unix/gc.ml

@@ -42,8 +42,8 @@ module Make (Args : Gc_args.S) = struct
     latest_gc_target_offset : int63;
   }
 
-  let v ~root ~lower_root ~new_files_path ~generation ~unlink ~dispatcher ~fm
-      ~contents ~node ~commit commit_key =
+  let v ~root ~lower_root ~output ~generation ~unlink ~dispatcher ~fm ~contents
+      ~node ~commit commit_key =
     let open Result_syntax in
     let new_suffix_start_offset, latest_gc_target_offset =
       let state : _ Pack_key.state = Pack_key.inspect commit_key in
@@ -56,10 +56,11 @@ module Make (Args : Gc_args.S) = struct
           assert false
     in
     let status = Fm.control fm |> Fm.Control.payload |> fun p -> p.status in
-    (* Ensure we are calling GC on a commit strictly newer than last GC commit *)
+    (* Ensure we are calling GC on a commit strictly newer than last GC commit
+       Only checking when the output is the root (it is not a snapshot export) *)
     let* () =
-      match status with
-      | Gced previous
+      match (output, status) with
+      | `Root, Gced previous
         when Int63.Syntax.(
                previous.latest_gc_target_offset >= latest_gc_target_offset) ->
           Error
@@ -69,6 +70,9 @@ module Make (Args : Gc_args.S) = struct
                  previous.latest_gc_target_offset))
       | _ -> Ok ()
     in
+    let new_files_path =
+      match output with `Root -> root | `External path -> path
+    in
     (* Since we can call GC on commits in the lower, ensure we do not provide a
        [new_suffix_start_offset] that is older than our current starting offset. *)
     let new_suffix_start_offset =

src/irmin-pack/unix/gc.mli

@@ -26,7 +26,7 @@ module Make (Args : Gc_args.S) : sig
   val v :
     root:string ->
     lower_root:string option ->
-    new_files_path:string ->
+    output:[ `External of string | `Root ] ->
     generation:int ->
     unlink:bool ->
     dispatcher:Args.Dispatcher.t ->

src/irmin-pack/unix/store.ml

@@ -240,8 +240,7 @@ module Maker (Config : Conf.S) = struct
                         (Irmin.Type.to_string XKey.t key))
                 | Some (k, _kind) -> Ok k)
 
-          let start ~unlink ~use_auto_finalisation ~new_files_path t commit_key
-              =
+          let start ~unlink ~use_auto_finalisation ~output t commit_key =
             let open Result_syntax in
             [%log.info "GC: Starting on %a" pp_key commit_key];
             let* () =
@@ -260,21 +259,20 @@ module Maker (Config : Conf.S) = struct
             let* gc =
               Gc.v ~root ~lower_root ~generation:next_generation ~unlink
                 ~dispatcher:t.dispatcher ~fm:t.fm ~contents:t.contents
-                ~node:t.node ~commit:t.commit ~new_files_path commit_key
+                ~node:t.node ~commit:t.commit ~output commit_key
             in
             t.running_gc <- Some { gc; use_auto_finalisation };
             Ok ()
 
-          let start_exn ?(unlink = true) ~use_auto_finalisation ~new_files_path
-              t commit_key =
+          let start_exn ?(unlink = true) ?(output = `Root)
+              ~use_auto_finalisation t commit_key =
             match t.running_gc with
             | Some _ ->
                 [%log.info "Repo is alreadying running GC. Skipping."];
                 Lwt.return false
             | None -> (
                 let result =
-                  start ~unlink ~use_auto_finalisation ~new_files_path t
-                    commit_key
+                  start ~unlink ~use_auto_finalisation ~output t commit_key
                 in
                 match result with
                 | Ok _ -> Lwt.return true
@@ -353,7 +351,7 @@ module Maker (Config : Conf.S) = struct
             (* The GC action here does not matter, since we'll not fully
                finalise it *)
             let* launched =
-              start_exn ~use_auto_finalisation:false ~new_files_path:path t
+              start_exn ~use_auto_finalisation:false ~output:(`External path) t
                 commit_key
             in
             let () =
@@ -622,16 +620,13 @@ module Maker (Config : Conf.S) = struct
       let finalise_exn = X.Repo.Gc.finalise_exn
 
       let start_exn ?unlink t =
-        let root = Irmin_pack.Conf.root t.X.Repo.config in
-        X.Repo.Gc.start_exn ?unlink ~use_auto_finalisation:false
-          ~new_files_path:root t
+        X.Repo.Gc.start_exn ?unlink ~use_auto_finalisation:false t
 
       let start repo commit_key =
-        let root = Irmin_pack.Conf.root repo.X.Repo.config in
         try
           let* started =
-            X.Repo.Gc.start_exn ~unlink:true ~use_auto_finalisation:true
-              ~new_files_path:root repo commit_key
+            X.Repo.Gc.start_exn ~unlink:true ~use_auto_finalisation:true repo
+              commit_key
           in
           Lwt.return_ok started
         with exn -> catch_errors "Start GC" exn

test/irmin-pack/test_gc.ml

@@ -1470,10 +1470,32 @@ module Snapshot = struct
     let* () = check_2 t c2 in
     S.Repo.close t.repo
 
+  (* Test creating a snapshot in an archive store for a commit that is before
+     the last gc target commit (ie it is in the lower) *)
+  let snapshot_gced_commit () =
+    let lower_root = create_lower_root ~mkdir:false () in
+    let* t = init ~lower_root:(Some lower_root) () in
+    let* t, c1 = commit_1 t in
+    let* t = checkout_exn t c1 in
+    let* t, c2 = commit_2 t in
+    let* () = start_gc t c2 in
+    let* () = finalise_gc t in
+    let root_snap = Filename.concat t.root "snap" in
+    let* () = export t c1 root_snap in
+    let* () = S.Repo.close t.repo in
+    [%log.debug "open store from snapshot"];
+    let* t = init ~readonly:false ~fresh:false ~root:root_snap () in
+    let* t = checkout_exn t c1 in
+    let* t, c2 = commit_2 t in
+    let* ()  = check_1 t c1 in
+    let* () = check_2 t c2 in
+    S.Repo.close t.repo
+
   let tests =
     [
       tc "Import/export in rw" snapshot_rw;
       tc "Import in ro" snapshot_import_in_ro;
       tc "Export in ro" snapshot_export_in_ro;
+      tc "Snapshot gced commit" snapshot_gced_commit;
     ]
 end