From 9d606d78375abcd4c961331a1e8ee8f9be9212cb Mon Sep 17 00:00:00 2001 From: ArthurW Date: Mon, 13 May 2024 17:32:56 +0200 Subject: [PATCH 1/2] irmin-fs: eio backend --- src/irmin-cli/cli.ml | 191 +++++++++--------- src/irmin-cli/cli.mli | 7 +- src/irmin-cli/dune | 1 + src/irmin-cli/import.ml | 4 + src/irmin-cli/resolver.ml | 77 ++++--- src/irmin-cli/resolver.mli | 11 +- src/irmin-cli/server.ml | 16 +- src/irmin-client/unix/bin/client.ml | 6 +- src/irmin-fs/irmin_fs.ml | 128 ++++++------ src/irmin-fs/irmin_fs.mli | 29 +-- src/irmin-fs/unix/dune | 2 +- src/irmin-fs/unix/eio_pool.ml | 3 +- src/irmin-fs/unix/irmin_fs_unix.ml | 299 +++++++++++++--------------- src/irmin-fs/unix/irmin_fs_unix.mli | 7 + src/irmin/conf.ml | 95 ++++++--- src/irmin/conf.mli | 55 +++-- src/libirmin/config.ml | 27 ++- src/libirmin/util.ml | 7 +- test/irmin-cli/test.ml | 13 +- test/irmin-cli/test_command_line.t | 30 +++ test/irmin-fs/test.ml | 3 +- test/irmin-fs/test_fs_unix.ml | 4 +- test/irmin-fs/test_unix.ml | 5 +- test/irmin/test_conf.ml | 6 - 24 files changed, 557 insertions(+), 469 deletions(-) diff --git a/src/irmin-cli/cli.ml b/src/irmin-cli/cli.ml index 5ef2a3cbe7..5cbc121ff3 100644 --- a/src/irmin-cli/cli.ml +++ b/src/irmin-cli/cli.ml @@ -19,6 +19,8 @@ open Cmdliner open Resolver module Graphql = Irmin_graphql_unix +type eio = Import.eio + let deprecated_info = (Term.info [@alert "-deprecated"]) let deprecated_man_format = (Term.man_format [@alert "-deprecated"]) let deprecated_eval_choice = (Term.eval_choice [@alert "-deprecated"]) @@ -53,7 +55,7 @@ let term_info title ~doc ~man = deprecated_info ~sdocs:global_option_section ~docs:global_option_section ~doc ~man title -type command = (unit Term.t * Term.info[@alert "-deprecated"]) +type command = env:eio -> (unit Term.t * Term.info[@alert "-deprecated"]) type sub = { name : string; @@ -62,7 +64,8 @@ type sub = { term : unit Term.t; } -let create_command c = +let create_command c ~env = + let c = c ~env in let man = [ `S "DESCRIPTION"; `P c.doc ] @ c.man in (c.term, term_info c.name ~doc:c.doc ~man) @@ -113,14 +116,14 @@ let run t = try t () with err -> print_exc err let mk (fn : 'a) : 'a Term.t = Term.(const (fun () -> fn) $ setup_log) (* INIT *) -let init = +let init ~env = { name = "init"; doc = "Initialize a store."; man = []; term = (let init (S (_, _store, _)) = () in - Term.(mk init $ store ())); + Term.(mk init $ store ~env)); } let print fmt = Fmt.kstr print_endline fmt @@ -136,7 +139,7 @@ let branch f x = get "branch" f x let commit f x = get "commit" f x (* GET *) -let get = +let get ~env = { name = "get"; doc = "Read the value associated with a key."; @@ -152,11 +155,11 @@ let get = exit 1 | Some v -> print "%a" (Irmin.Type.pp S.Contents.t) v in - Term.(mk get $ store () $ path)); + Term.(mk get $ store ~env $ path)); } (* LIST *) -let list = +let list ~env = { name = "list"; doc = "List subdirectories."; @@ -180,11 +183,11 @@ let list = in List.iter (print "%a" pp) paths in - Term.(mk list $ store () $ path_or_empty)); + Term.(mk list $ store ~env $ path_or_empty)); } (* TREE *) -let tree = +let tree ~env = { name = "tree"; doc = "List the store contents."; @@ -236,7 +239,7 @@ let tree = print "%s%s%s" k dots v) all in - Term.(mk tree $ store ())); + Term.(mk tree $ store ~env)); } let author = @@ -248,7 +251,7 @@ let message = Arg.(value & opt (some string) None & doc) (* SET *) -let set = +let set ~env = { name = "set"; doc = "Update the value associated with a key."; @@ -267,11 +270,11 @@ let set = let value = value S.Contents.t v in S.set_exn t ~info:(info (module S) ?author "%s" message) path value in - Term.(mk set $ store () $ author $ message $ path $ v)); + Term.(mk set $ store ~env $ author $ message $ path $ v)); } (* REMOVE *) -let remove = +let remove ~env = { name = "remove"; doc = "Delete a key."; @@ -288,7 +291,7 @@ let remove = ~info:(info (module S) ?author "%s" message) (key S.Path.t path) in - Term.(mk remove $ store () $ author $ message $ path)); + Term.(mk remove $ store ~env $ author $ message $ path)); } let apply e f = @@ -298,7 +301,7 @@ let apply e f = | r, _ -> r (* CLONE *) -let clone = +let clone ~env = { name = "clone"; doc = "Copy a remote respository to a local store"; @@ -316,11 +319,11 @@ let clone = | Ok `Empty -> () | Error (`Msg e) -> failwith e in - Term.(mk clone $ Resolver.remote () $ depth)); + Term.(mk clone $ Resolver.remote ~env $ depth)); } (* FETCH *) -let fetch = +let fetch ~env = { name = "fetch"; doc = "Download objects and refs from another repository."; @@ -338,11 +341,11 @@ let fetch = let _ = Sync.pull_exn t x `Set in () in - Term.(mk fetch $ Resolver.remote ())); + Term.(mk fetch $ Resolver.remote ~env)); } (* MERGE *) -let merge = +let merge ~env = { name = "merge"; doc = "Merge branches."; @@ -371,11 +374,11 @@ let merge = let doc = Arg.info ~docv:"BRANCH" ~doc:"Branch to merge from." [] in Arg.(required & pos 0 (some string) None & doc) in - Term.(mk merge $ store () $ author $ message $ branch_name)); + Term.(mk merge $ store ~env $ author $ message $ branch_name)); } (* PULL *) -let pull = +let pull ~env = { name = "pull"; doc = "Fetch and merge with another repository."; @@ -394,11 +397,11 @@ let pull = in () in - Term.(mk pull $ remote () $ author $ message)); + Term.(mk pull $ remote ~env $ author $ message)); } (* PUSH *) -let push = +let push ~env = { name = "push"; doc = "Update remote references along with associated objects."; @@ -414,11 +417,11 @@ let push = let _ = Sync.push_exn t x in () in - Term.(mk push $ remote ())); + Term.(mk push $ remote ~env)); } (* SNAPSHOT *) -let snapshot = +let snapshot ~env = { name = "snapshot"; doc = "Return a snapshot for the current state of the database."; @@ -432,11 +435,11 @@ let snapshot = print "%a" S.Commit.pp_hash k; () in - Term.(mk snapshot $ store ())); + Term.(mk snapshot $ store ~env)); } (* REVERT *) -let revert = +let revert ~env = { name = "revert"; doc = "Revert the contents of the store to a previous state."; @@ -457,7 +460,7 @@ let revert = | Some s -> S.Head.set t s | None -> failwith "invalid commit" in - Term.(mk revert $ store () $ snapshot)); + Term.(mk revert $ store ~env $ snapshot)); } (* WATCH *) @@ -543,7 +546,7 @@ let handle_diff (type a b) and type Schema.Metadata.t = S.metadata) diff command proc -let watch = +let watch ~env = { name = "watch"; doc = "Get notifications when values change."; @@ -573,11 +576,11 @@ let watch = let doc = Arg.info ~docv:"COMMAND" ~doc:"Command to execute" [] in Arg.(value & pos_right 0 string [] & doc) in - Term.(mk watch $ store () $ path $ command)); + Term.(mk watch $ store ~env $ path $ command)); } (* DOT *) -let dot = +let dot ~env = { name = "dot"; doc = "Dump the contents of the store as a Graphviz file."; @@ -639,7 +642,7 @@ let dot = in if i <> 0 then [%logs.err "The %s.dot is corrupted" basename]) in - Term.(mk dot $ store () $ basename $ depth $ no_dot_call $ full)); + Term.(mk dot $ store ~env $ basename $ depth $ no_dot_call $ full)); } let config_man = @@ -676,7 +679,7 @@ let config_man = @ help_sections ) (* HELP *) -let help = +let help ~env:_ = { name = "help"; doc = "Display help about Irmin and Irmin commands."; @@ -710,7 +713,7 @@ let help = } (* GRAPHQL *) -let graphql = +let graphql ~env = { name = "graphql"; doc = "Run a graphql server."; @@ -748,19 +751,19 @@ let graphql = ~mode:(`TCP (`Port port)) server in - Term.(mk graphql $ store () $ port $ addr)); + Term.(mk graphql $ store ~env $ port $ addr)); } (* SERVER *) -let server = +let server ~env = { name = "server"; doc = "Run irmin-server."; man = []; - term = Server.main_term; + term = Server.main_term ~env; } -let options = +let options ~env = { name = "options"; doc = "Get information about backend specific configuration options."; @@ -768,26 +771,22 @@ let options = term = (let options (store, hash, contents) = let module Conf = Irmin.Backend.Conf in - let store, _ = Resolver.load_config ?store ?hash ?contents () in + let store, _ = Resolver.load_config ~env ?store ?hash ?contents () in let spec = Store.spec store in Seq.iter (fun (Conf.K k) -> let name = Conf.name k in if name = "root" || name = "uri" then () else - let ty = Conf.ty k in + let ty = Conf.typename k in let doc = Conf.doc k |> Option.value ~default:"" in - let ty = - Fmt.str "%a" Irmin.Type.pp_ty ty - |> Astring.String.filter (fun c -> c <> '\n') - in Fmt.pr "%s: %s\n\t%s\n" name ty doc) (Conf.Spec.keys spec) in Term.(mk options $ Store.term ())); } -let branches = +let branches ~env = { name = "branches"; doc = "List branches"; @@ -800,7 +799,7 @@ let branches = let branches = S.Branch.list (S.repo t) in List.iter (Fmt.pr "%a\n" (Irmin.Type.pp S.branch_t)) branches in - Term.(mk branches $ store ())); + Term.(mk branches $ store ~env)); } let weekday Unix.{ tm_wday; _ } = @@ -830,7 +829,7 @@ let month Unix.{ tm_mon; _ } = | 11 -> "Dec" | _ -> assert false -let log = +let log ~env = { name = "log"; doc = "List commits"; @@ -911,10 +910,36 @@ let log = () with Sys_error s when String.equal s "Broken pipe" -> () in - Term.(mk commits $ store () $ plain $ pager $ num $ skip $ reverse)); + Term.(mk commits $ store ~env $ plain $ pager $ num $ skip $ reverse)); } -let default = +let common_commands = + [ + init; + get; + set; + remove; + list; + tree; + clone; + fetch; + merge; + pull; + push; + snapshot; + revert; + watch; + dot; + graphql; + server; + options; + branches; + log; + ] + +let commands = help :: common_commands + +let default ~env = let doc = "Irmin, the database that never forgets." in let man = [ @@ -933,66 +958,28 @@ let default = "usage: irmin [--version]\n\ \ [--help]\n\ \ []\n\n\ - The most commonly used subcommands are:\n\ - \ init %s\n\ - \ get %s\n\ - \ set %s\n\ - \ remove %s\n\ - \ list %s\n\ - \ tree %s\n\ - \ clone %s\n\ - \ fetch %s\n\ - \ merge %s\n\ - \ pull %s\n\ - \ push %s\n\ - \ snapshot %s\n\ - \ revert %s\n\ - \ watch %s\n\ - \ dot %s\n\ - \ graphql %s\n\ - \ server %s\n\ - \ options %s\n\ - \ branches %s\n\ - \ log %s\n\n\ - See `irmin help ` for more information on a specific command.\n\ - %!" - init.doc get.doc set.doc remove.doc list.doc tree.doc clone.doc fetch.doc - merge.doc pull.doc push.doc snapshot.doc revert.doc watch.doc dot.doc - graphql.doc server.doc options.doc branches.doc log.doc + The most commonly used subcommands are:\n"; + List.iter + (fun cmd -> + let cmd = cmd ~env in + Fmt.pr " %-11s %s\n" cmd.name cmd.doc) + common_commands; + Fmt.pr + "\n\ + See `irmin help ` for more information on a specific command.@." in ( Term.(mk usage $ const ()), deprecated_info "irmin" ~version:Irmin.version ~sdocs:global_option_section ~doc ~man ) -let commands = - List.map create_command - [ - help; - init; - get; - set; - remove; - list; - tree; - clone; - fetch; - merge; - pull; - push; - snapshot; - revert; - watch; - dot; - graphql; - server; - options; - branches; - log; - ] +let commands = List.map create_command commands let run ~default:x y = Eio_main.run @@ fun env -> - Irmin_fs.run env#fs @@ fun () -> Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook; - match deprecated_eval_choice x y with `Error _ -> exit 1 | _ -> () + let env = (env :> eio) in + let run cmd = cmd ~env in + match deprecated_eval_choice (run x) (List.map run y) with + | `Error _ -> exit 1 + | _ -> () diff --git a/src/irmin-cli/cli.mli b/src/irmin-cli/cli.mli index 6141f56afa..70a4f45b95 100644 --- a/src/irmin-cli/cli.mli +++ b/src/irmin-cli/cli.mli @@ -16,7 +16,10 @@ (** CLI commands. *) -type command = (unit Cmdliner.Term.t * Cmdliner.Term.info[@alert "-deprecated"]) +type eio = Import.eio + +type command = + env:eio -> (unit Cmdliner.Term.t * Cmdliner.Term.info[@alert "-deprecated"]) (** [Cmdliner] commands. *) val default : command @@ -38,5 +41,5 @@ type sub = { } (** Subcommand. *) -val create_command : sub -> command +val create_command : (env:eio -> sub) -> command (** Build a subcommand. *) diff --git a/src/irmin-cli/dune b/src/irmin-cli/dune index 8496c072ab..53ba1c313d 100644 --- a/src/irmin-cli/dune +++ b/src/irmin-cli/dune @@ -19,6 +19,7 @@ cohttp-lwt-unix unix yaml + eio eio_main lwt_eio) (preprocess diff --git a/src/irmin-cli/import.ml b/src/irmin-cli/import.ml index fff6d09bdb..bb36eaba59 100644 --- a/src/irmin-cli/import.ml +++ b/src/irmin-cli/import.ml @@ -15,3 +15,7 @@ *) include Irmin.Export_for_backends + +type eio = + < cwd : Eio.Fs.dir_ty Eio.Path.t + ; clock : float Eio.Time.clock_ty Eio.Time.clock > diff --git a/src/irmin-cli/resolver.ml b/src/irmin-cli/resolver.ml index 4d2106ef08..5c9dea5ced 100644 --- a/src/irmin-cli/resolver.ml +++ b/src/irmin-cli/resolver.ml @@ -23,21 +23,23 @@ let global_option_section = "COMMON OPTIONS" module Conf = Irmin.Backend.Conf -let try_parse ty v = - match Irmin.Type.of_string ty v with +let try_parse of_string v = + match of_string v with | Error e -> ( let x = Format.sprintf "{\"some\": %s}" v in - match Irmin.Type.of_string ty x with + match of_string x with | Error _ -> let y = Format.sprintf "{\"some\": \"%s\"}" v in - Irmin.Type.of_string ty y |> Result.map_error (fun _ -> e) + of_string y |> Result.map_error (fun _ -> e) | v -> v) | v -> v let pconv t = let pp = Irmin.Type.pp t in let parse s = - match try_parse t s with Ok x -> `Ok x | Error (`Msg e) -> `Error e + match try_parse (Irmin.Type.of_string t) s with + | Ok x -> `Ok x + | Error (`Msg e) -> `Error e in (parse, pp) @@ -296,7 +298,14 @@ module Store = struct v spec (module S) let mem = create Irmin_mem.Conf.spec (module Irmin_mem) - let fs = create Irmin_fs.Conf.spec (module Irmin_fs_unix) + + let fs env = + let spec = + Irmin_fs_unix.spec ~path:(Eio.Stdenv.cwd env) + ~clock:(Eio.Stdenv.clock env) + in + create spec (module Irmin_fs_unix) + let git (module C : Irmin.Contents.S) = v_git (module Xgit.FS.KV (C)) let git_mem (module C : Irmin.Contents.S) = v_git (module Xgit.Mem.KV (C)) @@ -324,23 +333,24 @@ module Store = struct let all = ref [ - ("git", Fixed_hash git); - ("git-mem", Fixed_hash git_mem); - ("fs", Variable_hash fs); - ("mem", Variable_hash mem); - ("pack", Variable_hash pack); - ("tezos", Fixed tezos); + ("git", fun _ -> Fixed_hash git); + ("git-mem", fun _ -> Fixed_hash git_mem); + ("fs", fun env -> Variable_hash (fs env)); + ("mem", fun _ -> Variable_hash mem); + ("pack", fun _ -> Variable_hash pack); + ("tezos", fun _ -> Fixed tezos); ] let default = "git" |> fun n -> ref (n, List.assoc n !all) let add name ?default:(x = false) m = + let m (_ : eio) = m in all := (name, m) :: !all; if x then default := (name, m) - let find name = + let find name env = match List.assoc_opt (String.Ascii.lowercase name) !all with - | Some s -> s + | Some s -> s env | None -> let valid = String.concat ~sep:", " (List.split !all |> fst) in let msg = @@ -456,10 +466,10 @@ let parse_config ?root y spec = | Some (Irmin.Backend.Conf.K k), Some v -> let v = json_of_yaml v |> Yojson.Basic.to_string in let v = - match Irmin.Type.of_json_string (Conf.ty k) v with + match Conf.of_json_string k v with | Error _ -> let v = Format.sprintf "{\"some\": %s}" v in - Irmin.Type.of_json_string (Conf.ty k) v |> Result.get_ok + Conf.of_json_string k v |> Result.get_ok | Ok v -> v in Conf.add config k v @@ -475,7 +485,7 @@ let parse_config ?root y spec = let config = match (root, Conf.Spec.find_key spec "root") with | Some root, Some (K r) -> - let v = Irmin.Type.of_string (Conf.ty r) root |> Result.get_ok in + let v = Conf.of_string r root |> Result.get_ok in Conf.add config r v | _ -> config in @@ -489,7 +499,7 @@ let load_plugin ?plugin config = | Ok (Some v) -> Dynlink.loadfile_private (Yaml.Util.to_string_exn v) | _ -> ()) -let get_store ?plugin config (store, hash, contents) = +let get_store ~env ?plugin config (store, hash, contents) = let () = load_plugin ?plugin config in let store = match store with @@ -500,6 +510,7 @@ let get_store ?plugin config (store, hash, contents) = match store with Some s -> Store.find s | None -> Store.find s) | _ -> snd !Store.default) in + let store = store env in let contents = match contents with | Some s -> Contents.find s @@ -532,9 +543,9 @@ let get_store ?plugin config (store, hash, contents) = | _ -> Fmt.failwith "Cannot customize the hash function for the given store") -let load_config ?plugin ?root ?config_path ?store ?hash ?contents () = +let load_config ~env ?plugin ?root ?config_path ?store ?hash ?contents () = let y = read_config_file config_path in - let store = get_store ?plugin y (store, hash, contents) in + let store = get_store ~env ?plugin y (store, hash, contents) in let spec = Store.spec store in let config = parse_config ?root y spec in (store, config) @@ -564,10 +575,10 @@ let get_commit (type a b) | None -> of_string (find_key config "commit") | Some t -> of_string (Some t) -let build_irmin_config config root opts (store, hash, contents) branch commit - plugin : store = +let build_irmin_config ~env config root opts (store, hash, contents) branch + commit plugin : store = let (T { impl; spec; remote }) = - get_store ?plugin config (store, hash, contents) + get_store ~env ?plugin config (store, hash, contents) in let (module S) = Store.Impl.generic_keyed impl in let branch = get_branch (module S) config branch in @@ -586,8 +597,7 @@ let build_irmin_config config root opts (store, hash, contents) branch commit | Some x -> x | None -> invalid_arg ("opt: " ^ k) in - let ty = Conf.ty key in - let v = try_parse ty v |> Result.get_ok in + let v = try_parse (Conf.of_string key) v |> Result.get_ok in let config = Conf.add config key v in config) config (List.flatten opts) @@ -626,10 +636,10 @@ let plugin = let doc = "Register new contents, store or hash types" in Arg.(value & opt (some string) None & info ~doc [ "plugin" ]) -let store () = +let store ~env = let create plugin store (root, config_path, opts) branch commit = let y = read_config_file config_path in - build_irmin_config y root opts store branch commit plugin + build_irmin_config ~env y root opts store branch commit plugin in Term.(const create $ plugin $ Store.term () $ config_term $ branch $ commit) @@ -653,7 +663,7 @@ type Irmin.remote += R of Cohttp.Header.t option * string (* FIXME: this is a very crude heuristic to choose the remote kind. Would be better to read the config file and look for remote alias. *) -let infer_remote hash contents branch headers str = +let infer_remote ~env hash contents branch headers str = let hash = match hash with None -> snd !Hash.default | Some c -> c in let contents = match contents with @@ -664,7 +674,7 @@ let infer_remote hash contents branch headers str = let r = if Sys.file_exists (str / ".git") then Store.git contents else if Sys.file_exists (str / "store.dict") then Store.pack hash contents - else Store.fs hash contents + else Store.fs env hash contents in match r with | Store.T { impl; spec; _ } -> @@ -673,7 +683,7 @@ let infer_remote hash contents branch headers str = let config = match Conf.Spec.find_key spec "root" with | Some (K r) -> - let v = Irmin.Type.of_string (Conf.ty r) str |> Result.get_ok in + let v = Conf.of_string r str |> Result.get_ok in Conf.add config r v | _ -> config in @@ -691,7 +701,7 @@ let infer_remote hash contents branch headers str = in R (headers, str) -let remote () = +let remote ~env = let repo = let doc = Arg.info ~docv:"REMOTE" @@ -703,9 +713,10 @@ let remote () = headers str = let y = read_config_file config_path in let store = - build_irmin_config y root opts (store, hash, contents) branch commit None + build_irmin_config ~env y root opts (store, hash, contents) branch commit + None in - let remote () = infer_remote hash contents branch headers str in + let remote () = infer_remote ~env hash contents branch headers str in (store, remote) in Term.( diff --git a/src/irmin-cli/resolver.mli b/src/irmin-cli/resolver.mli index 9fbc8f637f..fc90d466f2 100644 --- a/src/irmin-cli/resolver.mli +++ b/src/irmin-cli/resolver.mli @@ -43,6 +43,8 @@ type contents = Contents.t (** {1 Global Configuration} *) +type eio := Import.eio + module Store : sig module Impl : sig (** The type of {i implementations} of an Irmin store. @@ -86,10 +88,10 @@ module Store : sig t val mem : hash -> contents -> t - val fs : hash -> contents -> t + val fs : eio -> hash -> contents -> t val git : contents -> t val pack : hash -> contents -> t - val find : string -> store_functor + val find : string -> eio -> store_functor val add : string -> ?default:bool -> store_functor -> unit val spec : t -> Irmin.Backend.Conf.Spec.t val generic_keyed : t -> (module Irmin.Generic_key.S) @@ -103,6 +105,7 @@ end (** {1 Stores} *) val load_config : + env:eio -> ?plugin:string -> ?root:string -> ?config_path:string -> @@ -126,10 +129,10 @@ val load_config : type store = | S : 'a Store.Impl.t * (unit -> 'a) * Store.remote_fn option -> store -val store : unit -> store Cmdliner.Term.t +val store : env:eio -> store Cmdliner.Term.t (** Parse the command-line arguments and then the config file. *) type Irmin.remote += R of Cohttp.Header.t option * string -val remote : unit -> (store * (unit -> Irmin.remote)) Cmdliner.Term.t +val remote : env:eio -> (store * (unit -> Irmin.remote)) Cmdliner.Term.t (** Parse a remote store location. *) diff --git a/src/irmin-cli/server.ml b/src/irmin-cli/server.ml index 380615d2a6..20471e2ca6 100644 --- a/src/irmin-cli/server.ml +++ b/src/irmin-cli/server.ml @@ -29,10 +29,11 @@ let setup_log = Cmdliner.Term.( const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) -let main ~readonly ~root ~uri ~tls ~store ~contents ~hash ~dashboard +let main ~env ~readonly ~root ~uri ~tls ~store ~contents ~hash ~dashboard ~config_path (module Codec : Conn.Codec.S) fingerprint = + Lwt_eio.run_lwt @@ fun () -> let store, config = - Resolver.load_config ?root ?config_path ?store ?hash ?contents () + Resolver.load_config ~env ?root ?config_path ?store ?hash ?contents () in let config = Irmin_server.Cli.Conf.v config uri in let (module Store : Irmin.Generic_key.S) = @@ -61,16 +62,15 @@ let main ~readonly ~root ~uri ~tls ~store ~contents ~hash ~dashboard Logs.app (fun l -> l "Listening on %a, store: %s" Uri.pp_hum uri root); Server.serve server -let main readonly root uri tls (store, hash, contents) codec config_path +let main ~env readonly root uri tls (store, hash, contents) codec config_path dashboard fingerprint () = let codec = match codec with | `Bin -> (module Conn.Codec.Bin : Conn.Codec.S) | `Json -> (module Conn.Codec.Json) in - Lwt_main.run - @@ main ~readonly ~root ~uri ~tls ~store ~contents ~hash ~config_path - ~dashboard codec fingerprint + main ~env ~readonly ~root ~uri ~tls ~store ~contents ~hash ~config_path + ~dashboard codec fingerprint open Cmdliner @@ -107,9 +107,9 @@ let dashboard = in Arg.(value @@ opt (some int) None doc) -let main_term = +let main_term ~env = Term.( - const main + const (main ~env) $ readonly $ root $ Irmin_server.Cli.uri diff --git a/src/irmin-client/unix/bin/client.ml b/src/irmin-client/unix/bin/client.ml index 8ac3c90651..63bd18f250 100644 --- a/src/irmin-client/unix/bin/client.ml +++ b/src/irmin-client/unix/bin/client.ml @@ -260,7 +260,7 @@ let iterations = in Arg.(value @@ opt int 1 doc) -let config = +let config ~env = let create uri (branch : string option) tls (store, hash, contents) codec config_path () = let codec = @@ -270,7 +270,7 @@ let config = in let (module Codec) = codec in let store, config = - Irmin_cli.Resolver.load_config ?config_path ?store ?hash ?contents () + Irmin_cli.Resolver.load_config ~env ?config_path ?store ?hash ?contents () in let config = Irmin_server.Cli.Conf.v config uri in let (module Store : Irmin.Generic_key.S) = @@ -298,6 +298,8 @@ let help = (Term.info "irmin-client" [@alert "-deprecated"]) ) let[@alert "-deprecated"] () = + Eio_main.run @@ fun env -> + let config = config ~env:(env :> Irmin_cli.eio) in Term.exit @@ Term.eval_choice help [ diff --git a/src/irmin-fs/irmin_fs.ml b/src/irmin-fs/irmin_fs.ml index c08c50353e..4fdc93759f 100644 --- a/src/irmin-fs/irmin_fs.ml +++ b/src/irmin-fs/irmin_fs.ml @@ -15,43 +15,49 @@ *) open! Import -open Eio open Astring let src = Logs.Src.create "irmin.fs" ~doc:"Irmin disk persistence" module Log = (val Logs.src_log src : Logs.LOG) -let ( / ) = Path.( / ) +let ( / ) = Filename.concat module type Config = sig - val dir : Fs.dir_ty Path.t -> Fs.dir_ty Path.t + val dir : string -> string val file_of_key : string -> string val key_of_file : string -> string end module type IO = sig - type path = Fs.dir_ty Path.t + type io - val rec_files : path -> path list - val file_exists : path -> bool - val read_file : path -> string option - val mkdir : path -> unit + val io_of_config : Irmin.config -> io + + type path = string + + val rec_files : io:io -> path -> path list + val file_exists : io:io -> path -> bool + val read_file : io:io -> path -> string option + val mkdir : io:io -> path -> unit type lock - val lock_file : path -> lock - val write_file : ?temp_dir:path -> ?lock:lock -> path -> string -> unit + val lock_file : io:io -> path -> lock + + val write_file : + io:io -> temp_dir:path -> ?lock:lock -> path -> string -> unit val test_and_set_file : - ?temp_dir:path -> + io:io -> + temp_dir:path -> lock:lock -> path -> test:string option -> set:string option -> bool - val remove_file : ?lock:lock -> path -> unit + val remove_file : io:io -> ?lock:lock -> path -> unit end (* ~path *) @@ -76,15 +82,15 @@ module Read_only_ext struct type key = K.t type value = V.t - type 'a t = { path : Fs.dir_ty Path.t } + type 'a t = { path : string; io : IO.io } let get_path config = Option.value Conf.(find_root config) ~default:"." let v config = - let fs = Irmin.Backend.Conf.Env.fs () in - let path = Path.(fs / get_path config) in - IO.mkdir path; - { path } + let io = IO.io_of_config config in + let path = get_path config in + IO.mkdir ~io path; + { path; io } let close _ = () let cast t = (t :> read_write t) @@ -93,12 +99,13 @@ struct let file_of_key { path; _ } key = path / S.file_of_key (Irmin.Type.to_string K.t key) - let lock_of_key { path; _ } key = - IO.lock_file (path / "lock" / S.file_of_key (Irmin.Type.to_string K.t key)) + let lock_of_key { io; path } key = + IO.lock_file ~io + (path / "lock" / S.file_of_key (Irmin.Type.to_string K.t key)) let mem t key = let file = file_of_key t key in - IO.file_exists file + IO.file_exists ~io:t.io file let of_bin_string = Irmin.Type.(unstage (of_bin_string V.t)) @@ -113,17 +120,17 @@ struct let find t key = [%log.debug "find %a" pp_key key]; - match IO.read_file (file_of_key t key) with + match IO.read_file ~io:t.io (file_of_key t key) with | None -> None | Some x -> value x - let list t = + let list { path; io } = [%log.debug "list"]; - let files = IO.rec_files (S.dir t.path) in + let files = IO.rec_files ~io (S.dir path) in let files = - let p = String.length (snd t.path) in + let p = String.length path in List.fold_left - (fun acc (_, file) -> + (fun acc file -> let n = String.length file in if n <= p + 1 then acc else @@ -156,11 +163,11 @@ struct [%log.debug "add %a" pp_key key]; let file = file_of_key t key in let temp_dir = temp_dir t in - match IO.file_exists file with + match IO.file_exists ~io:t.io file with | true -> () | false -> let str = to_bin_string value in - IO.write_file ~temp_dir file str + IO.write_file ~io:t.io ~temp_dir file str end module Atomic_write_ext @@ -217,7 +224,7 @@ struct [%log.err "listen_dir: %s" e]; None in - W.listen_dir t.w (snd dir) ~key ~value:(RO.find t.t) + W.listen_dir t.w dir ~key ~value:(RO.find t.t) let watch_key t key ?init f = let stop = listen_dir t in @@ -240,14 +247,14 @@ struct let temp_dir = temp_dir t in let file = RO.file_of_key t.t key in let lock = RO.lock_of_key t.t key in - IO.write_file ~temp_dir file ~lock (raw_value value); + IO.write_file ~io:t.t.io ~temp_dir file ~lock (raw_value value); W.notify t.w key (Some value) let remove t key = [%log.debug "remove %a" RO.pp_key key]; let file = RO.file_of_key t.t key in let lock = RO.lock_of_key t.t key in - let () = IO.remove_file ~lock file in + let () = IO.remove_file ~io:t.t.io ~lock file in W.notify t.w key None let test_and_set t key ~test ~set = @@ -257,8 +264,8 @@ struct let lock = RO.lock_of_key t.t key in let raw_value = function None -> None | Some v -> Some (raw_value v) in let b = - IO.test_and_set_file file ~temp_dir ~lock ~test:(raw_value test) - ~set:(raw_value set) + IO.test_and_set_file ~io:t.t.io file ~temp_dir ~lock + ~test:(raw_value test) ~set:(raw_value set) in let () = if b then W.notify t.w key set in b @@ -266,7 +273,8 @@ struct let clear t = [%log.debug "clear"]; let remove_file key () = - IO.remove_file ~lock:(RO.lock_of_key t.t key) (RO.file_of_key t.t key) + IO.remove_file ~io:t.t.io ~lock:(RO.lock_of_key t.t key) + (RO.file_of_key t.t key) in list t |> fun keys -> Eio.Fiber.all (List.map remove_file keys) end @@ -330,26 +338,31 @@ module KV (IO : IO) = struct end module IO_mem = struct + type io = unit + + let io_of_config _ = () + + type path = string + type t = { watches : (string, string -> unit) Hashtbl.t; - files : (Fs.dir_ty Path.t, string) Hashtbl.t; + files : (path, string) Hashtbl.t; } let t = { watches = Hashtbl.create 3; files = Hashtbl.create 13 } - type path = Fs.dir_ty Path.t type lock = Eio.Mutex.t let locks = Hashtbl.create 10 - let lock_file (_, file) = + let lock_file ~io:() file = try Hashtbl.find locks file with Not_found -> let l = Eio.Mutex.create () in Hashtbl.add locks file l; l - let with_lock l f = + let with_lock ~io:() l f = match l with None -> f () | Some l -> Eio.Mutex.use_rw ~protect:false l f let set_listen_hook () = @@ -363,29 +376,28 @@ module IO_mem = struct Hashtbl.iter (fun dir f -> if String.is_prefix ~affix:dir file then f file) t.watches - (* |> Eio.Fiber.all *) - let mkdir _ = () + let mkdir ~io:() _ = () - let remove_file ?lock file = - with_lock lock (fun () -> Hashtbl.remove t.files file) + let remove_file ~io ?lock file = + with_lock ~io lock (fun () -> Hashtbl.remove t.files file) - let rec_files (_, dir) = + let rec_files ~io:() dir = Hashtbl.fold - (fun ((_, k) as v) _ acc -> - if String.is_prefix ~affix:dir k then v :: acc else acc) + (fun file _ acc -> + if String.is_prefix ~affix:dir file then file :: acc else acc) t.files [] - let file_exists file = Hashtbl.mem t.files file + let file_exists ~io:() file = Hashtbl.mem t.files file - let read_file file = + let read_file ~io:() file = try let buf = Hashtbl.find t.files file in Some buf with Not_found -> None - let write_file ?temp_dir:_ ?lock ((_, file) as f) v = - let () = with_lock lock (fun () -> Hashtbl.replace t.files f v) in + let write_file ~io ~temp_dir:_ ?(lock : lock option) file v = + let () = with_lock ~io lock (fun () -> Hashtbl.replace t.files file v) in notify file let equal x y = @@ -394,7 +406,7 @@ module IO_mem = struct | Some x, Some y -> String.equal x y | _ -> false - let test_and_set_file ?temp_dir:_ ~lock file ~test ~set = + let test_and_set_file ~io ~temp_dir:_ ~lock file ~test ~set = let f () = let old = try Some (Hashtbl.find t.files file) with Not_found -> None in let b = @@ -408,10 +420,10 @@ module IO_mem = struct Hashtbl.replace t.files file v; true in - let () = if b then notify (snd file) in + let () = if b then notify file in b in - with_lock (Some lock) f + with_lock ~io (Some lock) f let clear () = Hashtbl.clear t.files; @@ -423,17 +435,3 @@ module Maker_is_a_maker : Irmin.Maker = Maker (IO_mem) (* Enforce that {!KV} is a sub-type of {!Irmin.KV_maker}. *) module KV_is_a_KV : Irmin.KV_maker = KV (IO_mem) - -let run (fs : Fs.dir_ty Path.t) fn = - Switch.run @@ fun sw -> - Irmin.Backend.Watch.set_watch_switch sw; - let open Effect.Deep in - try_with fn () - { - effc = - (fun (type a) (e : a Effect.t) -> - match e with - | Irmin.Backend.Conf.Env.Fs -> - Some (fun (k : (a, _) continuation) -> continue k fs) - | _ -> None); - } diff --git a/src/irmin-fs/irmin_fs.mli b/src/irmin-fs/irmin_fs.mli index a463246c6b..da2242530a 100644 --- a/src/irmin-fs/irmin_fs.mli +++ b/src/irmin-fs/irmin_fs.mli @@ -33,37 +33,43 @@ val config : string -> Irmin.config module type IO = sig (** {1 File-system abstractions} *) - type path = Eio.Fs.dir_ty Eio.Path.t + type io + + val io_of_config : Irmin.config -> io + + type path = string (** The type for paths. *) (** {2 Read operations} *) - val rec_files : path -> path list + val rec_files : io:io -> path -> path list (** [rec_files dir] is the list of files recursively present in [dir] and all of its sub-directories. Return filenames prefixed by [dir]. *) - val file_exists : path -> bool + val file_exists : io:io -> path -> bool (** [file_exist f] is true if [f] exists. *) - val read_file : path -> string option + val read_file : io:io -> path -> string option (** Read the contents of a file using mmap. *) (** {2 Write Operations} *) - val mkdir : path -> unit + val mkdir : io:io -> path -> unit (** Create a directory. *) type lock (** The type for file locks. *) - val lock_file : path -> lock + val lock_file : io:io -> path -> lock (** [lock_file f] is the lock associated to the file [f]. *) - val write_file : ?temp_dir:path -> ?lock:lock -> path -> string -> unit + val write_file : + io:io -> temp_dir:path -> ?lock:lock -> path -> string -> unit (** Atomic writes. *) val test_and_set_file : - ?temp_dir:path -> + io:io -> + temp_dir:path -> lock:lock -> path -> test:string option -> @@ -71,7 +77,7 @@ module type IO = sig bool (** Test and set. *) - val remove_file : ?lock:lock -> path -> unit + val remove_file : io:io -> ?lock:lock -> path -> unit (** Remove a file or directory (even if non-empty). *) end @@ -83,10 +89,9 @@ module KV (IO : IO) : Irmin.KV_maker with type info = Irmin.Info.default (** {2 Advanced configuration} *) module type Config = sig - open Eio (** Same as [Config] but gives more control on the file hierarchy. *) - val dir : Fs.dir_ty Path.t -> Fs.dir_ty Path.t + val dir : string -> string (** [dir root] is the sub-directory to look for the keys. *) val file_of_key : string -> string @@ -108,5 +113,3 @@ module IO_mem : sig val clear : unit -> unit val set_listen_hook : unit -> unit end - -val run : Eio.Fs.dir_ty Eio.Path.t -> (unit -> 'a) -> 'a diff --git a/src/irmin-fs/unix/dune b/src/irmin-fs/unix/dune index b8cb6dd1d8..324d06cd44 100644 --- a/src/irmin-fs/unix/dune +++ b/src/irmin-fs/unix/dune @@ -1,7 +1,7 @@ (library (public_name irmin-fs.unix) (name irmin_fs_unix) - (libraries irmin-fs irmin.unix lwt eio eio.unix) + (libraries irmin-fs irmin.unix eio eio.unix) (preprocess (pps ppx_irmin.internal)) (instrumentation diff --git a/src/irmin-fs/unix/eio_pool.ml b/src/irmin-fs/unix/eio_pool.ml index e32c122638..1c0b75cdab 100644 --- a/src/irmin-fs/unix/eio_pool.ml +++ b/src/irmin-fs/unix/eio_pool.ml @@ -103,8 +103,7 @@ let acquire p = (* Limit reached: wait for a free one. *) let promise, resolver = Promise.create () in Stream.add p.waiters resolver; - validate_and_return p (Promise.await_exn promise) - (* (Lwt.add_task_r [@ocaml.warning "-3"]) p.waiters >>= validate_and_return p *)) + validate_and_return p (Promise.await_exn promise)) else (* Take the first free member and validate it. *) let c = Queue.take p.list in diff --git a/src/irmin-fs/unix/irmin_fs_unix.ml b/src/irmin-fs/unix/irmin_fs_unix.ml index ef7253ad7b..9e19cde381 100644 --- a/src/irmin-fs/unix/irmin_fs_unix.ml +++ b/src/irmin-fs/unix/irmin_fs_unix.ml @@ -14,6 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +module Conf = Irmin.Backend.Conf include Irmin.Export_for_backends open Eio @@ -21,9 +22,51 @@ let src = Logs.Src.create "fs.unix" ~doc:"logs fs unix events" module Log = (val Logs.src_log src : Logs.LOG) +type fs = Eio.Fs.dir_ty Eio.Path.t +type clock = float Eio.Time.clock_ty Eio.Time.clock +type io = { fs : fs; clock : clock } + +let fs_typ : fs Conf.Typ.t = Conf.Typ.create () +let clock_typ : clock Conf.Typ.t = Conf.Typ.create () + +let spec ~path:fs ~clock = + let spec = Conf.Spec.v "irmin-fs.unix" in + let fs = (fs :> fs) in + let _fs_key = + let to_string fs = Eio.Path.native_exn fs in + let of_string str = Ok Eio.Path.(fs / str) in + let of_json_string str = + match Irmin.Type.(of_json_string string) str with + | Ok str -> Ok Eio.Path.(fs / str) + | Error e -> Error e + in + Conf.key' ~typ:fs_typ ~spec ~typename:"_ Eio.Path.t" ~to_string ~of_string + ~of_json_string "fs" fs + in + let clock = (clock :> clock) in + let _clock_key = + let to_string _ = "Eio.Time.clock" in + let of_string _ = Ok clock in + let of_json_string _ = Ok clock in + Conf.key' ~typ:clock_typ ~spec ~typename:"_ Eio.Time.clock" ~to_string + ~of_string ~of_json_string "clock" clock + in + spec + +let conf ~path ~clock = Conf.empty (spec ~path ~clock) + module IO = struct + type nonrec io = io + + let io_of_config conf = + { + fs = Conf.find_key conf "fs" fs_typ; + clock = Conf.find_key conf "clock" clock_typ; + } + + type path = string + let mkdir_pool = Eio_pool.create 1 (fun () -> ()) - let mmap_threshold = 4096 (* Files smaller than this are loaded using [read]. Use of mmap is necessary to handle packfiles efficiently. Since these are stored @@ -37,66 +80,41 @@ module IO = struct (* Pool of opened files *) let openfile_pool = Eio_pool.create 200 (fun () -> ()) - let protect_unix_exn = function - | Unix.Unix_error _ as e -> raise (Failure (Printexc.to_string e)) - | e -> raise e - - let ignore_enoent = function - | Unix.Unix_error (Unix.ENOENT, _, _) -> () - | e -> raise e - - let protect f x = try f x with exn -> protect_unix_exn exn - let safe f x = try f x with exn -> ignore_enoent exn - let mkdir dirname = - let rec aux ((_, path) as dir) = - if Sys.file_exists path && Sys.is_directory path then () - else ( - if Sys.file_exists path then ( - [%log.debug "%s already exists but is a file, removing." path]; - safe Path.unlink dir); - let parent = (fst dir, Filename.dirname @@ snd dir) in - aux parent; - [%log.debug "mkdir %s" path]; - protect (Path.mkdir ~perm:0o755) dir) - in - (* TODO: Pool *) - Eio_pool.use mkdir_pool (fun () -> aux dirname) + Eio_pool.use mkdir_pool (fun () -> + Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 dirname) - let file_exists (_, f) = - try Sys.file_exists f with - (* See https://github.com/ocsigen/lwt/issues/316 *) - | Unix.Unix_error (Unix.ENOTDIR, _, _) -> false - | e -> raise e + let mkdir_parent file = + match Eio.Path.split file with + | None -> () + | Some (parent, _) -> mkdir parent + + let file_exists ~io:{ fs; _ } filename = Eio.Path.(is_file (fs / filename)) module Lock = struct - let is_stale max_age file = + let is_stale ~io:{ clock; _ } max_age file = try - let s = Eio_unix.run_in_systhread (fun () -> Unix.stat file) in - if s.Unix.st_mtime < 1.0 (* ??? *) then false - else Unix.gettimeofday () -. s.Unix.st_mtime > max_age - with - | Unix.Unix_error (Unix.ENOENT, _, _) -> false - | e -> raise e + let { Eio.File.Stat.mtime; _ } = Eio.Path.stat ~follow:false file in + if mtime < 1.0 (* ??? *) then false + else Eio.Time.now clock -. mtime > max_age + with Eio.Io (Eio.Fs.E (Not_found _), _) -> false let unlock file = Path.unlink file - let lock ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) - ((_, file) as fcap) = + let lock ~io ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) file + = let rec aux i = - [%log.debug "lock %s %d" file i]; - let is_stale = is_stale max_age file in - if is_stale then ( - [%log.err "%s is stale, removing it." file]; - unlock fcap; + [%log.debug "lock %a %d" Eio.Path.pp file i]; + if is_stale ~io max_age file then ( + [%log.err "%a is stale, removing it." Eio.Path.pp file]; + unlock file; aux 1) else let create () = let pid = Unix.getpid () in - let parent = (fst fcap, Filename.dirname file) in - mkdir parent; + mkdir_parent file; Switch.run @@ fun sw -> - let flow = Path.open_out ~sw fcap ~create:(`Exclusive 0o600) in + let flow = Path.open_out ~sw file ~create:(`Exclusive 0o600) in Flow.copy_string (string_of_int pid) flow in try create () with @@ -107,180 +125,131 @@ module IO = struct (let i = float i in i *. i) in - Eio_unix.sleep (sleep *. backoff); + Eio.Time.sleep io.clock (sleep *. backoff); aux (i + 1) | e -> raise e in aux 1 - let with_lock file fn = + let with_lock ~io file fn = match file with | None -> fn () | Some f -> - lock f; + lock ~io f; Fun.protect fn ~finally:(fun () -> unlock f) end - type path = Eio.Fs.dir_ty Eio.Path.t - (* we use file locking *) - type lock = path + type lock = Eio.Fs.dir_ty Eio.Path.t - let lock_file x = x - let file_exists = file_exists + let lock_file ~io:{ fs; _ } x = Path.(fs / x) - let list_files kind ((_, dir) as v) = - if Sys.file_exists dir && Sys.is_directory dir then - let d = Path.read_dir v in - let d = List.sort String.compare d in - let d = List.map (Path.( / ) v) d in + let list_files kind dir = + if Eio.Path.is_directory dir then + let d = Path.read_dir dir in + let d = List.map (Path.( / ) dir) d in let d = List.filter kind d in d else [] - let directories dir = - list_files - (fun (_, f) -> try Sys.is_directory f with Sys_error _ -> false) - dir - - let files dir = - list_files - (fun (_, f) -> try not (Sys.is_directory f) with Sys_error _ -> false) - dir + let directories dir = list_files Eio.Path.is_directory dir + let files dir = list_files Eio.Path.is_file dir let write_string fd b = match String.length b with 0 -> () | _len -> Flow.copy_string b fd let _delays = Array.init 20 (fun i -> 0.1 *. (float i ** 2.)) + let remove_dir dir = Eio.Path.rmtree dir - let command fmt = - Printf.ksprintf - (fun str -> - [%log.debug "[exec] %s" str]; - let i = Sys.command str in - if i <> 0 then [%log.debug "[exec] error %d" i]) - fmt - - let remove_dir dir = - if Sys.os_type = "Win32" then command "cmd /d /v:off /c rd /s /q %S" dir - else command "rm -rf %S" dir - - let remove_file ?lock ((_, file) as f) = - Lock.with_lock lock (fun () -> - try Path.unlink f with - (* On Windows, [EACCES] can also occur in an attempt to - rename a file or directory or to remove an existing - directory. *) - | Unix.Unix_error (Unix.EACCES, _, _) - | Unix.Unix_error (Unix.EISDIR, _, _) - | Eio.Io (Eio.Exn.X (Eio_unix.Unix_error (Unix.EACCES, _, _)), _) - | Eio.Io (Eio.Exn.X (Eio_unix.Unix_error (Unix.EISDIR, _, _)), _) -> - remove_dir file - | Unix.Unix_error (Unix.ENOENT, _, _) - | Eio.Io (Eio.Fs.E (Fs.Not_found _), _) -> - () - | e -> raise e) - - let rename tmp file = Path.rename tmp file - - let with_write_file ?temp_dir file fn = - let () = match temp_dir with None -> () | Some d -> mkdir d in - let dir = (fst file, Filename.dirname @@ snd file) in - mkdir dir; - let temp_dir_path = Option.get temp_dir in - let temp_dir = snd temp_dir_path in - let file_f = snd file in - let tmp_f = - Filename.temp_file ~temp_dir (Filename.basename file_f) "write" + let remove_file ~io ?lock file = + Lock.with_lock ~io lock (fun () -> + let file = Path.(io.fs / file) in + if Path.is_directory file then remove_dir file + else + try Path.unlink file + with Eio.Io (Eio.Fs.E (Fs.Not_found _), _) -> ()) + + let temp_file ~temp_dir file suffix = + let basename = + match Eio.Path.split file with + | None -> "tmp" + | Some (_, basename) -> basename + in + let rec go i = + let tmp = Eio.Path.(temp_dir / (basename ^ string_of_int i ^ suffix)) in + if Eio.Path.kind ~follow:false tmp = `Not_found then tmp else go (i + 1) in - let tmp_name = Filename.basename tmp_f in + go 0 + + let with_write_file ~temp_dir file fn = + mkdir temp_dir; + mkdir_parent file; + let tmp_file = temp_file ~temp_dir file "write" in Eio_pool.use openfile_pool (fun () -> - [%log.debug - "Writing %s (%s) %s %s" file_f tmp_f (snd temp_dir_path) (snd file)]; - Path.( - with_open_out ~create:(`Or_truncate 0o644) (temp_dir_path / tmp_name) - fn); - rename Path.(temp_dir_path / tmp_name) file) + [%log.debug "Writing %a (%a)" Eio.Path.pp file Eio.Path.pp tmp_file]; + Path.(with_open_out ~create:(`Or_truncate 0o644) tmp_file fn); + Path.rename tmp_file file) let read_file_with_read file size = - (* let chunk_size = max 4096 (min size 0x100000) in *) let buf = Cstruct.create size in - (* let flags = [ Unix.O_RDONLY ] in - let perm = 0o0 in *) - (* let* fd = Lwt_unix.openfile file flags perm in *) Path.with_open_in file @@ fun flow -> - try - Flow.read_exact flow buf; - Cstruct.to_string buf - with End_of_file -> Cstruct.to_string buf - - let read_file_with_mmap file = - let open Bigarray in - let fd = Unix.(openfile file [ O_RDONLY; O_NONBLOCK ] 0o644) in - let ba = - Unix.map_file fd char c_layout false [| -1 |] - |> Bigarray.array1_of_genarray - in - Unix.close fd; + Flow.read_exact flow buf; + Cstruct.to_string buf - (* XXX(samoht): ideally we should not do a copy here. *) - Bigstringaf.to_string ba - - let read_file file = - let file_f = snd file in + let read_file ~io:{ fs; _ } file = try + let file = Path.(fs / file) in Eio_pool.use openfile_pool (fun () -> - [%log.debug "Reading %s" file_f]; - let stats = Unix.stat file_f in - let size = stats.Unix.st_size in - let buf = - if size >= mmap_threshold then read_file_with_mmap file_f - else read_file_with_read file size - in + [%log.debug "Reading %a" Eio.Path.pp file]; + let { Eio.File.Stat.size; _ } = Eio.Path.stat ~follow:false file in + let size = Optint.Int63.to_int size in + let buf = read_file_with_read file size in Some buf) - with - | Unix.Unix_error _ | Sys_error _ -> None - | e -> raise e + with Eio.Io _ -> None - let write_file ?temp_dir ?lock file b = + let write_file ~io ~temp_dir ?(lock : lock option) file b = + let file = Path.(io.fs / file) in + let temp_dir = Path.(io.fs / temp_dir) in let write () = - with_write_file file ?temp_dir (fun fd -> write_string fd b) + with_write_file file ~temp_dir (fun fd -> write_string fd b) in - Lock.with_lock lock (fun () -> - try write () with - | Unix.Unix_error (Unix.EISDIR, _, _) -> - remove_dir (snd file); - write () - | e -> raise e) - - let test_and_set_file ?temp_dir ~lock file ~test ~set = - Lock.with_lock (Some lock) (fun () -> - let v = read_file file in + Lock.with_lock ~io lock (fun () -> + if Path.is_directory file then remove_dir file; + write ()) + + let test_and_set_file ~io ~temp_dir ~lock file ~test ~set = + Lock.with_lock ~io (Some lock) (fun () -> + let v = read_file ~io file in let equal = match (test, v) with | None, None -> true - | Some x, Some y -> x = y (* TODO *) + | Some x, Some y -> String.equal x y | _ -> false in if not equal then false else let () = match set with - | None -> remove_file file - | Some v -> write_file ?temp_dir file v + | None -> remove_file ~io file + | Some v -> write_file ~io ~temp_dir file v in true) - let rec_files dir : Fs.dir_ty Path.t list = + let rec_files ~io:{ fs; _ } dir : path list = + let dir = Path.(fs / dir) in let rec aux accu dir = let ds = directories dir in let fs = files dir in List.fold_left aux (fs @ accu) ds in - aux [] dir + aux [] dir |> List.map snd + + let mkdir ~io:{ fs; _ } dirname = mkdir Path.(fs / dirname) end -module Append_only = Irmin_fs.Append_only (IO) +module Append_only (K : Irmin.Type.S) (V : Irmin.Type.S) = + Irmin_fs.Append_only (IO) (K) (V) + module Atomic_write = Irmin_fs.Atomic_write (IO) include Irmin_fs.Maker (IO) module KV = Irmin_fs.KV (IO) diff --git a/src/irmin-fs/unix/irmin_fs_unix.mli b/src/irmin-fs/unix/irmin_fs_unix.mli index bcfe077790..b75a48b0bb 100644 --- a/src/irmin-fs/unix/irmin_fs_unix.mli +++ b/src/irmin-fs/unix/irmin_fs_unix.mli @@ -28,3 +28,10 @@ module Maker_ext (Obj : Irmin_fs.Config) (Ref : Irmin_fs.Config) : Irmin.Maker (** {1 Common Unix utilities} *) include module type of Irmin_unix + +(** {1 Backend-specific config} *) + +val spec : + path:_ Eio.Path.t -> clock:_ Eio.Time.clock -> Irmin.Backend.Conf.Spec.t + +val conf : path:_ Eio.Path.t -> clock:_ Eio.Time.clock -> Irmin.Backend.Conf.t diff --git a/src/irmin/conf.ml b/src/irmin/conf.ml index d66e810a12..c694a1241d 100644 --- a/src/irmin/conf.ml +++ b/src/irmin/conf.ml @@ -16,6 +16,25 @@ *) open! Import +type (_, _) eq = Refl : ('a, 'a) eq + +module Typ = struct + type 'a s = .. + type 'a t = { s : 'a s; eq : 'b. 'b s -> ('a, 'b) eq option } + + let create (type a) () : a t = + let open struct + type _ s += S : a s + + let eq : type b. b s -> (a, b) eq option = function + | S -> Some Refl + | _ -> None + end in + { s = S; eq } + + let equal a b = a.eq b.s +end + module Univ = struct type t = exn @@ -31,8 +50,12 @@ type 'a key = { doc : string option; docv : string option; docs : string option; - ty : 'a Type.t; + typename : string; + to_string : 'a -> string; + of_string : string -> ('a, [ `Msg of string ]) result; + of_json_string : string -> ('a, [ `Msg of string ]) result; default : 'a; + typ : 'a Typ.t; to_univ : 'a -> Univ.t; of_univ : Univ.t -> 'a option; } @@ -50,20 +73,9 @@ module Spec = struct type t = { name : string; mutable keys : k M.t } - let all = Hashtbl.create 8 - - let v name = - let keys = M.empty in - if Hashtbl.mem all name then - Fmt.failwith "Config spec already exists: %s" name; - let x = { name; keys } in - Hashtbl.replace all name x; - x - + let v name = { name; keys = M.empty } let name { name; _ } = name let update spec name k = spec.keys <- M.add name k spec.keys - let list () = Hashtbl.to_seq_values all - let find name = Hashtbl.find_opt all name let find_key spec name = M.find_opt name spec.keys let keys spec = M.to_seq spec.keys |> Seq.map snd let clone { name; keys } = { name; keys } @@ -87,7 +99,8 @@ type t = Spec.t * Univ.t M.t let spec = fst -let key ?docs ?docv ?doc ?(allow_duplicate = false) ~spec name ty default = +let key' ?docs ?docv ?doc ?(allow_duplicate = false) ?typ ~spec ~typename + ~to_string ~of_string ~of_json_string name default = let () = String.iter (function @@ -99,16 +112,44 @@ let key ?docs ?docv ?doc ?(allow_duplicate = false) ~spec name ty default = | Some _ when allow_duplicate = false -> Fmt.invalid_arg "duplicate key: %s" name | _ -> + let typ = match typ with Some typ -> typ | None -> Typ.create () in let to_univ, of_univ = Univ.create () in - let k = { name; ty; default; to_univ; of_univ; doc; docv; docs } in + let k = + { + name; + to_string; + of_json_string; + of_string; + default; + typename; + typ; + to_univ; + of_univ; + doc; + docv; + docs; + } + in Spec.update spec name (K k); k +let key ?docs ?docv ?doc ?allow_duplicate ?typ ~spec name ty default = + let to_string = Type.to_string ty in + let typename = + Fmt.str "%a" Type.pp_ty ty |> Astring.String.filter (fun c -> c <> '\n') + in + let of_string = Type.of_string ty in + let of_json_string = Type.of_json_string ty in + key' ?docs ?docv ?doc ?allow_duplicate ?typ ~spec ~typename ~to_string + ~of_json_string ~of_string name default + let name t = t.name let doc t = t.doc let docv t = t.docv let docs t = t.docs -let ty t = t.ty +let typename t = t.typename +let of_string t = t.of_string +let of_json_string t = t.of_json_string let default t = t.default let empty spec = (spec, M.empty) let singleton spec k v = (spec, M.singleton (K k) (k.to_univ v)) @@ -143,6 +184,15 @@ let get (_, d) k = | None -> raise Not_found with Not_found -> k.default +let find_key : type a. t -> string -> a Typ.t -> a = + fun ((spec, _) as t) name typ -> + match Spec.find_key spec name with + | Some (K k) -> ( + match Typ.equal k.typ typ with + | Some Refl -> get t k + | None -> raise Not_found) + | None -> raise Not_found + let keys (_, conf) = M.to_seq conf |> Seq.map (fun (k, _) -> k) let with_spec (_, conf) spec = (spec, conf) @@ -152,7 +202,7 @@ let to_strings (_, conf) = |> Seq.map (fun (K k, v) -> ( k.name, match k.of_univ v with - | Some v -> Type.to_string k.ty v + | Some v -> k.to_string v | None -> assert false )) let pp ppf t = @@ -177,13 +227,4 @@ let find_root (spec, d) : string option = | None -> None | Some (K k) -> ( let v = find (spec, d) k in - match v with None -> None | Some v -> Some (Type.to_string k.ty v)) - -module Env = struct - type _ Effect.t += - | Fs : Eio.Fs.dir_ty Eio.Path.t Effect.t - | Net : _ Eio.Net.t Effect.t - - let fs () = Effect.perform Fs - let net () = Effect.perform Net -end + match v with None -> None | Some v -> Some (k.to_string v)) diff --git a/src/irmin/conf.mli b/src/irmin/conf.mli index c312c0b6d1..533d277bb8 100644 --- a/src/irmin/conf.mli +++ b/src/irmin/conf.mli @@ -36,12 +36,6 @@ module Spec : sig val name : t -> string (** [name spec] is the name associated with a config spec *) - val list : unit -> t Seq.t - (** [list ()] is a sequence containing all available config specs *) - - val find : string -> t option - (** [find name] is the config spec associated with [name] if available *) - val find_key : t -> string -> k option (** [find_key spec k] is the key associated with the name [k] in [spec] *) @@ -55,11 +49,18 @@ module Spec : sig the specs in [b] joined by hyphens. *) end +module Typ : sig + type 'a t + + val create : unit -> 'a t +end + val key : ?docs:string -> ?docv:string -> ?doc:string -> ?allow_duplicate:bool -> + ?typ:'a Typ.t -> spec:Spec.t -> string -> 'a Type.t -> @@ -83,11 +84,36 @@ val key : if [allow_duplicate] is [false] (the default) and [name] has already been used to create a key *) +val key' : + ?docs:string -> + ?docv:string -> + ?doc:string -> + ?allow_duplicate:bool -> + ?typ:'a Typ.t -> + spec:Spec.t -> + typename:string -> + to_string:('a -> string) -> + of_string:(string -> ('a, [ `Msg of string ]) result) -> + of_json_string:(string -> ('a, [ `Msg of string ]) result) -> + string -> + 'a -> + 'a key +(** Same as {!key} for types that don't implement [Type.t] but can be serialized + with [to_string], and deserialized with either [of_string] or + [of_json_string]. The [typename] is the user-readable description of the + type, in case of dynamic type errors. *) + val name : 'a key -> string (** The key name. *) -val ty : 'a key -> 'a Type.t -(** [tc k] is [k]'s converter. *) +val typename : 'a key -> string +(** [typename k] is the type name of [k]'s values. *) + +val of_string : 'a key -> string -> ('a, [ `Msg of string ]) result +(** [of_string k] is the parser of [k]'s values. *) + +val of_json_string : 'a key -> string -> ('a, [ `Msg of string ]) result +(** [of_json_string k] is the json parser of [k]'s values. *) val default : 'a key -> 'a (** [default k] is [k]'s default value. *) @@ -154,6 +180,10 @@ val keys : t -> k Seq.t val with_spec : t -> Spec.t -> t (** [with_spec t s] is the config [t] with spec [s] *) +val find_key : t -> string -> 'a Typ.t -> 'a +(** [find_key t name typ] returns the value associated with [name] in the config + [t]. *) + val verify : t -> t (** [verify t] is an identity function that ensures all keys match the spec @@ -166,12 +196,3 @@ val uri : Uri.t Type.t val find_root : t -> string option (** [find_root c] is [root]'s mapping in [c], if any. *) - -module Env : sig - type _ Effect.t += - | Fs : Eio.Fs.dir_ty Eio.Path.t Effect.t - | Net : _ Eio.Net.t Effect.t - - val fs : unit -> Eio.Fs.dir_ty Eio.Path.t - val net : unit -> _ Eio.Net.t -end diff --git a/src/libirmin/config.ml b/src/libirmin/config.ml index 29fab1e0d6..50a87aeec5 100644 --- a/src/libirmin/config.ml +++ b/src/libirmin/config.ml @@ -40,10 +40,11 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct fn "config_pack" (string_opt @-> string_opt @-> returning config) (fun hash contents -> + run_env @@ fun env -> try let hash = Option.map Irmin_cli.Resolver.Hash.find hash in let c : config = - Irmin_cli.Resolver.load_config ~store:"pack" ?hash ?contents () + Irmin_cli.Resolver.load_config ~env ~store:"pack" ?hash ?contents () in Root.create_config c with _ -> null config) @@ -52,8 +53,11 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct fn "config_tezos" (void @-> returning config) (fun () -> + run_env @@ fun env -> try - let c : config = Irmin_cli.Resolver.load_config ~store:"tezos" () in + let c : config = + Irmin_cli.Resolver.load_config ~env ~store:"tezos" () + in Root.create_config c with _ -> null config) @@ -61,8 +65,11 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct fn "config_git" (string_opt @-> returning config) (fun contents -> + run_env @@ fun env -> try - let c = Irmin_cli.Resolver.load_config ~store:"git" ?contents () in + let c = + Irmin_cli.Resolver.load_config ~env ~store:"git" ?contents () + in Root.create_config c with _ -> null config) @@ -70,9 +77,10 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct fn "config_git_mem" (string_opt @-> returning config) (fun contents -> + run_env @@ fun env -> try let c = - Irmin_cli.Resolver.load_config ~store:"git-mem" ?contents () + Irmin_cli.Resolver.load_config ~env ~store:"git-mem" ?contents () in Root.create_config c with _ -> null config) @@ -81,10 +89,11 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct fn "config_fs" (string_opt @-> string_opt @-> returning config) (fun hash contents -> + run_env @@ fun env -> try let hash = Option.map Irmin_cli.Resolver.Hash.find hash in let c = - Irmin_cli.Resolver.load_config ~store:"irf" ?hash ?contents () + Irmin_cli.Resolver.load_config ~env ~store:"irf" ?hash ?contents () in Root.create_config c with _ -> null config) @@ -93,10 +102,11 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct fn "config_mem" (string_opt @-> string_opt @-> returning config) (fun hash contents -> + run_env @@ fun env -> try let hash = Option.map Irmin_cli.Resolver.Hash.find hash in let c = - Irmin_cli.Resolver.load_config ~store:"mem" ?hash ?contents () + Irmin_cli.Resolver.load_config ~env ~store:"mem" ?hash ?contents () in Root.create_config c with _ -> null config) @@ -116,7 +126,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct | None -> (false, config) | Some (Irmin.Backend.Conf.K k) -> let t : a Irmin.Type.t = Root.get_ty ty in - if type_name t <> type_name (Irmin.Backend.Conf.ty k) then + if type_name t <> Irmin.Backend.Conf.typename k then (false, config) else let value = Root.get_value value in @@ -139,8 +149,7 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct | None -> (false, config) | Some (Irmin.Backend.Conf.K k) -> let path = - Irmin.Type.of_string (Irmin.Backend.Conf.ty k) path - |> Result.get_ok + Irmin.Backend.Conf.of_string k path |> Result.get_ok in (true, Irmin.Backend.Conf.add config k path) in diff --git a/src/libirmin/util.ml b/src/libirmin/util.ml index 3b0ad52b31..e2ab02c80c 100644 --- a/src/libirmin/util.ml +++ b/src/libirmin/util.ml @@ -43,9 +43,12 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let fn name t f = I.internal ~runtime_lock:false ("irmin_" ^ name) t f - let run fn = + let run_env fn = Eio_main.run @@ fun env -> - Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> fn () + Lwt_eio.with_event_loop ~clock:env#clock @@ fun () -> + fn (env :> Irmin_cli.eio) + + let run fn = run_env (fun _ -> fn ()) module Root = struct let to_voidp t x = Ctypes.coerce t (ptr void) x diff --git a/test/irmin-cli/test.ml b/test/irmin-cli/test.ml index 01123ad540..d04fbe4802 100644 --- a/test/irmin-cli/test.ml +++ b/test/irmin-cli/test.ml @@ -17,10 +17,10 @@ include Irmin.Export_for_backends module Conf = struct - let test_config () = + let test_config ~env = let hash = Irmin_cli.Resolver.Hash.find "blake2b" in let _, cfg = - Irmin_cli.Resolver.load_config ~config_path:"test/irmin-cli/test.yml" + Irmin_cli.Resolver.load_config ~env ~config_path:"test/irmin-cli/test.yml" ~store:"pack" ~contents:"string" ~hash () in let spec = Irmin.Backend.Conf.spec cfg in @@ -34,8 +34,11 @@ module Conf = struct Alcotest.(check int) "index-log-size" 1234 index_log_size; Alcotest.(check bool) "fresh" true fresh - let misc : unit Alcotest.test_case list = - [ ("config", `Quick, fun () -> test_config ()) ] + let misc ~env : unit Alcotest.test_case list = + [ ("config", `Quick, fun () -> test_config ~env) ] end -let () = Alcotest.run "irmin-cli" [ ("conf", Conf.misc) ] +let () = + Eio_main.run @@ fun env -> + let env = (env :> Irmin_cli.eio) in + Alcotest.run "irmin-cli" [ ("conf", Conf.misc ~env) ] diff --git a/test/irmin-cli/test_command_line.t b/test/irmin-cli/test_command_line.t index cd99931ee0..3e11108b7b 100644 --- a/test/irmin-cli/test_command_line.t +++ b/test/irmin-cli/test_command_line.t @@ -94,3 +94,33 @@ Clone a local repo irmin: [WARNING] Updating the control file to [Used_non_minimal_indexing_strategy]. It won't be possible to GC this irmin-pack store anymore. $ irmin get --root ./cloned a/b/c 123 + +Show documentation + $ irmin + usage: irmin [--version] + [--help] + [] + + The most commonly used subcommands are: + init Initialize a store. + get Read the value associated with a key. + set Update the value associated with a key. + remove Delete a key. + list List subdirectories. + tree List the store contents. + clone Copy a remote respository to a local store + fetch Download objects and refs from another repository. + merge Merge branches. + pull Fetch and merge with another repository. + push Update remote references along with associated objects. + snapshot Return a snapshot for the current state of the database. + revert Revert the contents of the store to a previous state. + watch Get notifications when values change. + dot Dump the contents of the store as a Graphviz file. + graphql Run a graphql server. + server Run irmin-server. + options Get information about backend specific configuration options. + branches List branches + log List commits + + See `irmin help ` for more information on a specific command. diff --git a/test/irmin-fs/test.ml b/test/irmin-fs/test.ml index 17fb69d99d..7d7a322d71 100644 --- a/test/irmin-fs/test.ml +++ b/test/irmin-fs/test.ml @@ -15,7 +15,6 @@ *) let () = - Eio_main.run @@ fun env -> - Irmin_fs.run env#fs @@ fun () -> + Eio_main.run @@ fun _env -> Irmin_test.Store.run "irmin-fs" ~slow:true ~misc:[] ~sleep:Eio_unix.sleep [ (`Quick, Test_fs.suite) ] diff --git a/test/irmin-fs/test_fs_unix.ml b/test/irmin-fs/test_fs_unix.ml index 2975f784f3..91d9d8a81d 100644 --- a/test/irmin-fs/test_fs_unix.ml +++ b/test/irmin-fs/test_fs_unix.ml @@ -19,7 +19,6 @@ let stats () = (stats.Irmin_watcher.watchdogs, Irmin.Backend.Watch.workers ()) let test_db = Test_fs.test_db -let config = Test_fs.config let store = Irmin_test.store (module Irmin_fs_unix) (module Irmin.Metadata.None) let clean_dirs config = @@ -39,5 +38,6 @@ let clean ~config = clean_dirs config; Irmin.Backend.Watch.(set_listen_dir_hook none) -let suite = +let suite ~path ~clock = + let config = Irmin_fs_unix.conf ~path ~clock in Irmin_test.Suite.create ~name:"FS.UNIX" ~init ~store ~config ~clean ~stats () diff --git a/test/irmin-fs/test_unix.ml b/test/irmin-fs/test_unix.ml index f312b9f3f4..adffd629d8 100644 --- a/test/irmin-fs/test_unix.ml +++ b/test/irmin-fs/test_unix.ml @@ -16,8 +16,9 @@ let () = Eio_main.run @@ fun env -> - Irmin_fs.run env#fs @@ fun () -> Irmin_watcher.run @@ fun () -> + let path = Eio.Stdenv.cwd env in + let clock = Eio.Stdenv.clock env in Irmin_test.Store.run "irmin-fs.unix" ~slow:false ~sleep:Eio_unix.sleep ~misc:[] - [ (`Quick, Test_fs_unix.suite) ] + [ (`Quick, Test_fs_unix.suite ~path ~clock) ] diff --git a/test/irmin/test_conf.ml b/test/irmin/test_conf.ml index afcd08b7c9..e6aa40acd3 100644 --- a/test/irmin/test_conf.ml +++ b/test/irmin/test_conf.ml @@ -28,12 +28,6 @@ let test_conf () = (Invalid_argument "invalid config key: x") (fun () -> ignore (add (empty spec_b) x 1)) in - let specs = - Spec.list () |> Seq.map Spec.name |> List.of_seq |> List.sort String.compare - in - let () = - Alcotest.(check (list string)) "Spec list" [ "a"; "b"; "mem" ] specs - in let keys = Spec.keys spec_a |> Seq.map (fun (K k) -> name k) From 9046cf5ef61840be143cd396e3faef3d86155833 Mon Sep 17 00:00:00 2001 From: gwenaelle Date: Wed, 15 May 2024 11:38:36 +0200 Subject: [PATCH 2/2] irmin-pack: eio backend --- bench/irmin-pack/bench_common.ml | 38 +- bench/irmin-pack/bench_common.mli | 8 +- bench/irmin-pack/dune | 2 +- bench/irmin-pack/main.ml | 22 +- bench/irmin-pack/trace_collection.ml | 2 +- bench/irmin-pack/trace_common.ml | 5 +- bench/irmin-pack/trace_replay.ml | 37 +- bench/irmin-pack/trace_replay_intf.ml | 26 +- bench/irmin-pack/trace_stat_summary.ml | 1 + bench/irmin-pack/trace_stats.ml | 44 +- bench/irmin-pack/tree.ml | 141 ++-- examples/irmin-pack/gc.ml | 36 +- examples/irmin-pack/kv.ml | 17 +- src/irmin-cli/cli.ml | 9 +- src/irmin-cli/import.ml | 3 +- src/irmin-cli/resolver.ml | 20 +- src/irmin-cli/resolver.mli | 2 +- src/irmin-client/unix/bin/client.ml | 8 + src/irmin-pack-tools/ppcf/dune | 2 +- src/irmin-pack-tools/ppcf/ppcf.ml | 14 +- src/irmin-pack-tools/tezos_explorer/dune | 3 +- src/irmin-pack-tools/tezos_explorer/main.ml | 18 +- src/irmin-pack-tools/tezos_explorer/parse.ml | 9 +- src/irmin-pack-tools/tezos_explorer/show.ml | 8 +- src/irmin-pack/atomic_write_intf.ml | 7 +- src/irmin-pack/conf.ml | 43 +- src/irmin-pack/conf.mli | 14 +- src/irmin-pack/io/append_only_file.ml | 17 +- src/irmin-pack/io/append_only_file_intf.ml | 13 +- src/irmin-pack/io/async_intf.ml | 3 +- src/irmin-pack/io/atomic_write.ml | 30 +- src/irmin-pack/io/checks.ml | 117 ++-- src/irmin-pack/io/checks_intf.ml | 51 +- src/irmin-pack/io/chunked_suffix.ml | 31 +- src/irmin-pack/io/chunked_suffix_intf.ml | 9 +- src/irmin-pack/io/control_file.ml | 34 +- src/irmin-pack/io/control_file_intf.ml | 23 +- src/irmin-pack/io/dict.ml | 12 +- src/irmin-pack/io/dict_intf.ml | 11 +- src/irmin-pack/io/file_manager.ml | 233 ++++--- src/irmin-pack/io/file_manager_intf.ml | 24 +- src/irmin-pack/io/gc.ml | 32 +- src/irmin-pack/io/gc.mli | 10 +- src/irmin-pack/io/gc_worker.ml | 26 +- src/irmin-pack/io/gc_worker.mli | 7 +- src/irmin-pack/io/io_intf.ml | 42 +- src/irmin-pack/io/lower.ml | 67 +- src/irmin-pack/io/lower_intf.ml | 18 +- src/irmin-pack/io/snapshot.ml | 22 +- src/irmin-pack/io/snapshot_intf.ml | 12 +- src/irmin-pack/io/sparse_file.ml | 47 +- src/irmin-pack/io/sparse_file_intf.ml | 25 +- src/irmin-pack/io/store.ml | 89 ++- src/irmin-pack/io/store_intf.ml | 29 +- src/irmin-pack/io/traverse_pack_file.ml | 20 +- src/irmin-pack/irmin_pack_intf.ml | 6 +- src/irmin-pack/layout.ml | 7 +- src/irmin-pack/unix/async.ml | 125 +--- src/irmin-pack/unix/io.ml | 277 +++++--- src/irmin/conf.ml | 2 + src/irmin/conf.mli | 3 + src/libirmin/util.ml | 8 + test/irmin-bench/replay.ml | 62 +- test/irmin-bench/test.ml | 6 +- test/irmin-cli/test.ml | 9 +- test/irmin-pack/bench_multicore/bench.ml | 28 +- test/irmin-pack/bench_multicore/main.ml | 4 +- test/irmin-pack/common.ml | 80 +-- test/irmin-pack/common.mli | 53 +- test/irmin-pack/dune | 8 +- test/irmin-pack/test.ml | 10 +- test/irmin-pack/test_async.ml | 21 +- test/irmin-pack/test_async.mli | 2 +- test/irmin-pack/test_corrupted.ml | 25 +- test/irmin-pack/test_corrupted.mli | 2 +- test/irmin-pack/test_dispatcher.ml | 21 +- test/irmin-pack/test_dispatcher.mli | 5 +- test/irmin-pack/test_existing_stores.ml | 152 ++-- test/irmin-pack/test_existing_stores.mli | 5 +- test/irmin-pack/test_flush_reload.ml | 42 +- test/irmin-pack/test_gc.ml | 689 +++++++++++-------- test/irmin-pack/test_gc.mli | 44 +- test/irmin-pack/test_hashes.ml | 41 +- test/irmin-pack/test_hashes.mli | 2 +- test/irmin-pack/test_indexing_strategy.ml | 22 +- test/irmin-pack/test_indexing_strategy.mli | 2 +- test/irmin-pack/test_inode.ml | 174 +++-- test/irmin-pack/test_inode.mli | 2 +- test/irmin-pack/test_lower.ml | 263 +++---- test/irmin-pack/test_lower.mli | 7 +- test/irmin-pack/test_mapping.ml | 33 +- test/irmin-pack/test_mapping.mli | 2 +- test/irmin-pack/test_multicore.ml | 179 +++-- test/irmin-pack/test_pack.ml | 252 +++---- test/irmin-pack/test_pack.mli | 8 +- test/irmin-pack/test_pack_version_bump.ml | 71 +- test/irmin-pack/test_pack_version_bump.mli | 5 +- test/irmin-pack/test_readonly.ml | 44 +- test/irmin-pack/test_readonly.mli | 2 +- test/irmin-pack/test_snapshot.ml | 106 ++- test/irmin-pack/test_tree.ml | 111 +-- test/irmin-pack/test_upgrade.ml | 113 +-- test/irmin-tezos/generate.ml | 42 +- test/irmin-tezos/irmin_fsck.ml | 7 +- 104 files changed, 2831 insertions(+), 1946 deletions(-) diff --git a/bench/irmin-pack/bench_common.ml b/bench/irmin-pack/bench_common.ml index 771ce98df2..ecb67485b4 100644 --- a/bench/irmin-pack/bench_common.ml +++ b/bench/irmin-pack/bench_common.ml @@ -60,20 +60,11 @@ let random_string n = String.init n (fun _i -> random_char ()) let random_blob () = random_string 10 |> Bytes.of_string let random_key () = random_string 5 -let default_artefacts_dir = - let ( / ) = Filename.concat in - Unix.getcwd () / "_artefacts" / Uuidm.to_string (Uuidm.v `V4) +let default_artefacts_dir cwd = + Eio.Path.(cwd / "_artefacts" / Uuidm.to_string (Uuidm.v `V4)) let prepare_artefacts_dir path = - let rec mkdir_p path = - if Sys.file_exists path then () - else - let path' = Filename.dirname path in - if path' = path then failwith "Failed to prepare result dir"; - mkdir_p path'; - Unix.mkdir path 0o755 - in - mkdir_p path + Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 path let with_timer f = let t0 = Sys.time () in @@ -121,27 +112,26 @@ end module FSHelper = struct let file f = - try (Unix.stat f).st_size with Unix.Unix_error (Unix.ENOENT, _, _) -> 0 + (* in MiB *) + try + Eio.Switch.run @@ fun sw -> + let f = Eio.Path.open_in ~sw f in + Optint.Int63.to_int (Eio.File.size f) + with Eio.Exn.Io (Eio.Fs.E (Not_found _), _) -> 0 let dict root = file (Irmin_pack.Layout.V1_and_v2.dict ~root) / 1024 / 1024 let pack root = file (Irmin_pack.Layout.V1_and_v2.pack ~root) / 1024 / 1024 let index root = - let index_dir = Filename.concat root "index" in - let a = file (Filename.concat index_dir "data") in - let b = file (Filename.concat index_dir "log") in - let c = file (Filename.concat index_dir "log_async") in + let index_dir = Eio.Path.(root / "index") in + let a = file Eio.Path.(index_dir / "data") in + let b = file Eio.Path.(index_dir / "log") in + let c = file Eio.Path.(index_dir / "log_async") in (a + b + c) / 1024 / 1024 let size root = dict root + pack root + index root let get_size root = size root - - let rm_dir root = - if Sys.file_exists root then ( - let cmd = Printf.sprintf "rm -rf %s" root in - [%logs.info "exec: %s" cmd]; - let _ = Sys.command cmd in - ()) + let rm_dir root = Eio.Path.rmtree ~missing_ok:true root end module Generate_trees diff --git a/bench/irmin-pack/bench_common.mli b/bench/irmin-pack/bench_common.mli index 57f247bbf3..8a77002dee 100644 --- a/bench/irmin-pack/bench_common.mli +++ b/bench/irmin-pack/bench_common.mli @@ -16,8 +16,8 @@ module Mtime : module type of Import.Mtime -val default_artefacts_dir : string -val prepare_artefacts_dir : string -> unit +val default_artefacts_dir : Eio.Fs.dir_ty Eio.Path.t -> Eio.Fs.dir_ty Eio.Path.t +val prepare_artefacts_dir : Eio.Fs.dir_ty Eio.Path.t -> unit val reporter : ?prefix:string -> unit -> Logs.reporter val setup_log : Fmt.style_renderer option -> Logs.level option -> unit val reset_stats : unit -> unit @@ -36,8 +36,8 @@ module Conf : Irmin_pack.Conf.S module Schema : Irmin.Schema.S module FSHelper : sig - val rm_dir : string -> unit - val get_size : string -> int + val rm_dir : Eio.Fs.dir_ty Eio.Path.t -> unit + val get_size : Eio.Fs.dir_ty Eio.Path.t -> int end module Generate_trees diff --git a/bench/irmin-pack/dune b/bench/irmin-pack/dune index 487bb2cbff..cdcd8ea36f 100644 --- a/bench/irmin-pack/dune +++ b/bench/irmin-pack/dune @@ -80,7 +80,7 @@ (executable (name trace_stats) (modules trace_stats) - (libraries cmdliner irmin_traces)) + (libraries cmdliner irmin_traces eio_main)) ;; Require the executables to compile during tests diff --git a/bench/irmin-pack/main.ml b/bench/irmin-pack/main.ml index 828480924f..0fe2ff6395 100644 --- a/bench/irmin-pack/main.ml +++ b/bench/irmin-pack/main.ml @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -let config ~root = Irmin_pack.config ~fresh:false root - module Config = struct let entries = 2 let stable_hash = 3 @@ -33,15 +31,19 @@ module Bench = Irmin_bench.Make (KV) let file f = (* in MiB *) - try (Unix.stat f).st_size / 1024 / 1024 - with Unix.Unix_error (Unix.ENOENT, _, _) -> 0 + try + Eio.Switch.run @@ fun sw -> + let open Optint.Int63 in + let f = Eio.Path.open_in ~sw f in + Infix.(to_int @@ (Eio.File.size f / of_int 1024 / of_int 1024)) + with Eio.Exn.Io (Eio.Fs.E (Not_found _), _) -> 0 let index root = let rec aux acc i = if i = 256 then acc else let filename = Format.sprintf "store.index.%d" i in - let s = file (Filename.concat root filename) in + let s = file Eio.Path.(root / filename) in aux (acc + s) (i + 1) in aux 0 0 @@ -52,4 +54,12 @@ let size ~root = |> List.map file |> List.fold_left ( + ) index_size -let () = Bench.run ~config ~size +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let fs = Eio.Stdenv.cwd env in + let config ~root = + Irmin_pack.config ~sw ~fs ~fresh:false Eio.Path.(fs / root) + in + let size ~root = size ~root:Eio.Path.(fs / root) in + Bench.run ~config ~size diff --git a/bench/irmin-pack/trace_collection.ml b/bench/irmin-pack/trace_collection.ml index fcd1bc6be5..b9b216a548 100644 --- a/bench/irmin-pack/trace_collection.ml +++ b/bench/irmin-pack/trace_collection.ml @@ -167,7 +167,7 @@ module Make_stat (Store : Irmin.Generic_key.KV) = struct } end - let create_file : string -> Def.config -> string -> t = + let create_file : Eio.Fs.dir_ty Eio.Path.t -> Def.config -> string -> t = fun path config store_path -> let header = Def. diff --git a/bench/irmin-pack/trace_common.ml b/bench/irmin-pack/trace_common.ml index ce2773d0cd..2aa888d732 100644 --- a/bench/irmin-pack/trace_common.ml +++ b/bench/irmin-pack/trace_common.ml @@ -228,8 +228,10 @@ module Io (Ff : File_format) = struct in Seq.unfold produce_row () - let open_reader : string -> Ff.Latest.header * Ff.Latest.row Seq.t = + let open_reader : + Eio.Fs.dir_ty Eio.Path.t -> Ff.Latest.header * Ff.Latest.row Seq.t = fun path -> + let path = Eio.Path.native_exn path in let chan = open_in_bin path in let len = LargeFile.in_channel_length chan in if len < 12L then @@ -260,6 +262,7 @@ module Io (Ff : File_format) = struct type writer = { path : string; channel : out_channel; buffer : Buffer.t } let create_file path header = + let path = Eio.Path.native_exn path in let channel = open_out path in let buffer = Buffer.create 0 in output_string channel (Magic.to_string Ff.magic); diff --git a/bench/irmin-pack/trace_replay.ml b/bench/irmin-pack/trace_replay.ml index 11eabd8c35..665a3712fc 100644 --- a/bench/irmin-pack/trace_replay.ml +++ b/bench/irmin-pack/trace_replay.ml @@ -370,8 +370,8 @@ module Make (Store : Store) = struct let really_add_volume = time_to_add_volume in (really_wait_gc, really_start_gc, really_split, really_add_volume) - let add_commits config repo commit_seq on_commit on_end stats check_hash - empty_blobs = + let add_commits ~fs ~domain_mgr config repo commit_seq on_commit on_end stats + check_hash empty_blobs = let max_ncommits = config.number_of_commits_to_replay in with_progress_bar ~message:"Replaying trace" ~n:max_ncommits ~unit:"commit" @@ fun prog -> @@ -444,7 +444,7 @@ module Make (Store : Store) = struct commit_duration duration finalise_duration] | Error s -> failwith s in - Store.gc_run ~finished repo gc_commit_key) + Store.gc_run ~fs ~domain_mgr ~finished repo gc_commit_key) in let () = add_operations t repo ops i stats check_hash empty_blobs in t.latest_commit_idx <- i; @@ -465,8 +465,14 @@ module Make (Store : Store) = struct in aux commit_seq 0 - let run : type a. _ -> a config -> a = - fun ext_config config -> + let run : + type a. + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + _ -> + a config -> + a = + fun ~fs ~domain_mgr ext_config config -> let check_hash = config.path_conversion = `None && config.inode_config = (32, 256) @@ -475,14 +481,15 @@ module Make (Store : Store) = struct [%logs.app "Will %scheck commit hashes against reference." (if check_hash then "" else "NOT ")]; + Eio.Switch.run @@ fun sw -> let commit_seq = open_commit_sequence config.number_of_commits_to_replay config.path_conversion config.replay_trace_path in - let root = Filename.concat config.artefacts_path "root" in - let repo, on_commit, on_end = Store.create_repo ~root ext_config in + let root = Eio.Path.(config.artefacts_path / "root") in + let repo, on_commit, on_end = Store.create_repo ~sw ~fs ~root ext_config in prepare_artefacts_dir config.artefacts_path; - let stat_path = Filename.concat config.artefacts_path "stat_trace.repr" in + let stat_path = Eio.Path.(config.artefacts_path / "stat_trace.repr") in let c = let entries, stable_hash = config.inode_config in Trace_definitions.Stat_trace. @@ -491,19 +498,21 @@ module Make (Store : Store) = struct `Replay { path_conversion = config.path_conversion; - artefacts_dir = config.artefacts_path; + artefacts_dir = Eio.Path.native_exn config.artefacts_path; }; inode_config = (entries, entries, stable_hash); store_type = config.store_type; } in - let stats = Stat_collector.create_file stat_path c root in + let stats = + Stat_collector.create_file stat_path c (Eio.Path.native_exn root) + in Irmin_pack.Stats.reset_stats (); Fun.protect (fun () -> let block_count = - add_commits config repo commit_seq on_commit on_end stats check_hash - config.empty_blobs + add_commits ~fs ~domain_mgr config repo commit_seq on_commit on_end + stats check_hash config.empty_blobs in [%logs.app "Closing repo..."]; let () = Store.Repo.close repo in @@ -515,7 +524,7 @@ module Make (Store : Store) = struct Trace_stat_summary.summarise ~block_count stat_path) ~finally:(fun () -> if config.keep_stat_trace then ( - [%logs.app "Stat trace kept at %s" stat_path]; - Unix.chmod stat_path 0o444) + [%logs.app "Stat trace kept at %s" (Eio.Path.native_exn stat_path)]; + Unix.chmod (Eio.Path.native_exn stat_path) 0o444) else Stat_collector.remove stats) end diff --git a/bench/irmin-pack/trace_replay_intf.ml b/bench/irmin-pack/trace_replay_intf.ml index 76ca74d211..f33a30f660 100644 --- a/bench/irmin-pack/trace_replay_intf.ml +++ b/bench/irmin-pack/trace_replay_intf.ml @@ -24,8 +24,8 @@ module Config = struct path_conversion : [ `None | `V1 | `V0_and_v1 | `V0 ]; inode_config : int * int; store_type : [ `Pack | `Pack_layered | `Pack_mem ]; - replay_trace_path : string; - artefacts_path : string; + replay_trace_path : Eio.Fs.dir_ty Eio.Path.t; + artefacts_path : Eio.Fs.dir_ty Eio.Path.t; keep_store : bool; keep_stat_trace : bool; empty_blobs : bool; @@ -99,7 +99,13 @@ module type Store = sig type on_commit := int -> Hash.t -> unit type on_end := unit -> unit - val create_repo : root:string -> store_config -> Repo.t * on_commit * on_end + val create_repo : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> + store_config -> + Repo.t * on_commit * on_end + val split : repo -> unit val add_volume : repo -> unit val gc_wait : repo -> unit @@ -107,7 +113,12 @@ module type Store = sig type stats := Irmin_pack_unix.Stats.Latest_gc.stats val gc_run : - ?finished:((stats, string) result -> unit) -> repo -> commit_key -> unit + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + ?finished:((stats, string) result -> unit) -> + repo -> + commit_key -> + unit end module type Sigs = sig @@ -124,6 +135,11 @@ module type Sigs = sig with type 'a return_type = 'a return_type and type 'a config = 'a config - val run : Store.store_config -> 'a config -> 'a + val run : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + Store.store_config -> + 'a config -> + 'a end end diff --git a/bench/irmin-pack/trace_stat_summary.ml b/bench/irmin-pack/trace_stat_summary.ml index 74ef2429b0..69824a2210 100644 --- a/bench/irmin-pack/trace_stat_summary.ml +++ b/bench/irmin-pack/trace_stat_summary.ml @@ -1098,6 +1098,7 @@ let summarise ?block_count trace_stat_path = (* Section 4/4 - Conversion from summary to json file *) let save_to_json v path = + let path = Eio.Path.native_exn path in let j = Fmt.str "%a\n" (Irmin.Type.pp_json t) v in let chan = open_out path in output_string chan j; diff --git a/bench/irmin-pack/trace_stats.ml b/bench/irmin-pack/trace_stats.ml index 6ad6d53598..9840a949f9 100644 --- a/bench/irmin-pack/trace_stats.ml +++ b/bench/irmin-pack/trace_stats.ml @@ -29,9 +29,10 @@ let summarise path = Summary.(summarise path |> Fmt.pr "%a\n" (Irmin.Type.pp_json t)) let class_of_path p = - let chan = open_in_bin p in + let path = Eio.Path.native_exn p in + let chan = open_in_bin path in if in_channel_length chan < 8 then - Fmt.invalid_arg "File \"%s\" should be a stat trace or a json." p; + Fmt.invalid_arg "File \"%s\" should be a stat trace or a json." path; let magic = really_input_string chan 8 in close_in chan; if is_trace_magic magic then @@ -44,13 +45,13 @@ let class_of_path p = in `Trace block_count else - let chan = open_in_bin p in + let chan = open_in_bin path in let raw = really_input_string chan (in_channel_length chan) in close_in chan; match Irmin.Type.of_json_string Summary.t raw with | Error (`Msg msg) -> Fmt.invalid_arg - "File \"%s\" should be a stat trace or a json.\nError: %s" p msg + "File \"%s\" should be a stat trace or a json.\nError: %s" path msg | Ok s -> `Summary s let pp name_per_path paths cols_opt = @@ -120,23 +121,41 @@ let summary_to_cb path = open Cmdliner -let term_summarise = +let eio_path fs = + let parse s = Ok Eio.Path.(fs / s) in + let print = Eio.Path.pp in + Arg.conv ~docv:"PATH" (parse, print) + +let term_summarise fs = let stat_trace_file = let doc = Arg.info ~docv:"PATH" ~doc:"A stat trace file" [] in - Arg.(required @@ pos 0 (some string) None doc) + Arg.(required @@ pos 0 (some (eio_path fs)) None doc) in Term.(const summarise $ stat_trace_file) -let term_pp = +let eio_file fs = + let parse s = + let path = Eio.Path.(fs / s) in + match Eio.Path.kind ~follow:true path with + | `Regular_file -> Ok path + | `Not_found -> Error (`Msg (Format.sprintf "no file %s" s)) + | _ -> Error (`Msg (Format.sprintf "%s is a directory" s)) + in + let print = Eio.Path.pp in + Arg.conv ~docv:"PATH" (parse, print) + +let term_pp fs = let arg_indexed_files = let open Arg in - let a = pos_all non_dir_file [] (info [] ~docv:"FILE") in + let a = pos_all (eio_file fs) [] (info [] ~docv:"FILE") in value a in let arg_named_files = let open Arg in let a = - opt_all (pair string non_dir_file) [] + opt_all + (pair string (eio_file fs)) + [] (info [ "f"; "named-file" ] ~doc: "A comma-separated pair of short name / path to trace or summary. \ @@ -208,6 +227,9 @@ let () = let l = deprecated_info ~man ~doc:"Summary JSON to Continous Benchmarks JSON" "cb" in + Eio_main.run @@ fun env -> + let fs = Eio.Stdenv.fs env in deprecated_exit - @@ deprecated_eval_choice (term_summarise, i) - [ (term_summarise, j); (term_pp, k); (term_cb, l) ] + @@ deprecated_eval_choice + (term_summarise fs, i) + [ (term_summarise fs, j); (term_pp fs, k); (term_cb, l) ] diff --git a/bench/irmin-pack/tree.ml b/bench/irmin-pack/tree.ml index dda91d9496..fc02622e22 100644 --- a/bench/irmin-pack/tree.ml +++ b/bench/irmin-pack/tree.ml @@ -25,12 +25,12 @@ type config = { nchain_trees : int; width : int; nlarge_trees : int; - store_dir : string; + store_dir : Eio.Fs.dir_ty Eio.Path.t; path_conversion : [ `None | `V1 | `V0_and_v1 | `V0 ]; inode_config : int * int; store_type : [ `Pack | `Pack_mem ]; - replay_trace_path : string; - artefacts_path : string; + replay_trace_path : Eio.Fs.dir_ty Eio.Path.t; + artefacts_path : Eio.Fs.dir_ty Eio.Path.t; keep_store : bool; keep_stat_trace : bool; no_summary : bool; @@ -55,7 +55,12 @@ module type Store = sig type on_commit := int -> Hash.t -> unit type on_end := unit -> unit - val create_repo : root:string -> store_config -> Repo.t * on_commit * on_end + val create_repo : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> + store_config -> + Repo.t * on_commit * on_end type stats := Irmin_pack_unix.Stats.Latest_gc.stats @@ -63,7 +68,12 @@ module type Store = sig val add_volume : repo -> unit val gc_run : - ?finished:((stats, string) result -> unit) -> repo -> commit_key -> unit + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + ?finished:((stats, string) result -> unit) -> + repo -> + commit_key -> + unit val gc_wait : repo -> unit end @@ -121,10 +131,11 @@ module Bench_suite (Store : Store) = struct in aux None 0 - let run_large config = + let run_large ~fs config = reset_stats (); + Eio.Switch.run @@ fun sw -> let root = config.store_dir in - let repo, on_commit, on_end = Store.create_repo ~root config in + let repo, on_commit, on_end = Store.create_repo ~sw ~fs ~root config in let result, () = Trees.add_large_trees config.width config.nlarge_trees |> add_commits ~message:"Playing large mode" repo config.ncommits @@ -141,10 +152,11 @@ module Bench_suite (Store : Store) = struct config.ncommits config.nlarge_trees config.width Benchmark.pp_results result - let run_chains config = + let run_chains ~fs config = reset_stats (); + Eio.Switch.run @@ fun sw -> let root = config.store_dir in - let repo, on_commit, on_end = Store.create_repo ~root config in + let repo, on_commit, on_end = Store.create_repo ~sw ~fs ~root config in let result, () = Trees.add_chain_trees config.depth config.nchain_trees |> add_commits ~message:"Playing chain mode" repo config.ncommits @@ -161,7 +173,7 @@ module Bench_suite (Store : Store) = struct config.ncommits config.nchain_trees config.depth Benchmark.pp_results result - let run_read_trace config = + let run_read_trace ~fs ~domain_mgr config = let replay_config : _ Irmin_traces.Trace_replay.config = { number_of_commits_to_replay = config.number_of_commits_to_replay; @@ -183,14 +195,15 @@ module Bench_suite (Store : Store) = struct in if config.no_summary then let () = - Trace_replay.run config { replay_config with return_type = Unit } + Trace_replay.run ~fs ~domain_mgr config + { replay_config with return_type = Unit } in fun _ppf -> () else - let summary = Trace_replay.run config replay_config in + let summary = Trace_replay.run ~fs ~domain_mgr config replay_config in fun ppf -> if not config.no_summary then ( - let p = Filename.concat config.artefacts_path "stat_summary.json" in + let p = Eio.Path.(config.artefacts_path / "stat_summary.json") in Trace_stat_summary.save_to_json summary p; Format.fprintf ppf "%a" (Trace_stat_summary_pp.pp 5) @@ -211,9 +224,10 @@ module Make_store_mem (Conf : Irmin_pack.Conf.S) = struct let indexing_strategy = Irmin_pack.Indexing_strategy.minimal - let create_repo ~root _config = + let create_repo ~sw ~fs ~root _config = let conf = - Irmin_pack.config ~readonly:false ~fresh:true ~indexing_strategy root + Irmin_pack.config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy + root in prepare_artefacts_dir root; let repo = Store.Repo.v conf in @@ -224,7 +238,7 @@ module Make_store_mem (Conf : Irmin_pack.Conf.S) = struct let split _repo = () let add_volume _repo = () let gc_wait _repo = () - let gc_run ?finished:_ _repo _key = () + let gc_run ~fs:_ ~domain_mgr:_ ?finished:_ _repo _key = () end module Make_store_pack (Conf : Irmin_pack.Conf.S) = struct @@ -241,13 +255,13 @@ module Make_store_pack (Conf : Irmin_pack.Conf.S) = struct let indexing_strategy = Irmin_pack.Indexing_strategy.minimal - let create_repo ~root (config : store_config) = + let create_repo ~sw ~fs ~root (config : store_config) = let lower_root = - if config.add_volume_every > 0 then Some (Filename.concat root "lower") + if config.add_volume_every > 0 then Some Eio.Path.(root / "lower") else None in let conf = - Irmin_pack.config ~readonly:false ~fresh:true ~indexing_strategy + Irmin_pack.config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy ~lower_root root in prepare_artefacts_dir root; @@ -263,13 +277,13 @@ module Make_store_pack (Conf : Irmin_pack.Conf.S) = struct let r = Store.Gc.wait repo in match r with Ok _ -> () | Error (`Msg err) -> failwith err - let gc_run ?(finished = fun _ -> ()) repo key = + let gc_run ~fs ~domain_mgr ?(finished = fun _ -> ()) repo key = let f (result : (_, Store.Gc.msg) result) = match result with | Error (`Msg err) -> finished @@ Error err | Ok stats -> finished @@ Ok stats in - let launched = Store.Gc.run ~finished:f repo key in + let launched = Store.Gc.run ~fs ~domain_mgr ~finished:f repo key in match launched with | Ok true -> () | Ok false -> [%logs.app "GC skipped"] @@ -277,9 +291,18 @@ module Make_store_pack (Conf : Irmin_pack.Conf.S) = struct end module type B = sig - val run_large : config -> Format.formatter -> unit - val run_chains : config -> Format.formatter -> unit - val run_read_trace : config -> Format.formatter -> unit + val run_large : + fs:Eio.Fs.dir_ty Eio.Path.t -> config -> Format.formatter -> unit + + val run_chains : + fs:Eio.Fs.dir_ty Eio.Path.t -> config -> Format.formatter -> unit + + val run_read_trace : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + config -> + Format.formatter -> + unit end let store_of_config config = @@ -300,7 +323,7 @@ type suite_elt = { run : config -> Format.formatter -> unit; } -let suite : suite_elt list = +let suite ~fs ~domain_mgr : suite_elt list = List.rev [ { @@ -312,7 +335,7 @@ let suite : suite_elt list = { config with inode_config = (32, 256); store_type = `Pack } in let (module Store) = store_of_config config in - Store.run_read_trace config); + Store.run_read_trace ~fs ~domain_mgr config); }; { mode = `Read_trace; @@ -323,7 +346,7 @@ let suite : suite_elt list = { config with inode_config = (32, 256); store_type = `Pack } in let (module Store) = store_of_config config in - Store.run_read_trace config); + Store.run_read_trace ~fs ~domain_mgr config); }; { mode = `Chains; @@ -334,7 +357,7 @@ let suite : suite_elt list = { config with inode_config = (32, 256); store_type = `Pack } in let (module Store) = store_of_config config in - Store.run_chains config); + Store.run_chains ~fs config); }; { mode = `Chains; @@ -345,7 +368,7 @@ let suite : suite_elt list = { config with inode_config = (2, 5); store_type = `Pack } in let (module Store) = store_of_config config in - Store.run_chains config); + Store.run_chains ~fs config); }; { mode = `Large; @@ -356,7 +379,7 @@ let suite : suite_elt list = { config with inode_config = (32, 256); store_type = `Pack } in let (module Store) = store_of_config config in - Store.run_large config); + Store.run_large ~fs config); }; { mode = `Large; @@ -367,7 +390,7 @@ let suite : suite_elt list = { config with inode_config = (2, 5); store_type = `Pack } in let (module Store) = store_of_config config in - Store.run_large config); + Store.run_large ~fs config); }; { mode = `Read_trace; @@ -375,11 +398,11 @@ let suite : suite_elt list = run = (fun config -> let (module Store) = store_of_config config in - Store.run_read_trace config); + Store.run_read_trace ~fs ~domain_mgr config); }; ] -let get_suite suite_filter = +let get_suite ~fs ~domain_mgr suite_filter = List.filter (fun { mode; speed; _ } -> match (suite_filter, speed, mode) with @@ -396,9 +419,9 @@ let get_suite suite_filter = | (`Slow | `Quick | `Custom_trace | `Custom_chains | `Custom_large), _, _ -> false) - suite + (suite ~fs ~domain_mgr) -let main () ncommits number_of_commits_to_replay suite_filter inode_config +let main ~fs () ncommits number_of_commits_to_replay suite_filter inode_config store_type _freeze_commit path_conversion depth width nchain_trees nlarge_trees replay_trace_path artefacts_path keep_store keep_stat_trace no_summary empty_blobs gc_every gc_distance_in_the_past gc_wait_after @@ -411,7 +434,7 @@ let main () ncommits number_of_commits_to_replay suite_filter inode_config { ncommits; number_of_commits_to_replay; - store_dir = Filename.concat artefacts_path "store"; + store_dir = Eio.Path.(artefacts_path / "store"); path_conversion; depth; width; @@ -437,21 +460,21 @@ let main () ncommits number_of_commits_to_replay suite_filter inode_config results. *) Gc.set { (Gc.get ()) with Gc.allocation_policy = 0 }; FSHelper.rm_dir config.store_dir; - let suite = get_suite suite_filter in + Eio_main.run @@ fun env -> + let domain_mgr = Eio.Stdenv.domain_mgr env in + let suite = get_suite ~fs ~domain_mgr suite_filter in let run_benchmarks () = List.map (fun b -> b.run config) suite in let results = - Eio_main.run @@ fun _env -> Fun.protect run_benchmarks ~finally:(fun () -> if keep_store then ( - [%logs.app "Store kept at %s" config.store_dir]; - let ( / ) = Filename.concat in + [%logs.app "Store kept at %s" (Eio.Path.native_exn config.store_dir)]; let ro p = if Sys.file_exists p then Unix.chmod p 0o444 in - ro (config.store_dir / "store.branches"); - ro (config.store_dir / "store.dict"); - ro (config.store_dir / "store.pack"); - ro (config.store_dir / "index" / "data"); - ro (config.store_dir / "index" / "log"); - ro (config.store_dir / "index" / "log_async")) + ro Eio.Path.(native_exn @@ (config.store_dir / "store.branches")); + ro Eio.Path.(native_exn @@ (config.store_dir / "store.dict")); + ro Eio.Path.(native_exn @@ (config.store_dir / "store.pack")); + ro Eio.Path.(native_exn @@ (config.store_dir / "index" / "data")); + ro Eio.Path.(native_exn @@ (config.store_dir / "index" / "log")); + ro Eio.Path.(native_exn @@ (config.store_dir / "index" / "log_async"))) else FSHelper.rm_dir config.store_dir) in [%logs.app "%a@." Fmt.(list ~sep:(any "@\n@\n") (fun ppf f -> f ppf)) results] @@ -571,18 +594,23 @@ let nlarge_trees = in Arg.(value @@ opt int 1 doc) -let replay_trace_path = +let eio_path fs = + let parse s = Ok Eio.Path.(fs / s) in + let print = Eio.Path.pp in + Arg.conv ~docv:"PATH" (parse, print) + +let replay_trace_path fs = let doc = Arg.info ~docv:"PATH" ~doc:"Trace of Tezos operations to be replayed." [] in - Arg.(required @@ pos 0 (some string) None doc) + Arg.(required @@ pos 0 (some (eio_path fs)) None doc) -let artefacts_path = +let artefacts_path fs cwd = let doc = Arg.info ~docv:"PATH" ~doc:"Destination of the bench artefacts." [ "artefacts" ] in - Arg.(value @@ opt string default_artefacts_dir doc) + Arg.(value @@ opt (eio_path fs) (default_artefacts_dir cwd) doc) let setup_log = Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) @@ -612,9 +640,9 @@ let add_volume_every = let doc = Arg.info ~doc:"Add volume ever N GCs" [ "add-volume-every" ] in Arg.(value @@ opt int 0 doc) -let main_term = +let main_term fs cwd = Term.( - const main + const (main ~fs) $ setup_log $ ncommits $ number_of_commits_to_replay @@ -627,8 +655,8 @@ let main_term = $ width $ nchain_trees $ nlarge_trees - $ replay_trace_path - $ artefacts_path + $ replay_trace_path fs + $ artefacts_path fs cwd $ keep_store $ keep_stat_trace $ no_summary @@ -663,4 +691,7 @@ let () = let info = deprecated_info ~man ~doc:"Benchmarks for tree operations" "tree" in - deprecated_exit @@ deprecated_eval (main_term, info) + Eio_main.run @@ fun env -> + let fs = Eio.Stdenv.fs env in + let cwd = Eio.Stdenv.cwd env in + deprecated_exit @@ deprecated_eval (main_term fs cwd, info) diff --git a/examples/irmin-pack/gc.ml b/examples/irmin-pack/gc.ml index 0e92f851ef..a5c2a9a167 100644 --- a/examples/irmin-pack/gc.ml +++ b/examples/irmin-pack/gc.ml @@ -61,7 +61,7 @@ module Repo_config = struct (** Location on disk to save the repository Note: irmin-pack will not create the entire path, only the final directory *) - let root = "./irmin-pack-example" + let root fs = Eio.Path.(fs / "./irmin-pack-example") (** See {!Irmin_pack.Conf} for more keys that can be used when initialising the repository config *) @@ -71,19 +71,19 @@ module Repo_config = struct let fresh = true (** Create config for our repository *) - let config = - Irmin_pack.config ~fresh ~index_log_size ~merge_throttle ~indexing_strategy - root + let config ~sw fs = + Irmin_pack.config ~sw ~fs ~fresh ~index_log_size ~merge_throttle + ~indexing_strategy (root fs) (** We can add an optional lower layer to our repository. Data discarded by the GC will be stored there and still be accessible instead of being deleted. *) - let lower_root = Some "./irmin-pack-example-lower" + let lower_root fs = Some Eio.Path.(fs / "./irmin-pack-example-lower") (** Create a copy of the previous configuration, now with a lower layer *) - let config_with_lower = - Irmin_pack.config ~fresh ~index_log_size ~merge_throttle ~indexing_strategy - ~lower_root root + let config_with_lower ~sw fs = + Irmin_pack.config ~sw ~fs ~fresh ~index_log_size ~merge_throttle + ~indexing_strategy ~lower_root:(lower_root fs) (root fs) end (** Utility for creating commit info *) @@ -121,7 +121,7 @@ end (** Demonstrate running GC on a previous commit aligned to the end of a chunk for ideal GC space reclamation. *) -let run_gc config repo tracker = +let run_gc fs domain_mgr config repo tracker = let () = match Tracker.(tracker.next_gc_commit) with | None -> () @@ -148,7 +148,7 @@ let run_gc config repo tracker = in (* Launch GC *) let commit_key = Store.Commit.key commit in - let launched = Store.Gc.run ~finished repo commit_key in + let launched = Store.Gc.run ~fs ~domain_mgr ~finished repo commit_key in match launched with | Ok false -> () | Ok true -> @@ -160,7 +160,9 @@ let run_gc config repo tracker = let () = Store.split repo in Tracker.mark_next_gc_commit tracker -let run_experiment config = +let run_experiment env config = + let fs = Eio.Stdenv.fs env in + let domain_mgr = Eio.Stdenv.domain_mgr env in let num_of_commits = 200_000 in let gc_every = 1_000 in let repo = Store.Repo.v config in @@ -176,7 +178,9 @@ let run_experiment config = Store.Commit.v repo ~info:(info "add %s = %s" key value) ~parents tree in Tracker.update_latest_commit tracker commit; - let _ = if i mod gc_every = 0 then run_gc config repo tracker in + let _ = + if i mod gc_every = 0 then run_gc fs domain_mgr config repo tracker + in if i >= n then () else loop (i + 1) n in loop 1 num_of_commits @@ -186,8 +190,10 @@ let run_experiment config = () let () = - Eio_main.run @@ fun _env -> + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let fs = Eio.Stdenv.fs env in Printf.printf "== RUN 1: deleting discarded data ==\n"; - run_experiment Repo_config.config; + run_experiment env (Repo_config.config ~sw fs); Printf.printf "== RUN 2: archiving discarded data ==\n"; - run_experiment Repo_config.config_with_lower + run_experiment env (Repo_config.config_with_lower ~sw fs) diff --git a/examples/irmin-pack/kv.ml b/examples/irmin-pack/kv.ml index ebf481c4f7..9bec787337 100644 --- a/examples/irmin-pack/kv.ml +++ b/examples/irmin-pack/kv.ml @@ -50,7 +50,7 @@ module Repo_config = struct (** Location on disk to save the repository Note: irmin-pack will not create the entire path, only the final directory *) - let root = "./irmin-pack-example" + let root fs = Eio.Path.(fs / "./irmin-pack-example") (** See {!Irmin_pack.Conf} for more keys that can be used when initialising the repository config *) @@ -60,17 +60,20 @@ module Repo_config = struct let fresh = true (** Create config for our repository *) - let config = + let config fs = Irmin_pack.config ~fresh ~index_log_size ~merge_throttle ~indexing_strategy - root + (root fs) end module StoreMaker = Irmin_pack_unix.KV (Conf) module Store = StoreMaker.Make (Irmin.Contents.String) -let main () = +let main env = + (* Create a switch *) + Eio.Switch.run @@ fun sw -> + let fs = Eio.Stdenv.fs env in (* Instantiate a repository *) - let repo = Store.Repo.v Repo_config.config in + let repo = Store.Repo.v (Repo_config.config ~sw ~fs fs) in (* Get the store from the main branch. *) let store = Store.main repo in @@ -93,6 +96,6 @@ let setup_logs () = Logs.(set_level @@ Some Debug) let () = - Eio_main.run @@ fun _env -> + Eio_main.run @@ fun env -> setup_logs (); - main () + main env diff --git a/src/irmin-cli/cli.ml b/src/irmin-cli/cli.ml index 5cbc121ff3..d6a2205d69 100644 --- a/src/irmin-cli/cli.ml +++ b/src/irmin-cli/cli.ml @@ -978,7 +978,14 @@ let run ~default:x y = Eio_main.run @@ fun env -> Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook; - let env = (env :> eio) in + Eio.Switch.run @@ fun sw -> + let env = + object + method cwd = Eio.Stdenv.cwd env + method clock = Eio.Stdenv.clock env + method sw = sw + end + in let run cmd = cmd ~env in match deprecated_eval_choice (run x) (List.map run y) with | `Error _ -> exit 1 diff --git a/src/irmin-cli/import.ml b/src/irmin-cli/import.ml index bb36eaba59..cfd000bf23 100644 --- a/src/irmin-cli/import.ml +++ b/src/irmin-cli/import.ml @@ -18,4 +18,5 @@ include Irmin.Export_for_backends type eio = < cwd : Eio.Fs.dir_ty Eio.Path.t - ; clock : float Eio.Time.clock_ty Eio.Time.clock > + ; clock : float Eio.Time.clock_ty Eio.Time.clock + ; sw : Eio.Switch.t > diff --git a/src/irmin-cli/resolver.ml b/src/irmin-cli/resolver.ml index 5c9dea5ced..f2209193e8 100644 --- a/src/irmin-cli/resolver.ml +++ b/src/irmin-cli/resolver.ml @@ -320,15 +320,20 @@ module Store = struct end) end - let pack : hash -> contents -> t = - fun (module H) (module C) -> + let pack : eio -> hash -> contents -> t = + fun env (module H) (module C) -> let module Schema = struct include Irmin.Schema.KV (C) module Hash = H end in - v_generic Irmin_pack.Conf.spec (module Irmin_pack_maker.Make (Schema)) + v_generic + (Irmin_pack.Conf.spec ~sw:env#sw ~fs:env#cwd) + (module Irmin_pack_maker.Make (Schema)) - let tezos = v_generic Irmin_pack.Conf.spec (module Irmin_tezos.Store) + let tezos env = + v_generic + (Irmin_pack.Conf.spec ~sw:env#sw ~fs:env#cwd) + (module Irmin_tezos.Store) let all = ref @@ -337,8 +342,8 @@ module Store = struct ("git-mem", fun _ -> Fixed_hash git_mem); ("fs", fun env -> Variable_hash (fs env)); ("mem", fun _ -> Variable_hash mem); - ("pack", fun _ -> Variable_hash pack); - ("tezos", fun _ -> Fixed tezos); + ("pack", fun env -> Variable_hash (pack env)); + ("tezos", fun env -> Fixed (tezos env)); ] let default = "git" |> fun n -> ref (n, List.assoc n !all) @@ -673,7 +678,8 @@ let infer_remote ~env hash contents branch headers str = if Sys.file_exists str then let r = if Sys.file_exists (str / ".git") then Store.git contents - else if Sys.file_exists (str / "store.dict") then Store.pack hash contents + else if Sys.file_exists (str / "store.dict") then + Store.pack env hash contents else Store.fs env hash contents in match r with diff --git a/src/irmin-cli/resolver.mli b/src/irmin-cli/resolver.mli index fc90d466f2..6310e19c2e 100644 --- a/src/irmin-cli/resolver.mli +++ b/src/irmin-cli/resolver.mli @@ -90,7 +90,7 @@ module Store : sig val mem : hash -> contents -> t val fs : eio -> hash -> contents -> t val git : contents -> t - val pack : hash -> contents -> t + val pack : eio -> hash -> contents -> t val find : string -> eio -> store_functor val add : string -> ?default:bool -> store_functor -> unit val spec : t -> Irmin.Backend.Conf.Spec.t diff --git a/src/irmin-client/unix/bin/client.ml b/src/irmin-client/unix/bin/client.ml index 63bd18f250..15185d18e7 100644 --- a/src/irmin-client/unix/bin/client.ml +++ b/src/irmin-client/unix/bin/client.ml @@ -299,6 +299,14 @@ let help = let[@alert "-deprecated"] () = Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let env = + object + method cwd = Eio.Stdenv.cwd env + method clock = Eio.Stdenv.clock env + method sw = sw + end + in let config = config ~env:(env :> Irmin_cli.eio) in Term.exit @@ Term.eval_choice help diff --git a/src/irmin-pack-tools/ppcf/dune b/src/irmin-pack-tools/ppcf/dune index 2700e07eb6..1af20aa8dd 100644 --- a/src/irmin-pack-tools/ppcf/dune +++ b/src/irmin-pack-tools/ppcf/dune @@ -3,6 +3,6 @@ (package irmin-pack-tools) (name ppcf) (modules ppcf) - (libraries irmin-pack irmin-pack.unix cmdliner) + (libraries irmin-pack irmin-pack.unix cmdliner eio_main) (preprocess (pps ppx_repr))) diff --git a/src/irmin-pack-tools/ppcf/ppcf.ml b/src/irmin-pack-tools/ppcf/ppcf.ml index e59ec852ed..49e3cc01e9 100644 --- a/src/irmin-pack-tools/ppcf/ppcf.ml +++ b/src/irmin-pack-tools/ppcf/ppcf.ml @@ -5,8 +5,8 @@ module Volume_control = Irmin_pack_unix.Control_file.Volume (Io) type store_type = Upper | Volume -let print_cf read print control_file = - let r = read ~path:control_file in +let print_cf ~sw ~fs read print control_file = + let r = read ~sw ~path:Eio.Path.(fs / control_file) in match r with | Error err -> Io_errors.raise_error err | Ok payload -> Fmt.pr "%a\n" (Irmin.Type.pp_json print) payload @@ -36,9 +36,13 @@ let control_file = & pos 1 (some string) None & info [] ~docv:"control file" ~doc:"the path to the control file") -let main_cmd = +let main_cmd ~sw ~fs = let doc = "a json printer for irmin pack control files" in let info = Cmd.info "irmin-ppcf" ~doc in - Cmd.v info Term.(const main $ store_type $ control_file) + Cmd.v info Term.(const (main ~sw ~fs) $ store_type $ control_file) -let () = exit (Cmd.eval ~catch:false main_cmd) +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let fs = Eio.Stdenv.fs env in + exit (Cmd.eval ~catch:false (main_cmd ~sw ~fs)) diff --git a/src/irmin-pack-tools/tezos_explorer/dune b/src/irmin-pack-tools/tezos_explorer/dune index ad79cf77ae..b556f89bc3 100644 --- a/src/irmin-pack-tools/tezos_explorer/dune +++ b/src/irmin-pack-tools/tezos_explorer/dune @@ -12,6 +12,7 @@ index.unix hex ptime - cmdliner) + cmdliner + eio_main) (preprocess (pps ppx_repr))) diff --git a/src/irmin-pack-tools/tezos_explorer/main.ml b/src/irmin-pack-tools/tezos_explorer/main.ml index 433c14e50a..8ab360e5f0 100644 --- a/src/irmin-pack-tools/tezos_explorer/main.ml +++ b/src/irmin-pack-tools/tezos_explorer/main.ml @@ -34,36 +34,40 @@ let index_path = ~doc:"the path to the index file generated, default to `store.index`") (* Command parse *) -let parse_cmd = +let parse_cmd ~sw ~fs = let doc = "parses a pack file and generates the associated .info & .idx files" in let info = Cmd.info "parse" ~doc in Cmd.v info Term.( - const Parse.main + const (Parse.main ~sw ~fs) $ store_path $ info_last_path $ info_next_path $ index_path) (* Command show *) -let show_cmd = +let show_cmd ~sw ~fs = let doc = "graphical user interface for pack files inspection" in let info = Cmd.info "show" ~doc in Cmd.v info Term.( - const Show.main + const (Show.main ~sw ~fs) $ store_path $ info_last_path $ info_next_path $ index_path) (* Main command *) -let main_cmd = +let main_cmd ~sw ~fs = let doc = "a visual tool for irmin pack files inspection" in let info = Cmd.info "irmin-pack-inspect" ~version:"%%VERSION%%" ~doc in let default = Term.(ret (const (`Help (`Pager, None)))) in - Cmd.group info ~default [ parse_cmd; show_cmd ] + Cmd.group info ~default [ parse_cmd ~sw ~fs; show_cmd ~sw ~fs ] -let () = exit (Cmd.eval ~catch:false main_cmd) +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let fs = Eio.Stdenv.fs env in + exit (Cmd.eval ~catch:false (main_cmd ~sw ~fs)) diff --git a/src/irmin-pack-tools/tezos_explorer/parse.ml b/src/irmin-pack-tools/tezos_explorer/parse.ml index f3e2d6b66f..a934044819 100644 --- a/src/irmin-pack-tools/tezos_explorer/parse.ml +++ b/src/irmin-pack-tools/tezos_explorer/parse.ml @@ -68,9 +68,9 @@ let dump_idxs fd n is is2 = let get_values r = List.filter_map (Ring.get r) [ 1; 10; 1000 ] -let main store_path info_last_path info_next_path idx_path = - let conf = Irmin_pack.Conf.init store_path in - match Files.File_manager.open_ro conf with +let main ~sw ~fs store_path info_last_path info_next_path idx_path = + let conf = Irmin_pack.Conf.init ~sw ~fs Eio.Path.(fs / store_path) in + match Files.File_manager.open_ro ~sw ~fs conf with | Error exn -> Fmt.pr "%a\n%!" (Irmin.Type.pp Files.Errs.t) exn | Ok fm -> let info_fd = @@ -136,6 +136,3 @@ let main store_path info_last_path info_next_path idx_path = in dump_idxs idx_fd entries (List.rev !idxs) !idxs2; Unix.close idx_fd - -let main store_path info_last_path info_next_path index_path = - main store_path info_last_path info_next_path index_path diff --git a/src/irmin-pack-tools/tezos_explorer/show.ml b/src/irmin-pack-tools/tezos_explorer/show.ml index d5e5c6cc40..26b6e28ddf 100644 --- a/src/irmin-pack-tools/tezos_explorer/show.ml +++ b/src/irmin-pack-tools/tezos_explorer/show.ml @@ -854,9 +854,11 @@ let rec loop t c = loop t c | _ -> loop t c -let main store_path info_last_path info_next_path index_path = - let conf = Irmin_pack.Conf.init store_path in - let fm = Files.File_manager.open_ro conf |> Files.Errs.raise_if_error in +let main ~sw ~fs store_path info_last_path info_next_path index_path = + let conf = Irmin_pack.Conf.init ~sw ~fs Eio.Path.(fs / store_path) in + let fm = + Files.File_manager.open_ro ~sw ~fs conf |> Files.Errs.raise_if_error + in let dispatcher = Files.Dispatcher.v fm |> Files.Errs.raise_if_error in let max_offset = Files.Dispatcher.end_offset dispatcher in let dict = Files.File_manager.dict fm in diff --git a/src/irmin-pack/atomic_write_intf.ml b/src/irmin-pack/atomic_write_intf.ml index bf9ca4db11..0e90f20142 100644 --- a/src/irmin-pack/atomic_write_intf.ml +++ b/src/irmin-pack/atomic_write_intf.ml @@ -23,7 +23,12 @@ end module type Persistent = sig include S - val v : ?fresh:bool -> ?readonly:bool -> string -> t + val v : + sw:Eio.Switch.t -> + ?fresh:bool -> + ?readonly:bool -> + Eio.Fs.dir_ty Eio.Path.t -> + t end module type Value = sig diff --git a/src/irmin-pack/conf.ml b/src/irmin-pack/conf.ml index b0cc16b9d2..9cc816a87a 100644 --- a/src/irmin-pack/conf.ml +++ b/src/irmin-pack/conf.ml @@ -42,6 +42,10 @@ end open Irmin.Backend.Conf +type fs = Eio.Fs.dir_ty Eio.Path.t + +let sw_typ : Eio.Switch.t Typ.t = Typ.create () +let fs_typ : fs Typ.t = Typ.create () let spec = Spec.v "pack" type merge_throttle = [ `Block_writes | `Overcommit_memory ] [@@deriving irmin] @@ -121,15 +125,46 @@ let lower_root config = get config Key.lower_root let indexing_strategy config = get config Key.indexing_strategy let use_fsync config = get config Key.use_fsync let no_migrate config = get config Key.no_migrate - -let init ?(fresh = Default.fresh) ?(readonly = Default.readonly) +let switch config = find_key config "sw" sw_typ +let fs config = find_key config "fs" fs_typ + +let spec ~sw ~fs = + let spec = Spec.copy spec in + let _sw_key = + let to_string _ = "Eio.Switch.t" in + let of_string _ = Ok sw in + let of_json_string _ = Ok sw in + key' ~typ:sw_typ ~spec ~typename:"Eio.Switch.t" ~to_string ~of_string + ~of_json_string "sw" sw + in + let fs = (fs :> fs) in + let _fs_key = + let to_string fs = Eio.Path.native_exn fs in + let of_string str = Ok Eio.Path.(fs / str) in + let of_json_string str = + match Irmin.Type.(of_json_string string) str with + | Ok str -> Ok Eio.Path.(fs / str) + | Error e -> Error e + in + key' ~typ:fs_typ ~spec ~typename:"_ Eio.Path.t" ~to_string ~of_string + ~of_json_string "fs" fs + in + spec + +let init ~sw ~fs ?(fresh = Default.fresh) ?(readonly = Default.readonly) ?(lru_size = Default.lru_size) ?(lru_max_memory = Default.lru_max_memory) ?(index_log_size = Default.index_log_size) ?(merge_throttle = Default.merge_throttle) ?(indexing_strategy = Default.indexing_strategy) ?(use_fsync = Default.use_fsync) ?(no_migrate = Default.no_migrate) - ?(lower_root = Default.lower_root) root = - let config = empty spec in + ?(lower_root = None) root = + let root = Eio.Path.native_exn root in + let lower_root = + match lower_root with + | None -> Default.lower_root + | Some lower_root -> Some (Eio.Path.native_exn lower_root) + in + let config = empty (spec ~sw ~fs) in let config = add config Key.root root in let config = add config Key.lower_root lower_root in let config = add config Key.fresh fresh in diff --git a/src/irmin-pack/conf.mli b/src/irmin-pack/conf.mli index 4386fa3a2a..553fe9dd98 100644 --- a/src/irmin-pack/conf.mli +++ b/src/irmin-pack/conf.mli @@ -58,7 +58,7 @@ module type S = sig See https://github.com/mirage/irmin/issues/1304 *) end -val spec : Irmin.Backend.Conf.Spec.t +val spec : sw:Eio.Switch.t -> fs:_ Eio.Path.t -> Irmin.Backend.Conf.Spec.t type merge_throttle = [ `Block_writes | `Overcommit_memory ] [@@deriving irmin] (** Strategy for when attempting to write when the index log is full and waiting @@ -128,7 +128,15 @@ val use_fsync : Irmin.Backend.Conf.t -> bool val no_migrate : Irmin.Backend.Conf.t -> bool (** Flag to prevent migration of data. Default [false]. *) +val switch : Irmin.Backend.Conf.t -> Eio.Switch.t +(** Eio switch *) + +val fs : Irmin.Backend.Conf.t -> Eio.Fs.dir_ty Eio.Path.t +(** Eio filesystem *) + val init : + sw:Eio.Switch.t -> + fs:_ Eio.Path.t -> ?fresh:bool -> ?readonly:bool -> ?lru_size:int -> @@ -138,8 +146,8 @@ val init : ?indexing_strategy:Indexing_strategy.t -> ?use_fsync:bool -> ?no_migrate:bool -> - ?lower_root:string option -> - string -> + ?lower_root:Eio.Fs.dir_ty Eio.Path.t option -> + Eio.Fs.dir_ty Eio.Path.t -> Irmin.config (** [init root] creates a backend configuration for storing data with default configuration parameters and stored at [root]. Flags are documented above. *) diff --git a/src/irmin-pack/io/append_only_file.ml b/src/irmin-pack/io/append_only_file.ml index f8221f8207..decd713ef4 100644 --- a/src/irmin-pack/io/append_only_file.ml +++ b/src/irmin-pack/io/append_only_file.ml @@ -45,9 +45,9 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct buf_length = Atomic.make 0; } - let create_rw ~path ~overwrite = + let create_rw ~sw ~path ~overwrite = let open Result_syntax in - let+ io = Io.create ~path ~overwrite in + let+ io = Io.create ~sw ~path ~overwrite in let persisted_end_poff = Atomic.make Int63.zero in { io; @@ -78,21 +78,22 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct if real_offset_without_header > end_poff then [%log.warn "The end offset in the control file %a is smaller than the offset on \ - disk %a for %s; the store was closed in a inconsistent state." - Int63.pp end_poff Int63.pp real_offset_without_header (Io.path io)]; + disk %a for %a; the store was closed in a inconsistent state." + Int63.pp end_poff Int63.pp real_offset_without_header Eio.Path.pp + (Io.path io)]; Ok ()) - let open_rw ~path ~end_poff ~dead_header_size = + let open_rw ~sw ~path ~end_poff ~dead_header_size = let open Result_syntax in - let* io = Io.open_ ~path ~readonly:false in + let* io = Io.open_ ~sw ~path ~readonly:false in let+ () = check_consistent_store ~end_poff ~dead_header_size io in let persisted_end_poff = Atomic.make end_poff in let dead_header_size = Int63.of_int dead_header_size in { io; persisted_end_poff; dead_header_size; rw_perm = create_rw_perm () } - let open_ro ~path ~end_poff ~dead_header_size = + let open_ro ~sw ~path ~end_poff ~dead_header_size = let open Result_syntax in - let* io = Io.open_ ~path ~readonly:true in + let* io = Io.open_ ~sw ~path ~readonly:true in let+ () = check_consistent_store ~end_poff ~dead_header_size io in let persisted_end_poff = Atomic.make end_poff in let dead_header_size = Int63.of_int dead_header_size in diff --git a/src/irmin-pack/io/append_only_file_intf.ml b/src/irmin-pack/io/append_only_file_intf.ml index 41ae128a7a..02558397bc 100644 --- a/src/irmin-pack/io/append_only_file_intf.ml +++ b/src/irmin-pack/io/append_only_file_intf.ml @@ -31,11 +31,15 @@ module type S = sig type t val create_rw : - path:string -> overwrite:bool -> (t, [> Io.create_error ]) result + sw:Eio.Switch.t -> + path:Eio.Fs.dir_ty Eio.Path.t -> + overwrite:bool -> + (t, [> Io.create_error ]) result (** Create a rw instance of [t] by creating the file at [path]. *) val open_rw : - path:string -> + sw:Eio.Switch.t -> + path:Eio.Fs.dir_ty Eio.Path.t -> end_poff:int63 -> dead_header_size:int -> ( t, @@ -67,7 +71,8 @@ module type S = sig stores with [`V3]. *) val open_ro : - path:string -> + sw:Eio.Switch.t -> + path:Eio.Fs.dir_ty Eio.Path.t -> end_poff:int63 -> dead_header_size:int -> ( t, @@ -156,7 +161,7 @@ module type S = sig val readonly : t -> bool val empty_buffer : t -> bool - val path : t -> string + val path : t -> Eio.Fs.dir_ty Eio.Path.t end module type Sigs = sig diff --git a/src/irmin-pack/io/async_intf.ml b/src/irmin-pack/io/async_intf.ml index dad1c3c4fb..9b1def4089 100644 --- a/src/irmin-pack/io/async_intf.ml +++ b/src/irmin-pack/io/async_intf.ml @@ -25,7 +25,8 @@ module type S = sig type status = [ outcome | `Running ] [@@deriving irmin] - val async : (unit -> unit) -> t + val async : + sw:Eio.Switch.t -> domain_mgr:_ Eio.Domain_manager.t -> (unit -> unit) -> t (** Start a task. *) val await : t -> [> outcome ] diff --git a/src/irmin-pack/io/atomic_write.ml b/src/irmin-pack/io/atomic_write.ml index fd613893f4..77da11ad9f 100644 --- a/src/irmin-pack/io/atomic_write.ml +++ b/src/irmin-pack/io/atomic_write.ml @@ -56,7 +56,8 @@ struct index : int63 Tbl.t; cache : V.t Tbl.t; block : Io.t; - mutable block_size : int63; + lock : Eio.Mutex.t; + block_size : int63 Atomic.t; w : W.t; } @@ -125,10 +126,14 @@ struct aux () let sync_offset t = - let former_offset = t.block_size in - t.block_size <- block_size t.block; - if t.block_size > former_offset then - refill t ~to_:t.block_size ~from:former_offset + let newer_offset = block_size t.block in + let former_offset = Atomic.get t.block_size in + if newer_offset > former_offset then + Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> + let former_offset = Atomic.get t.block_size in + if newer_offset > former_offset then ( + refill t ~to_:newer_offset ~from:former_offset; + Atomic.set t.block_size newer_offset) let unsafe_find t k = [%log.debug "[branches] find %a" pp_key k]; @@ -157,25 +162,26 @@ struct let watches = W.v () - let v ?(fresh = false) ?(readonly = false) file = + let v ~sw ?(fresh = false) ?(readonly = false) file = let block = if (not readonly) && (fresh || Io.classify_path file = `No_such_file_or_directory) then ( let io = - Io_errors.raise_if_error (Io.create ~path:file ~overwrite:true) + Io_errors.raise_if_error (Io.create ~sw ~path:file ~overwrite:true) in Io.write_exn io ~off:Int63.zero ~len:dead_header_size (String.make dead_header_size '\000'); io) - else Io_errors.raise_if_error (Io.open_ ~path:file ~readonly) + else Io_errors.raise_if_error (Io.open_ ~sw ~path:file ~readonly) in let cache = Tbl.create 997 in let index = Tbl.create 997 in - let block_size = block_size block in - let t = { cache; index; block; block_size; w = watches } in - refill t ~to_:block_size ~from:(Int63.of_int dead_header_size); + let block_size = Atomic.make (block_size block) in + let lock = Eio.Mutex.create () in + let t = { cache; index; block; block_size; lock; w = watches } in + refill t ~to_:(Atomic.get block_size) ~from:(Int63.of_int dead_header_size); t let clear _ = Fmt.failwith "Unsupported operation" @@ -192,7 +198,7 @@ struct Tbl.add t.index k offset let set t k v = - [%log.debug "[branches %s] set %a" (Io.path t.block) pp_key k]; + [%log.debug "[branches %a] set %a" Eio.Path.pp (Io.path t.block) pp_key k]; unsafe_set t k v; W.notify t.w k (Some v) diff --git a/src/irmin-pack/io/checks.ml b/src/irmin-pack/io/checks.ml index 493487e4ce..1015699c54 100644 --- a/src/irmin-pack/io/checks.ml +++ b/src/irmin-pack/io/checks.ml @@ -41,10 +41,15 @@ let setup_log = in Cmdliner.Term.(const init $ Fmt_cli.style_renderer () $ Logs_cli.level ()) -let path = +let path fs = let open Cmdliner.Arg in + let eio_path fs = + let parse s = Ok Eio.Path.(fs / s) in + let print = Eio.Path.pp in + conv ~docv:"PATH" (parse, print) + in required - @@ pos 0 (some string) None + @@ pos 0 (some (eio_path fs)) None @@ info ~doc:"Path to the Irmin store on disk" ~docv:"PATH" [] let deprecated_info = (Cmdliner.Term.info [@alert "-deprecated"]) @@ -73,6 +78,7 @@ struct [@@deriving irmin] let traverse_index ~root log_size = + let root = Eio.Path.native_exn root in let index = Index.v_exn ~readonly:true ~fresh:false ~log_size root in let ppf = Format.err_formatter in let bar, (progress_contents, progress_nodes, progress_commits) = @@ -95,18 +101,21 @@ struct let conf root = Conf.init ~readonly:true ~fresh:false ~no_migrate:true root - let run ~root = - [%logs.app "Getting statistics for store: `%s'@," root]; - let log_size = conf root |> Conf.index_log_size in + let run ~fs ~root = + [%logs.app + "Getting statistics for store: `%s'@," (Eio.Path.native_exn root)]; + Eio.Switch.run @@ fun sw -> + let log_size = conf ~sw ~fs root |> Conf.index_log_size in let objects = traverse_index ~root log_size in { hash_size = Bytes Hash.hash_size; log_size; objects } |> Irmin.Type.pp_json ~minify:false t Fmt.stdout - let term_internal = Cmdliner.Term.(const (fun root () -> run ~root) $ path) + let term_internal ~fs = + Cmdliner.Term.(const (fun root () -> run ~fs ~root) $ path fs) - let term = + let term ~fs = let doc = "Print high-level statistics about the store." in - Cmdliner.Term.(term_internal $ setup_log, deprecated_info ~doc "stat") + Cmdliner.Term.(term_internal ~fs $ setup_log, deprecated_info ~doc "stat") end module Reconstruct_index = struct @@ -126,24 +135,27 @@ struct & opt (some int) None @@ info ~doc:"Size of the index log file" [ "index-log-size" ] - let run ~root ~output ?index_log_size () = - let conf = conf ~index_log_size root in + let run ~sw ~fs ~root ~output ?index_log_size () = + let conf = conf ~sw ~fs ~index_log_size root in match output with - | None -> Store.traverse_pack_file (`Reconstruct_index `In_place) conf - | Some p -> Store.traverse_pack_file (`Reconstruct_index (`Output p)) conf + | None -> + Store.traverse_pack_file ~sw ~fs (`Reconstruct_index `In_place) conf + | Some p -> + Store.traverse_pack_file ~sw ~fs (`Reconstruct_index (`Output p)) conf - let term_internal = + let term_internal ~fs = Cmdliner.Term.( const (fun root output index_log_size () -> - run ~root ~output ?index_log_size ()) - $ path + Eio.Switch.run (fun sw -> + run ~sw ~fs ~root ~output ?index_log_size ())) + $ path fs $ dest $ index_log_size) - let term = + let term ~fs = let doc = "Reconstruct index from an existing pack file." in Cmdliner.Term. - (term_internal $ setup_log, deprecated_info ~doc "reconstruct-index") + (term_internal ~fs $ setup_log, deprecated_info ~doc "reconstruct-index") end module Integrity_check_index = struct @@ -155,10 +167,11 @@ struct Conf.init ~readonly:true ~fresh:false ~no_migrate:true ~indexing_strategy root - let run ~root ~auto_repair ~always () = - let conf = conf root always in - if auto_repair then Store.traverse_pack_file `Check_and_fix_index conf - else Store.traverse_pack_file `Check_index conf + let run ~sw ~fs ~root ~auto_repair ~always () = + let conf = conf ~sw ~fs root always in + if auto_repair then + Store.traverse_pack_file ~sw ~fs `Check_and_fix_index conf + else Store.traverse_pack_file ~sw ~fs `Check_index conf let auto_repair = let open Cmdliner.Arg in @@ -169,18 +182,19 @@ struct let open Cmdliner.Arg in value & (flag @@ info ~doc:"Use always indexing strategy" [ "always" ]) - let term_internal = + let term_internal ~fs = Cmdliner.Term.( const (fun root auto_repair always () -> - run ~root ~auto_repair ~always ()) - $ path + Eio.Switch.run (fun sw -> run ~sw ~fs ~root ~auto_repair ~always ())) + $ path fs $ auto_repair $ always) - let term = + let term ~fs = let doc = "Check index integrity." in Cmdliner.Term. - (term_internal $ setup_log, deprecated_info ~doc "integrity-check-index") + ( term_internal ~fs $ setup_log, + deprecated_info ~doc "integrity-check-index" ) end module Integrity_check = struct @@ -203,8 +217,8 @@ struct | Error (`Corrupted x) -> Printf.eprintf "%sError -- corrupted: %d\n%!" name x - let run ?ppf ~root ~auto_repair ~always ~heads () = - let conf = conf root always in + let run ~sw ~fs ?ppf ~root ~auto_repair ~always ~heads () = + let conf = conf ~sw ~fs root always in let repo = Store.Repo.v conf in let heads = match heads with @@ -235,19 +249,21 @@ struct let open Cmdliner.Arg in value & (flag @@ info ~doc:"Use always indexing strategy" [ "always" ]) - let term_internal = + let term_internal ~fs = Cmdliner.Term.( const (fun root auto_repair always heads () -> - run ~ppf:Format.err_formatter ~root ~auto_repair ~always ~heads ()) - $ path + Eio.Switch.run (fun sw -> + run ~sw ~fs ~ppf:Format.err_formatter ~root ~auto_repair ~always + ~heads ())) + $ path fs $ auto_repair $ always $ heads) - let term = + let term ~fs = let doc = "Check integrity of an existing store." in Cmdliner.Term. - (term_internal $ setup_log, deprecated_info ~doc "integrity-check") + (term_internal ~fs $ setup_log, deprecated_info ~doc "integrity-check") end module Integrity_check_inodes = struct @@ -259,8 +275,8 @@ struct & opt (some (list ~sep:',' string)) None & info [ "heads" ] ~doc:"List of head commit hashes" ~docv:"HEADS" - let run ~root ~heads = - let conf = conf root in + let run ~sw ~fs ~root ~heads = + let conf = conf ~sw ~fs root in let repo = Store.Repo.v conf in let heads = match heads with @@ -280,14 +296,17 @@ struct in Store.Repo.close repo - let term_internal = + let term_internal ~fs = Cmdliner.Term.( - const (fun root heads () -> run ~root ~heads) $ path $ heads) + const (fun root heads () -> + Eio.Switch.run (fun sw -> run ~sw ~fs ~root ~heads)) + $ path fs + $ heads) - let term = + let term ~fs = let doc = "Check integrity of inodes in an existing store." in Cmdliner.Term. - ( term_internal $ setup_log, + ( term_internal ~fs $ setup_log, deprecated_info ~doc "integrity-check-inodes" ) end @@ -308,8 +327,8 @@ struct & info [ "dump_blob_paths_to" ] ~doc:"Print all paths to a blob in the tree in a file." - let run ~root ~commit ~dump_blob_paths_to () = - let conf = conf root in + let run ~sw ~fs ~root ~commit ~dump_blob_paths_to () = + let conf = conf ~sw ~fs root in let repo = Store.Repo.v conf in let commit = match commit with @@ -334,27 +353,28 @@ struct let () = Store.stats ~dump_blob_paths_to ~commit repo in Store.Repo.close repo - let term_internal = + let term_internal ~fs = Cmdliner.Term.( const (fun root commit dump_blob_paths_to () -> - run ~root ~commit ~dump_blob_paths_to ()) - $ path + Eio.Switch.run (fun sw -> + run ~sw ~fs ~root ~commit ~dump_blob_paths_to ())) + $ path fs $ commit $ dump_blob_paths_to) - let term = + let term ~fs = let doc = "Traverse one commit, specified with the --commit argument, in the \ store for stats. If no commit is specified the current head is used." in Cmdliner.Term. - (term_internal $ setup_log, deprecated_info ~doc "stat-store") + (term_internal ~fs $ setup_log, deprecated_info ~doc "stat-store") end module Cli = struct open Cmdliner - let main + let main ~fs ?(terms = [ Stat.term; @@ -364,10 +384,11 @@ struct Integrity_check_index.term; Stats_commit.term; ]) () : empty = + let terms = List.map (fun f -> f ~fs) terms in let default = let default_info = let doc = "Check Irmin data-stores." in - deprecated_info ~doc "irmin-fsck" + deprecated_info ~doc "irmin-~fsck" in Term.(ret (const (`Help (`Auto, None))), default_info) in diff --git a/src/irmin-pack/io/checks_intf.ml b/src/irmin-pack/io/checks_intf.ml index f62dd361cf..aee916f6a2 100644 --- a/src/irmin-pack/io/checks_intf.ml +++ b/src/irmin-pack/io/checks_intf.ml @@ -23,17 +23,23 @@ module type Subcommand = sig val run : run - val term_internal : (unit -> unit) Cmdliner.Term.t + val term_internal : + fs:Eio.Fs.dir_ty Eio.Path.t -> (unit -> unit) Cmdliner.Term.t (** A pre-packaged [Cmdliner] term for executing {!run}. *) - val term : (unit Cmdliner.Term.t * Cmdliner.Term.info[@alert "-deprecated"]) + val term : + fs:Eio.Fs.dir_ty Eio.Path.t -> + (unit Cmdliner.Term.t * Cmdliner.Term.info[@alert "-deprecated"]) (** [term] is {!term_internal} plus documentation and logs initialisation *) end module type S = sig (** Reads basic metrics from an existing store and prints them to stdout. *) module Stat : sig - include Subcommand with type run := root:string -> unit + include + Subcommand + with type run := + fs:Eio.Fs.dir_ty Eio.Path.t -> root:Eio.Fs.dir_ty Eio.Path.t -> unit (** Internal implementation utilities exposed for use in other integrity checks. *) @@ -43,13 +49,15 @@ module type S = sig type objects = { nb_commits : int; nb_nodes : int; nb_contents : int } [@@deriving irmin] - val traverse_index : root:string -> int -> objects + val traverse_index : root:Eio.Fs.dir_ty Eio.Path.t -> int -> objects end module Reconstruct_index : Subcommand with type run := - root:string -> + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> output:string option -> ?index_log_size:int -> unit -> @@ -61,8 +69,10 @@ module type S = sig include Subcommand with type run := + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> ?ppf:Format.formatter -> - root:string -> + root:Eio.Fs.dir_ty Eio.Path.t -> auto_repair:bool -> always:bool -> heads:string list option -> @@ -83,14 +93,25 @@ module type S = sig include Subcommand with type run := - root:string -> auto_repair:bool -> always:bool -> unit -> unit + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> + auto_repair:bool -> + always:bool -> + unit -> + unit end (** Checks the integrity of inodes in a store *) module Integrity_check_inodes : sig include Subcommand - with type run := root:string -> heads:string list option -> unit + with type run := + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> + heads:string list option -> + unit end (** Traverses a commit to get stats on its underlying tree. *) @@ -98,7 +119,9 @@ module type S = sig include Subcommand with type run := - root:string -> + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> commit:string option -> dump_blob_paths_to:string option -> unit -> @@ -106,8 +129,12 @@ module type S = sig end val cli : + fs:Eio.Fs.dir_ty Eio.Path.t -> ?terms: - ((unit Cmdliner.Term.t * Cmdliner.Term.info)[@alert "-deprecated"]) list -> + ((fs:Eio.Fs.dir_ty Eio.Path.t -> + unit Cmdliner.Term.t * Cmdliner.Term.info) + [@alert "-deprecated"]) + list -> unit -> empty (** Run a [Cmdliner] binary containing tools for running offline checks. @@ -126,7 +153,9 @@ module type Sigs = sig type nonrec empty = empty val setup_log : unit Cmdliner.Term.t - val path : string Cmdliner.Term.t + + val path : + Eio.Fs.dir_ty Eio.Path.t -> Eio.Fs.dir_ty Eio.Path.t Cmdliner.Term.t module type Subcommand = Subcommand module type S = S diff --git a/src/irmin-pack/io/chunked_suffix.ml b/src/irmin-pack/io/chunked_suffix.ml index c8172e03f8..bf7de42a95 100644 --- a/src/irmin-pack/io/chunked_suffix.ml +++ b/src/irmin-pack/io/chunked_suffix.ml @@ -193,18 +193,23 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct let start_idx t = t.chunks.(0).idx end - type t = { inventory : Inventory.t; root : string; dead_header_size : int } + type t = { + inventory : Inventory.t; + root : Eio.Fs.dir_ty Eio.Path.t; + dead_header_size : int; + sw : Eio.Switch.t; + } let chunk_path = Layout.V4.suffix_chunk - let create_rw ~root ~start_idx ~overwrite = + let create_rw ~sw ~root ~start_idx ~overwrite = let open Result_syntax in let chunk_idx = start_idx in let path = chunk_path ~root ~chunk_idx in - let+ ao = Ao.create_rw ~path ~overwrite in + let+ ao = Ao.create_rw ~sw ~path ~overwrite in let chunk = { idx = chunk_idx; suffix_off = Int63.zero; ao } in let inventory = Inventory.v 1 (Fun.const chunk) in - { inventory; root; dead_header_size = 0 } + { inventory; root; dead_header_size = 0; sw } (** A module to adjust values when mapping from chunks to append-only files *) module Ao_shim = struct @@ -230,7 +235,7 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct { dead_header_size; end_poff } end - let open_rw ~root ~appendable_chunk_poff ~start_idx ~chunk_num + let open_rw ~sw ~root ~appendable_chunk_poff ~start_idx ~chunk_num ~dead_header_size = let open Result_syntax in let open_chunk ~chunk_idx ~is_legacy ~is_appendable = @@ -240,13 +245,13 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct ~is_appendable in match is_appendable with - | true -> Ao.open_rw ~path ~end_poff ~dead_header_size - | false -> Ao.open_ro ~path ~end_poff ~dead_header_size + | true -> Ao.open_rw ~sw ~path ~end_poff ~dead_header_size + | false -> Ao.open_ro ~sw ~path ~end_poff ~dead_header_size in let+ inventory = Inventory.open_ ~start_idx ~chunk_num ~open_chunk in - { inventory; root; dead_header_size } + { inventory; root; dead_header_size; sw } - let open_ro ~root ~appendable_chunk_poff ~dead_header_size ~start_idx + let open_ro ~sw ~root ~appendable_chunk_poff ~dead_header_size ~start_idx ~chunk_num = let open Result_syntax in let open_chunk ~chunk_idx ~is_legacy ~is_appendable = @@ -255,10 +260,10 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct Ao_shim.v ~path ~appendable_chunk_poff ~dead_header_size ~is_legacy ~is_appendable in - Ao.open_ro ~path ~end_poff ~dead_header_size + Ao.open_ro ~sw ~path ~end_poff ~dead_header_size in let+ inventory = Inventory.open_ ~start_idx ~chunk_num ~open_chunk in - { inventory; root; dead_header_size } + { inventory; root; dead_header_size; sw } let start_idx t = Inventory.start_idx t.inventory let chunk_num t = Inventory.count t.inventory @@ -325,8 +330,8 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct ~is_legacy ~is_appendable in match is_appendable with - | true -> Ao.create_rw ~path ~overwrite:true - | false -> Ao.open_ro ~path ~end_poff ~dead_header_size + | true -> Ao.create_rw ~sw:t.sw ~path ~overwrite:true + | false -> Ao.open_ro ~sw:t.sw ~path ~end_poff ~dead_header_size in Inventory.add_new_appendable ~open_chunk t.inventory diff --git a/src/irmin-pack/io/chunked_suffix_intf.ml b/src/irmin-pack/io/chunked_suffix_intf.ml index 09ad711ce0..640ed05650 100644 --- a/src/irmin-pack/io/chunked_suffix_intf.ml +++ b/src/irmin-pack/io/chunked_suffix_intf.ml @@ -47,13 +47,15 @@ module type S = sig | `Multiple_empty_chunks ] val create_rw : - root:string -> + sw:Eio.Switch.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> start_idx:int -> overwrite:bool -> (t, [> create_error ]) result val open_rw : - root:string -> + sw:Eio.Switch.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> appendable_chunk_poff:int63 -> start_idx:int -> chunk_num:int -> @@ -61,7 +63,8 @@ module type S = sig (t, [> open_error ]) result val open_ro : - root:string -> + sw:Eio.Switch.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> appendable_chunk_poff:int63 -> dead_header_size:int -> start_idx:int -> diff --git a/src/irmin-pack/io/control_file.ml b/src/irmin-pack/io/control_file.ml index 0e88b66175..b4e99d1119 100644 --- a/src/irmin-pack/io/control_file.ml +++ b/src/irmin-pack/io/control_file.ml @@ -239,7 +239,7 @@ module Serde = struct | Valid (V4 payload) -> Ok (upgrade_from_v4 payload) | Valid (V5 payload) -> Ok payload - (* Similar yo [of_bin_string] but skips version upgrade *) + (* Similar to [of_bin_string] but skips version upgrade *) let raw_of_bin_string = Data.of_bin_string let to_bin_string payload = Data.(to_bin_string (Valid (V5 payload))) end @@ -323,8 +323,8 @@ module Make (Serde : Serde.S) (Io : Io_intf.S) = struct type t = { mutable io : Io.t; payload : payload Atomic.t; - path : string; - tmp_path : string option; + path : Eio.Fs.dir_ty Eio.Path.t; + tmp_path : Eio.Fs.dir_ty Eio.Path.t option; lock : Eio.Mutex.t; } @@ -332,7 +332,7 @@ module Make (Serde : Serde.S) (Io : Io_intf.S) = struct let s = Serde.to_bin_string payload in Io.write_string io ~off:Int63.zero s - let set_payload t payload = + let set_payload ~sw t payload = let open Result_syntax in Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> if Io.readonly t.io then Error `Ro_not_allowed @@ -341,7 +341,7 @@ module Make (Serde : Serde.S) (Io : Io_intf.S) = struct | None -> Error `No_tmp_path_provided | Some tmp_path -> let* () = Io.close t.io in - let* io_tmp = Io.create ~path:tmp_path ~overwrite:true in + let* io_tmp = Io.create ~sw ~path:tmp_path ~overwrite:true in t.io <- io_tmp; let* () = write io_tmp payload in let+ () = Io.move_file ~src:tmp_path ~dst:t.path in @@ -350,19 +350,19 @@ module Make (Serde : Serde.S) (Io : Io_intf.S) = struct let read io = let open Result_syntax in let* string = Io.read_all_to_string io in - Serde.of_bin_string (Io.path io) string + Serde.of_bin_string (Eio.Path.native_exn @@ Io.path io) string - let create_rw ~path ~tmp_path ~overwrite (payload : payload) = + let create_rw ~sw ~path ~tmp_path ~overwrite (payload : payload) = let open Result_syntax in let lock = Eio.Mutex.create () in - let* io = Io.create ~path ~overwrite in + let* io = Io.create ~sw ~path ~overwrite in let+ () = write io payload in { io; payload = Atomic.make payload; path; tmp_path; lock } - let open_ ~path ~tmp_path ~readonly = + let open_ ~sw ~path ~tmp_path ~readonly = let open Result_syntax in let lock = Eio.Mutex.create () in - let* io = Io.open_ ~path ~readonly in + let* io = Io.open_ ~sw ~path ~readonly in let+ payload = read io in { io; payload = Atomic.make payload; path; tmp_path; lock } @@ -373,29 +373,29 @@ module Make (Serde : Serde.S) (Io : Io_intf.S) = struct let payload t = Atomic.get t.payload - let reload t = + let reload ~sw t = let open Result_syntax in Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> if not @@ Io.readonly t.io then Error `Rw_not_allowed else let* () = Io.close t.io in - let* io = Io.open_ ~path:t.path ~readonly:true in + let* io = Io.open_ ~sw ~path:t.path ~readonly:true in t.io <- io; let+ payload = read io in Atomic.set t.payload payload - let read_payload ~path = + let read_payload ~sw ~path = let open Result_syntax in - let* io = Io.open_ ~path ~readonly:true in + let* io = Io.open_ ~sw ~path ~readonly:true in let* payload = read io in let+ () = Io.close io in payload - let read_raw_payload ~path = + let read_raw_payload ~sw ~path = let open Result_syntax in - let* io = Io.open_ ~path ~readonly:true in + let* io = Io.open_ ~sw ~path ~readonly:true in let* string = Io.read_all_to_string io in - let* payload = Serde.raw_of_bin_string path string in + let* payload = Serde.raw_of_bin_string (Eio.Path.native_exn path) string in let+ () = Io.close io in payload diff --git a/src/irmin-pack/io/control_file_intf.ml b/src/irmin-pack/io/control_file_intf.ml index d33fac8185..c1ce497ea5 100644 --- a/src/irmin-pack/io/control_file_intf.ml +++ b/src/irmin-pack/io/control_file_intf.ml @@ -304,8 +304,9 @@ module type S = sig type t val create_rw : - path:string -> - tmp_path:string option -> + sw:Eio.Switch.t -> + path:Eio.Fs.dir_ty Eio.Path.t -> + tmp_path:Eio.Fs.dir_ty Eio.Path.t option -> overwrite:bool -> payload -> (t, [> Io.create_error | Io.write_error ]) result @@ -320,8 +321,9 @@ module type S = sig | `Unknown_major_pack_version of string ] val open_ : - path:string -> - tmp_path:string option -> + sw:Eio.Switch.t -> + path:Eio.Fs.dir_ty Eio.Path.t -> + tmp_path:Eio.Fs.dir_ty Eio.Path.t option -> readonly:bool -> (t, [> open_error ]) result (** Create a rw instance of [t] by reading an existing file at [path]. @@ -331,13 +333,17 @@ module type S = sig val close : t -> (unit, [> Io.close_error ]) result val read_payload : - path:string -> (payload, [> open_error | Io.close_error ]) result + sw:Eio.Switch.t -> + path:Eio.Fs.dir_ty Eio.Path.t -> + (payload, [> open_error | Io.close_error ]) result (** [read_payload ~path] reads the payload at [path]. It is a convenient way to read the payload without needing to call {!open_}, {!payload}, {!close}. *) val read_raw_payload : - path:string -> (raw_payload, [> open_error | Io.close_error ]) result + sw:Eio.Switch.t -> + path:Eio.Fs.dir_ty Eio.Path.t -> + (raw_payload, [> open_error | Io.close_error ]) result val payload : t -> payload (** [payload t] is the payload in [t]. @@ -355,7 +361,7 @@ module type S = sig type reload_error := [ `Rw_not_allowed | open_error | Io.close_error ] - val reload : t -> (unit, [> reload_error ]) result + val reload : sw:Eio.Switch.t -> t -> (unit, [> reload_error ]) result (** {3 RW mode} Always returns an error. @@ -376,7 +382,8 @@ module type S = sig | move_error | Io.close_error ] - val set_payload : t -> payload -> (unit, [> set_error ]) result + val set_payload : + sw:Eio.Switch.t -> t -> payload -> (unit, [> set_error ]) result (** {3 RW mode} Write a new payload on disk. diff --git a/src/irmin-pack/io/dict.ml b/src/irmin-pack/io/dict.ml index 522678cfa1..17069c577a 100644 --- a/src/irmin-pack/io/dict.ml +++ b/src/irmin-pack/io/dict.ml @@ -90,9 +90,9 @@ module Make (Io : Io_intf.S) = struct let last_refill_offset = Int63.zero in { capacity = default_capacity; index; cache; ao; last_refill_offset } - let create_rw ~overwrite ~path:filename = + let create_rw ~sw ~overwrite ~path:filename = let open Result_syntax in - let* ao = Ao.create_rw ~overwrite ~path:filename in + let* ao = Ao.create_rw ~sw ~overwrite ~path:filename in Ok (v_empty ao) let v_filled ao = @@ -101,14 +101,14 @@ module Make (Io : Io_intf.S) = struct let* () = refill t in Ok t - let open_rw ~size ~dead_header_size filename = + let open_rw ~sw ~size ~dead_header_size filename = let open Result_syntax in - let* ao = Ao.open_rw ~path:filename ~end_poff:size ~dead_header_size in + let* ao = Ao.open_rw ~sw ~path:filename ~end_poff:size ~dead_header_size in v_filled ao - let open_ro ~size ~dead_header_size filename = + let open_ro ~sw ~size ~dead_header_size filename = let open Result_syntax in - let* ao = Ao.open_ro ~path:filename ~end_poff:size ~dead_header_size in + let* ao = Ao.open_ro ~sw ~path:filename ~end_poff:size ~dead_header_size in v_filled ao let end_poff t = Ao.end_poff t.ao diff --git a/src/irmin-pack/io/dict_intf.ml b/src/irmin-pack/io/dict_intf.ml index 0542b253a6..83bfcaaac9 100644 --- a/src/irmin-pack/io/dict_intf.ml +++ b/src/irmin-pack/io/dict_intf.ml @@ -25,18 +25,23 @@ module type S = sig val index : t -> string -> int option val create_rw : - overwrite:bool -> path:string -> (t, [> Io.create_error ]) result + sw:Eio.Switch.t -> + overwrite:bool -> + path:Eio.Fs.dir_ty Eio.Path.t -> + (t, [> Io.create_error ]) result val open_rw : + sw:Eio.Switch.t -> size:int63 -> dead_header_size:int -> - string -> + Eio.Fs.dir_ty Eio.Path.t -> (t, [> Io.open_error | Io.read_error | `Inconsistent_store ]) result val open_ro : + sw:Eio.Switch.t -> size:int63 -> dead_header_size:int -> - string -> + Eio.Fs.dir_ty Eio.Path.t -> (t, [> Io.open_error | Io.read_error | `Inconsistent_store ]) result val refresh_end_poff : diff --git a/src/irmin-pack/io/file_manager.ml b/src/irmin-pack/io/file_manager.ml index f488c3e5d1..419212a4d8 100644 --- a/src/irmin-pack/io/file_manager.ml +++ b/src/irmin-pack/io/file_manager.ml @@ -49,7 +49,8 @@ struct mutable suffix_consumers : after_flush_consumer list; indexing_strategy : Irmin_pack.Indexing_strategy.t; use_fsync : bool; - root : string; + root : Eio.Fs.dir_ty Eio.Path.t; + sw : Eio.Switch.t; } let control t = t.control @@ -149,7 +150,7 @@ struct if new_pl = pl then Ok () else let open Result_syntax in - let* () = Control.set_payload t.control new_pl in + let* () = Control.set_payload ~sw:t.sw t.control new_pl in if t.use_fsync then Control.fsync t.control else Ok () (** Flush stage 2 *) @@ -201,7 +202,7 @@ struct module Layout = Irmin_pack.Layout.V5 - let open_prefix ~root ~generation ~mapping_size = + let open_prefix ~sw ~root ~generation ~mapping_size = let open Result_syntax in if generation = 0 then Ok None else @@ -213,12 +214,14 @@ struct | None -> Io.size_of_path mapping in let mapping_size = Int63.to_int mapping_size in - let+ prefix = Sparse.open_ro ~mapping_size ~mapping ~data in + let+ prefix = Sparse.open_ro ~sw ~mapping_size ~mapping ~data in Some prefix let reopen_prefix t ~generation ~mapping_size = let open Result_syntax in - let* some_prefix = open_prefix ~root:t.root ~generation ~mapping_size in + let* some_prefix = + open_prefix ~sw:t.sw ~root:t.root ~generation ~mapping_size + in match some_prefix with | None -> Ok () | Some _ -> @@ -240,13 +243,14 @@ struct let* suffix1 = let root = t.root in let start_idx = chunk_start_idx in + let sw = t.sw in [%log.debug "reload: generation changed, opening suffix"]; if readonly then - Suffix.open_ro ~root ~appendable_chunk_poff ~dead_header_size ~start_idx - ~chunk_num + Suffix.open_ro ~sw ~root ~appendable_chunk_poff ~dead_header_size + ~start_idx ~chunk_num else - Suffix.open_rw ~root ~appendable_chunk_poff ~dead_header_size ~start_idx - ~chunk_num + Suffix.open_rw ~sw ~root ~appendable_chunk_poff ~dead_header_size + ~start_idx ~chunk_num in let suffix0 = t.suffix in t.suffix <- suffix1; @@ -266,19 +270,24 @@ struct | `Prefix g | `Mapping g -> g <> generation | `Suffix idx -> idx < chunk_start_idx || idx > chunk_start_idx + chunk_num - | `Reachable _ | `Sorted _ | `Gc_result _ | `Control_tmp -> true) + | `Reachable _ | `Sorted _ | `Gc_result _ | `Control_tmp + | `Dict_tmp -> + true) |> List.iter (fun residual -> - let filename = Filename.concat root residual in - [%log.debug "Remove residual file %s" filename]; + let filename = Eio.Path.(root / residual) in + [%log.debug + "Remove residual file %s" (Eio.Path.native_exn filename)]; match Io.unlink filename with | Ok () -> () | Error (`Sys_error error) -> [%log.warn - "Could not remove residual file %s: %s" filename error]) + "Could not remove residual file %s: %s" + (Eio.Path.native_exn filename) + error]) in Option.might (Lower.cleanup ~generation) lower - let add_volume_and_update_control lower control = + let add_volume_and_update_control ~sw lower control = let open Result_syntax in (* Step 1. Add volume *) let* _ = Lower.add_volume lower in @@ -286,12 +295,12 @@ struct let pl = Control.payload control in let pl = { pl with volume_num = Lower.volume_num lower } in [%log.debug "add_volume: update control_file volume_num:%d" pl.volume_num]; - Control.set_payload control pl + Control.set_payload ~sw control pl - let finish_constructing_rw config control ~make_dict ~make_suffix ~make_index - ~make_lower = + let finish_constructing_rw ~sw ~fs config control ~make_dict ~make_suffix + ~make_index ~make_lower = let open Result_syntax in - let root = Irmin_pack.Conf.root config in + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let use_fsync = Irmin_pack.Conf.use_fsync config in let indexing_strategy = Conf.indexing_strategy config in let pl : Payload.t = Control.payload control in @@ -327,7 +336,7 @@ struct in (* 2. Open the other files *) let* suffix = make_suffix () in - let* prefix = open_prefix ~root ~generation ~mapping_size in + let* prefix = open_prefix ~sw ~root ~generation ~mapping_size in let* dict = let path = Layout.dict ~root in make_dict ~path @@ -365,13 +374,14 @@ struct suffix_consumers = []; indexing_strategy; root; + sw; } in instance := Some t; Ok t - let create_control_file ~overwrite config pl = - let root = Irmin_pack.Conf.root config in + let create_control_file ~fs ~overwrite config pl = + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let path = Layout.control ~root in let tmp_path = Layout.control_tmp ~root in Control.create_rw ~path ~tmp_path:(Some tmp_path) ~overwrite pl @@ -385,7 +395,7 @@ struct (match hook with Some h -> h `After_index | None -> ()); let pl0 = Control.payload t.control in (* Step 2. Reread control file *) - let* () = Control.reload t.control in + let* () = Control.reload ~sw:t.sw t.control in (match hook with Some h -> h `After_control | None -> ()); let pl1 : Payload.t = Control.payload t.control in if pl0 = pl1 then Ok () @@ -428,10 +438,11 @@ struct (* File creation ********************************************************** *) - let create_lower_if_needed ~lower_root ~overwrite = + let create_lower_if_needed ~fs ~lower_root ~overwrite = match lower_root with | None -> Ok () | Some path -> ( + let path = Eio.Path.(fs / path) in match (Io.classify_path path, overwrite) with | `Directory, false -> Ok () | `Directory, true -> @@ -439,23 +450,25 @@ struct failwith (Fmt.str "Lower root already exists but fresh = true in configuration. \ - Please manually remove %s." - path) + Please manually remove %a." + Eio.Path.pp path) | `No_such_file_or_directory, _ -> Io.mkdir path - | (`File | `Other), _ -> Errs.raise_error (`Not_a_directory path)) + | (`File | `Other), _ -> + Errs.raise_error (`Not_a_directory (Eio.Path.native_exn path))) - let create_rw ~overwrite config = + let create_rw ~sw ~fs ~overwrite config = let open Result_syntax in - let root = Irmin_pack.Conf.root config in + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let lower_root = Irmin_pack.Conf.lower_root config in let* () = match (overwrite, Io.classify_path root) with - | _, (`File | `Other) -> Error (`Not_a_directory root) - | false, `Directory -> Error (`File_exists root) + | _, (`File | `Other) -> + Error (`Not_a_directory (Eio.Path.native_exn root)) + | false, `Directory -> Error (`File_exists (Eio.Path.native_exn root)) | true, `Directory -> Ok () | _, `No_such_file_or_directory -> Io.mkdir root in - let* () = create_lower_if_needed ~lower_root ~overwrite in + let* () = create_lower_if_needed ~fs ~lower_root ~overwrite in let* control = let open Payload in let status = No_gc_yet in @@ -472,24 +485,27 @@ struct volume_num = 0; } in - create_control_file ~overwrite config pl + create_control_file ~sw ~fs ~overwrite config pl in - let make_dict = Dict.create_rw ~overwrite in - let make_suffix () = Suffix.create_rw ~root ~overwrite ~start_idx:0 in + let make_dict = Dict.create_rw ~sw ~overwrite in + let make_suffix () = Suffix.create_rw ~sw ~root ~overwrite ~start_idx:0 in let make_index ~flush_callback ~readonly ~throttle ~log_size root = (* [overwrite] is ignored for index *) - Index.v ~fresh:true ~flush_callback ~readonly ~throttle ~log_size root + Index.v ~fresh:true ~flush_callback ~readonly ~throttle ~log_size + (Eio.Path.native_exn root) in let make_lower () = match lower_root with | None -> Ok None | Some path -> - let* l = Lower.v ~readonly:false ~volume_num:0 path in - let+ _ = add_volume_and_update_control l control in + let* l = + Lower.v ~sw ~readonly:false ~volume_num:0 Eio.Path.(fs / path) + in + let+ _ = add_volume_and_update_control ~sw l control in Some l in - finish_constructing_rw config control ~make_dict ~make_suffix ~make_index - ~make_lower + finish_constructing_rw ~sw ~fs config control ~make_dict ~make_suffix + ~make_index ~make_lower (* Open rw **************************************************************** *) @@ -510,7 +526,7 @@ struct | T15 -> failwith "invalid status: T1..T15" - let migrate_to_lower ~root ~lower_root ~control (payload : Payload.t) = + let migrate_to_lower ~sw ~root ~lower_root ~control (payload : Payload.t) = let open Result_syntax in (* Step 1. Create a lower by moving the suffix file. *) let suffix_file = @@ -519,13 +535,13 @@ struct let dead_header_size = dead_header_size_of_status payload.status in let end_offset = payload.appendable_chunk_poff in let* () = - Lower.create_from ~src:suffix_file ~dead_header_size ~size:end_offset + Lower.create_from ~sw ~src:suffix_file ~dead_header_size ~size:end_offset lower_root in (* Step 2. Create a new empty suffix for the upper. *) let chunk_start_idx = payload.chunk_start_idx + 1 in let* () = - Suffix.create_rw ~root ~overwrite:false ~start_idx:chunk_start_idx + Suffix.create_rw ~sw ~root ~overwrite:false ~start_idx:chunk_start_idx >>= Suffix.close in (* Step 3. Create a new empty prefix for the upper. *) @@ -533,16 +549,18 @@ struct let* () = let mapping = Layout.mapping ~generation ~root in let data = Layout.prefix ~root ~generation in - Sparse.Ao.create ~mapping ~data >>= Sparse.Ao.close + Sparse.Ao.create ~sw ~mapping ~data >>= Sparse.Ao.close in (* Step 4. Remove dead header from dict (if needed) *) let* dict_end_poff, after_payload_write = if dead_header_size > 0 then ( let dict_path = Layout.dict ~root in - let tmp_dict_path = Filename.temp_file ~temp_dir:root "store" "dict" in - let* dict_file = Io.open_ ~path:dict_path ~readonly:false in + let tmp_dict_path = Layout.dict_tmp ~root in + let* dict_file = Io.open_ ~sw ~path:dict_path ~readonly:false in let* len = Io.read_size dict_file in - let* tmp_dict_file = Io.open_ ~path:tmp_dict_path ~readonly:false in + let* tmp_dict_file = + Io.create ~sw ~path:tmp_dict_path ~overwrite:true + in let contents_len = Int63.to_int len - dead_header_size in let* contents = Io.read_to_string dict_file @@ -578,29 +596,31 @@ struct }; } in - let* () = Control.set_payload control payload in + let* () = Control.set_payload ~sw control payload in let* () = after_payload_write () in Ok payload - let load_payload ~config ~root ~lower_root ~control = + let load_payload ~sw ~fs ~config ~root ~lower_root ~control = let payload = Control.payload control in match lower_root with | Some lower_root when payload.volume_num = 0 -> if Irmin_pack.Conf.no_migrate config then Error `Migration_needed else if not (can_migrate_to_lower payload) then Error `Migration_to_lower_not_allowed - else migrate_to_lower ~root ~lower_root ~control payload + else + let lower_root = Eio.Path.(fs / lower_root) in + migrate_to_lower ~sw ~root ~lower_root ~control payload | _ -> Ok payload - let open_rw_with_control_file config = + let open_rw_with_control_file ~sw ~fs config = let open Result_syntax in - let root = Irmin_pack.Conf.root config in + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let lower_root = Irmin_pack.Conf.lower_root config in - let* () = create_lower_if_needed ~lower_root ~overwrite:false in + let* () = create_lower_if_needed ~fs ~lower_root ~overwrite:false in let* control = let path = Layout.control ~root in let tmp_path = Layout.control_tmp ~root in - Control.open_ ~readonly:false ~path ~tmp_path:(Some tmp_path) + Control.open_ ~sw ~readonly:false ~path ~tmp_path:(Some tmp_path) in let* Payload. { @@ -612,7 +632,7 @@ struct volume_num; _; } = - load_payload ~config ~root ~lower_root ~control + load_payload ~sw ~fs ~config ~root ~lower_root ~control in let* dead_header_size = match status with @@ -627,30 +647,32 @@ struct Error `V3_store_from_the_future in let make_dict ~path = - Dict.open_rw ~size:dict_end_poff ~dead_header_size path + Dict.open_rw ~sw ~size:dict_end_poff ~dead_header_size path in let make_suffix () = - Suffix.open_rw ~root ~appendable_chunk_poff ~start_idx ~chunk_num + Suffix.open_rw ~sw ~root ~appendable_chunk_poff ~start_idx ~chunk_num ~dead_header_size in let make_index ~flush_callback ~readonly ~throttle ~log_size root = - Index.v ~fresh:false ~flush_callback ~readonly ~throttle ~log_size root + Index.v ~fresh:false ~flush_callback ~readonly ~throttle ~log_size + (Eio.Path.native_exn root) in let make_lower () = match lower_root with | None -> Ok None | Some lower_root -> assert (volume_num > 0); - let+ l = Lower.v ~readonly:false ~volume_num lower_root in + let lower_root = Eio.Path.(fs / lower_root) in + let+ l = Lower.v ~sw ~readonly:false ~volume_num lower_root in Some l in - finish_constructing_rw config control ~make_dict ~make_suffix ~make_index - ~make_lower + finish_constructing_rw ~sw ~fs config control ~make_dict ~make_suffix + ~make_index ~make_lower - let read_offset_from_legacy_file path = + let read_offset_from_legacy_file ~sw path = let open Result_syntax in (* Bytes 0-7 contains the offset. Bytes 8-15 contain the version. *) - let* io = Io.open_ ~path ~readonly:true in + let* io = Io.open_ ~sw ~path ~readonly:true in Errors.finalise (fun _ -> Io.close io |> Errs.log_if_error "FM: read_offset_from_legacy_file") @@ fun () -> @@ -658,10 +680,10 @@ struct let x = Int63.decode ~off:0 s in Ok x - let read_version_from_legacy_file path = + let read_version_from_legacy_file ~sw path = let open Result_syntax in (* Bytes 0-7 contains the offset. Bytes 8-15 contain the version. *) - let* io = Io.open_ ~path ~readonly:true in + let* io = Io.open_ ~sw ~path ~readonly:true in Errors.finalise (fun _ -> Io.close io |> Errs.log_if_error "FM: read_version_from_legacy_file") @@ fun () -> @@ -671,16 +693,16 @@ struct | Some x -> Ok x | None -> Error `Corrupted_legacy_file - let open_rw_migrate_from_v1_v2 config = + let open_rw_migrate_from_v1_v2 ~sw ~fs config = let open Result_syntax in - let root = Irmin_pack.Conf.root config in + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let src = Irmin_pack.Layout.V1_and_v2.pack ~root in let chunk_start_idx = 0 in let dst = Layout.suffix_chunk ~root ~chunk_idx:chunk_start_idx in - let* suffix_end_poff = read_offset_from_legacy_file src in + let* suffix_end_poff = read_offset_from_legacy_file ~sw src in let* dict_end_poff = let path = Layout.dict ~root in - read_offset_from_legacy_file path + read_offset_from_legacy_file ~sw path in let* () = Io.move_file ~src ~dst in let* control = @@ -701,52 +723,54 @@ struct volume_num = 0; } in - create_control_file ~overwrite:false config pl + create_control_file ~sw ~fs ~overwrite:false config pl in let* () = Control.close control in - open_rw_with_control_file config + open_rw_with_control_file ~sw ~fs config - let open_rw_no_control_file config = - let root = Irmin_pack.Conf.root config in + let open_rw_no_control_file ~sw ~fs config = + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let suffix_path = Irmin_pack.Layout.V1_and_v2.pack ~root in match Io.classify_path suffix_path with | `Directory | `No_such_file_or_directory | `Other -> Error `Invalid_layout - | `File -> open_rw_migrate_from_v1_v2 config + | `File -> open_rw_migrate_from_v1_v2 ~sw ~fs config - let open_rw config = - let root = Irmin_pack.Conf.root config in + let open_rw ~sw ~fs config = + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let no_migrate = Irmin_pack.Conf.no_migrate config in match Io.classify_path root with - | `File | `Other -> Error (`Not_a_directory root) - | `No_such_file_or_directory -> Error (`No_such_file_or_directory root) + | `File | `Other -> Error (`Not_a_directory (Eio.Path.native_exn root)) + | `No_such_file_or_directory -> + Error (`No_such_file_or_directory (Eio.Path.native_exn root)) | `Directory -> ( let path = Layout.control ~root in match Io.classify_path path with - | `File -> open_rw_with_control_file config + | `File -> open_rw_with_control_file ~sw ~fs config | `No_such_file_or_directory -> if no_migrate then Error `Migration_needed - else open_rw_no_control_file config + else open_rw_no_control_file ~sw ~fs config | `Directory | `Other -> Error `Invalid_layout) (* Open ro **************************************************************** *) - let open_ro config = + let open_ro ~sw ~fs config = let open Result_syntax in let indexing_strategy = Conf.indexing_strategy config in - let root = Irmin_pack.Conf.root config in + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let lower_root = Irmin_pack.Conf.lower_root config in let use_fsync = Irmin_pack.Conf.use_fsync config in (* 1. Open the control file *) let* control = let path = Layout.control ~root in - Control.open_ ~readonly:true ~path ~tmp_path:None + Control.open_ ~sw ~readonly:true ~path ~tmp_path:None (* If no control file, then check whether the store is in v1 or v2. *) |> Result.map_error (function | `No_such_file_or_directory _ -> ( let pack = Irmin_pack.Layout.V1_and_v2.pack ~root in match Io.classify_path pack with | `File -> `Migration_needed - | `No_such_file_or_directory -> `No_such_file_or_directory pack + | `No_such_file_or_directory -> + `No_such_file_or_directory (Eio.Path.native_exn pack) | `Directory | `Other -> `Invalid_layout) | error -> error) in @@ -766,27 +790,29 @@ struct let generation = generation status in (* 2. Open the other files *) let* suffix = - Suffix.open_ro ~root ~appendable_chunk_poff ~start_idx ~chunk_num + Suffix.open_ro ~sw ~root ~appendable_chunk_poff ~start_idx ~chunk_num ~dead_header_size in let* prefix = - open_prefix ~root ~generation ~mapping_size:(mapping_size status) + open_prefix ~sw ~root ~generation ~mapping_size:(mapping_size status) in let* dict = let filename = Layout.dict ~root in - Dict.open_ro ~size:dict_end_poff ~dead_header_size filename + Dict.open_ro ~sw ~size:dict_end_poff ~dead_header_size filename in let* index = let log_size = Conf.index_log_size config in let throttle = Conf.merge_throttle config in - Index.v ~fresh:false ~readonly:true ~throttle ~log_size root + Index.v ~fresh:false ~readonly:true ~throttle ~log_size + (Eio.Path.native_exn root) in (* 3. Open lower layer *) let* lower = match lower_root with | None -> Ok None | Some path -> - let+ l = Lower.v ~readonly:true ~volume_num path in + let path = Eio.Path.(fs / path) in + let+ l = Lower.v ~sw ~readonly:true ~volume_num path in Some l in (* 4. return with success *) @@ -803,14 +829,15 @@ struct prefix_consumers = []; suffix_consumers = []; root; + sw; } (* MISC. ****************************************************************** *) - let version ~root = + let version ~sw ~root = let v2_or_v1 () = let path = Irmin_pack.Layout.V1_and_v2.pack ~root in - match read_version_from_legacy_file path with + match read_version_from_legacy_file ~sw path with | Ok v -> Ok v | Error `Double_close | Error `Invalid_argument | Error `Closed -> assert false @@ -821,11 +848,12 @@ struct | Error (`Io_misc _) as e -> e in match Io.classify_path root with - | `No_such_file_or_directory -> Error (`No_such_file_or_directory root) - | `File | `Other -> Error (`Not_a_directory root) + | `No_such_file_or_directory -> + Error (`No_such_file_or_directory (Eio.Path.native_exn root)) + | `File | `Other -> Error (`Not_a_directory (Eio.Path.native_exn root)) | `Directory -> ( let path = Layout.control ~root in - match Control.open_ ~path ~tmp_path:None ~readonly:true with + match Control.open_ ~sw ~path ~tmp_path:None ~readonly:true with | Ok _ -> Ok `V3 | Error (`No_such_file_or_directory _) -> v2_or_v1 () | Error `Not_a_file -> Error `Invalid_layout @@ -880,7 +908,7 @@ struct { pl with status; chunk_start_idx; chunk_num } in [%log.debug "GC: writing new control_file"]; - Control.set_payload t.control pl + Control.set_payload ~sw:t.sw t.control pl in (* Step 3. Swap volume and reload lower if needed *) @@ -954,12 +982,12 @@ struct [%log.debug "split: update control_file chunk_start_idx:%d chunk_num:%d" pl.chunk_start_idx pl.chunk_num]; - Control.set_payload t.control pl + Control.set_payload ~sw:t.sw t.control pl let add_volume t = match t.lower with | None -> Error `Add_volume_requires_lower - | Some lower -> add_volume_and_update_control lower t.control + | Some lower -> add_volume_and_update_control ~sw:t.sw lower t.control let cleanup t = let root = t.root in @@ -970,17 +998,17 @@ struct let lower = t.lower in cleanup ~root ~generation ~chunk_start_idx ~chunk_num ~lower - let create_one_commit_store t config gced commit_key = + let create_one_commit_store ~fs t config gced commit_key = let open Result_syntax in let src_root = t.root in - let dst_root = Irmin_pack.Conf.root config in + let dst_root = Eio.Path.(fs / Irmin_pack.Conf.root config) in (* Step 1. Copy the dict *) let src_dict = Layout.dict ~root:src_root in let dst_dict = Layout.dict ~root:dst_root in let* () = Io.copy_file ~src:src_dict ~dst:dst_dict in (* Step 2. Create an empty suffix and close it. *) let* suffix = - Suffix.create_rw ~root:dst_root ~overwrite:false ~start_idx:1 + Suffix.create_rw ~sw:t.sw ~root:dst_root ~overwrite:false ~start_idx:1 in let* () = Suffix.close suffix in (* Step 3. Create the control file and close it. *) @@ -999,14 +1027,17 @@ struct } in let path = Layout.control ~root:dst_root in - let* control = Control.create_rw ~path ~tmp_path:None ~overwrite:false pl in + let* control = + Control.create_rw ~sw:t.sw ~path ~tmp_path:None ~overwrite:false pl + in let* () = Control.close control in (* Step 4. Create the index. *) let* index = let log_size = Conf.index_log_size config in let throttle = Conf.merge_throttle config in Index.v ~fresh:true ~flush_callback:Fun.id ~readonly:false ~throttle - ~log_size dst_root + ~log_size + (Eio.Path.native_exn dst_root) in (* Step 5. Add the commit to the index, close the index. *) let () = diff --git a/src/irmin-pack/io/file_manager_intf.ml b/src/irmin-pack/io/file_manager_intf.ml index 7a567f9a6e..c75d73a0fd 100644 --- a/src/irmin-pack/io/file_manager_intf.ml +++ b/src/irmin-pack/io/file_manager_intf.ml @@ -95,7 +95,11 @@ module type S = sig | `No_tmp_path_provided ] val create_rw : - overwrite:bool -> Irmin.Backend.Conf.t -> (t, [> create_error ]) result + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + overwrite:bool -> + Irmin.Backend.Conf.t -> + (t, [> create_error ]) result (** Create a rw instance of [t] by creating the files. Note on SWMR consistency: It is undefined for a reader to attempt an @@ -137,7 +141,11 @@ module type S = sig | `Invalid_parent_directory | `Pending_flush ] - val open_rw : Irmin.Backend.Conf.t -> (t, [> open_rw_error ]) result + val open_rw : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + Irmin.Backend.Conf.t -> + (t, [> open_rw_error ]) result (** Create a rw instance of [t] by opening existing files. If the pack store has already been garbage collected, opening with a @@ -175,7 +183,11 @@ module type S = sig | `Invalid_layout | `Volume_missing of string ] - val open_ro : Irmin.Backend.Conf.t -> (t, [> open_ro_error ]) result + val open_ro : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + Irmin.Backend.Conf.t -> + (t, [> open_ro_error ]) result (** Create a ro instance of [t] by opening existing files. Note on SWMR consistency: [open_ro] is supposed to work whichever the @@ -251,7 +263,10 @@ module type S = sig | `Not_a_directory of string | `Unknown_major_pack_version of string ] - val version : root:string -> (Import.Version.t, [> version_error ]) result + val version : + sw:Eio.Switch.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> + (Import.Version.t, [> version_error ]) result (** [version ~root] is the version of the pack stores at [root]. *) val cleanup : t -> (unit, [> `Sys_error of string ]) result @@ -288,6 +303,7 @@ module type S = sig (** Returns where data discarded by the GC will end up. (see {!gc_behaviour}). *) val create_one_commit_store : + fs:Eio.Fs.dir_ty Eio.Path.t -> t -> Irmin.Backend.Conf.t -> Control_file.Payload.Upper.Latest.gced -> diff --git a/src/irmin-pack/io/gc.ml b/src/irmin-pack/io/gc.ml index 648809b9db..e40ef289fc 100644 --- a/src/irmin-pack/io/gc.ml +++ b/src/irmin-pack/io/gc.ml @@ -26,7 +26,7 @@ module Make (Args : Gc_args.S) = struct module Gc_stats_main = Gc_stats.Main (Io) type t = { - root : string; + root : Eio.Fs.dir_ty Eio.Path.t; generation : int; task : Async.t; unlink : bool; @@ -39,8 +39,8 @@ module Make (Args : Gc_args.S) = struct latest_gc_target_offset : int63; } - let v ~root ~lower_root ~output ~generation ~unlink ~dispatcher ~fm - ~contents:_ ~node:_ ~commit:_ commit_key = + let v ~sw ~fs ~domain_mgr ~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 @@ -93,7 +93,7 @@ module Make (Args : Gc_args.S) = struct let result_file = Irmin_pack.Layout.V4.gc_result ~root ~generation in match Io.classify_path result_file with | `File -> - Io.unlink_dont_wait + Io.unlink_dont_wait ~sw ~on_exn:(fun exn -> [%log.warn "Unlinking temporary files from previous failed gc. Failed \ @@ -107,9 +107,9 @@ module Make (Args : Gc_args.S) = struct unlink_result_file (); (* start worker task *) let task = - Async.async (fun () -> - Worker.run_and_output_result root commit_key new_suffix_start_offset - ~lower_root ~generation ~new_files_path) + Async.async ~sw ~domain_mgr (fun () -> + Worker.run_and_output_result ~fs root commit_key + new_suffix_start_offset ~lower_root ~generation ~new_files_path) in let partial_stats = Gc_stats_main.finish_current_step partial_stats "before finalise" @@ -153,13 +153,13 @@ module Make (Args : Gc_args.S) = struct ~suffix_start_offset ~chunk_start_idx ~chunk_num ~suffix_dead_bytes ~latest_gc_target_offset ~volume:gc_results.modified_volume - let unlink_all { root; generation; _ } removable_chunk_idxs = + let unlink_all ~sw { root; generation; _ } removable_chunk_idxs = (* Unlink suffix chunks *) let () = removable_chunk_idxs |> List.iter (fun chunk_idx -> let path = Irmin_pack.Layout.V4.suffix_chunk ~root ~chunk_idx in - Io.unlink_dont_wait + Io.unlink_dont_wait ~sw ~on_exn:(fun exn -> [%log.warn "Unlinking chunk_idxs files after gc, failed with error %s" @@ -171,7 +171,7 @@ module Make (Args : Gc_args.S) = struct let prefix = Irmin_pack.Layout.V4.prefix ~root ~generation:(generation - 1) in - Io.unlink_dont_wait + Io.unlink_dont_wait ~sw ~on_exn:(fun exn -> [%log.warn "Unlinking previous prefix after gc, failed with error %s" @@ -182,7 +182,7 @@ module Make (Args : Gc_args.S) = struct let mapping = Irmin_pack.Layout.V4.mapping ~root ~generation:(generation - 1) in - Io.unlink_dont_wait + Io.unlink_dont_wait ~sw ~on_exn:(fun exn -> [%log.warn "Unlinking previous mapping after gc, failed with error %s" @@ -191,7 +191,7 @@ module Make (Args : Gc_args.S) = struct (* Unlink current gc's result.*) let result = Irmin_pack.Layout.V4.gc_result ~root ~generation in - Io.unlink_dont_wait + Io.unlink_dont_wait ~sw ~on_exn:(fun exn -> [%log.warn "Unlinking current gc's result after gc, failed with error %s" @@ -216,7 +216,8 @@ module Make (Args : Gc_args.S) = struct let open Result_syntax in let read_file () = let path = Irmin_pack.Layout.V4.gc_result ~root ~generation in - let* io = Io.open_ ~path ~readonly:true in + Eio.Switch.run @@ fun sw -> + let* io = Io.open_ ~sw ~path ~readonly:true in let* len = Io.read_size io in let len = Int63.to_int len in let* string = Io.read_to_string io ~off:Int63.zero ~len in @@ -235,7 +236,7 @@ module Make (Args : Gc_args.S) = struct let clean_after_abort t = Fm.cleanup t.fm |> Errs.log_if_error "clean_after_abort" - let finalise ~wait t = + let finalise ~sw ~wait t = match t.resulting_stats with | Some partial_stats -> Ok (`Finalised partial_stats) | None -> ( @@ -264,7 +265,8 @@ module Make (Args : Gc_args.S) = struct let partial_stats = Gc_stats_main.finish_current_step partial_stats "unlink" in - if t.unlink then unlink_all t gc_results.removable_chunk_idxs; + if t.unlink then + unlink_all ~sw t gc_results.removable_chunk_idxs; let stats = let after_suffix_end_offset = diff --git a/src/irmin-pack/io/gc.mli b/src/irmin-pack/io/gc.mli index 5340b1268f..3b2938a431 100644 --- a/src/irmin-pack/io/gc.mli +++ b/src/irmin-pack/io/gc.mli @@ -25,9 +25,12 @@ module Make (** A running GC process. *) val v : - root:string -> - lower_root:string option -> - output:[ `External of string | `Root ] -> + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + root:Eio.Fs.dir_ty Eio.Path.t -> + lower_root:Eio.Fs.dir_ty Eio.Path.t option -> + output:[ `External of Eio.Fs.dir_ty Eio.Path.t | `Root ] -> generation:int -> unlink:bool -> dispatcher:Args.Dispatcher.t -> @@ -40,6 +43,7 @@ module Make (** Creates and starts a new GC process. *) val finalise : + sw:Eio.Switch.t -> wait:bool -> t -> ([> `Running | `Finalised of Stats.Latest_gc.stats ], Args.Errs.t) result diff --git a/src/irmin-pack/io/gc_worker.ml b/src/irmin-pack/io/gc_worker.ml index 3ffb748c79..b1b7212025 100644 --- a/src/irmin-pack/io/gc_worker.ml +++ b/src/irmin-pack/io/gc_worker.ml @@ -211,12 +211,12 @@ module Make (Args : Gc_args.S) = struct type gc_output = (gc_results, Args.Errs.t) result [@@deriving irmin] - let run ~lower_root ~generation ~new_files_path root commit_key + let run ~sw ~fs ~lower_root ~generation ~new_files_path root commit_key new_suffix_start_offset = let open Result_syntax in let config = - Irmin_pack.Conf.init ~fresh:false ~readonly:true ~lru_size:0 ~lower_root - root + Irmin_pack.Conf.init ~sw ~fs ~fresh:false ~readonly:true ~lru_size:0 + ~lower_root root in (* Step 1. Open the files *) @@ -226,7 +226,7 @@ module Make (Args : Gc_args.S) = struct report_old_file_sizes ~root ~generation:(generation - 1) stats |> ignore in - let fm = Fm.open_ro config |> Errs.raise_if_error in + let fm = Fm.open_ro ~sw ~fs config |> Errs.raise_if_error in Errors.finalise_exn (fun _outcome -> Fm.close fm |> Errs.log_if_error "GC: Close File_manager") @@ fun () -> @@ -268,7 +268,9 @@ module Make (Args : Gc_args.S) = struct in let data = Irmin_pack.Layout.V4.prefix ~root:new_files_path ~generation in let mapping_size = - let prefix = Sparse.Ao.create ~mapping ~data |> Errs.raise_if_error in + let prefix = + Sparse.Ao.create ~sw ~mapping ~data |> Errs.raise_if_error + in (* Step 5. Transfer to the new prefix, flush and close. *) [%log.debug "GC: transfering to the new prefix"]; stats := Gc_stats_worker.finish_current_step !stats "prefix: transfer"; @@ -293,7 +295,8 @@ module Make (Args : Gc_args.S) = struct Gc_stats_worker.finish_current_step !stats "prefix: rewrite commit parents"; let prefix = - Sparse.Wo.open_wo ~mapping_size ~mapping ~data |> Errs.raise_if_error + Sparse.Wo.open_wo ~sw ~mapping_size ~mapping ~data + |> Errs.raise_if_error in Errors.finalise_exn (fun _outcome -> Sparse.Wo.fsync prefix @@ -413,10 +416,10 @@ module Make (Args : Gc_args.S) = struct stats; } - let write_gc_output ~root ~generation output = + let write_gc_output ~sw ~root ~generation output = let open Result_syntax in let path = Irmin_pack.Layout.V4.gc_result ~root ~generation in - let* io = Io.create ~path ~overwrite:true in + let* io = Io.create ~sw ~path ~overwrite:true in let out = Irmin.Type.to_json_string gc_output_t output in let* () = Io.write_string io ~off:Int63.zero out in let* () = Io.fsync io in @@ -424,15 +427,16 @@ module Make (Args : Gc_args.S) = struct (* No one catches errors when this function terminates. Write the result in a file and terminate. *) - let run_and_output_result ~lower_root ~generation ~new_files_path root + let run_and_output_result ~fs ~lower_root ~generation ~new_files_path root commit_key new_suffix_start_offset = + Eio.Switch.run @@ fun sw -> let result = Errs.catch (fun () -> - run ~lower_root ~generation ~new_files_path root commit_key + run ~sw ~fs ~lower_root ~generation ~new_files_path root commit_key new_suffix_start_offset) in Errs.log_if_error "gc run" result; - let write_result = write_gc_output ~root ~generation result in + let write_result = write_gc_output ~sw ~root ~generation result in write_result |> Errs.log_if_error "writing gc output" (* No need to raise or log if [result] is [Error _], we've written it in the file. *) diff --git a/src/irmin-pack/io/gc_worker.mli b/src/irmin-pack/io/gc_worker.mli index 5257f5b9be..4e6bc6c0fe 100644 --- a/src/irmin-pack/io/gc_worker.mli +++ b/src/irmin-pack/io/gc_worker.mli @@ -24,10 +24,11 @@ module Make module Args : Gc_args.S val run_and_output_result : - lower_root:string option -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + lower_root:Eio.Fs.dir_ty Eio.Path.t option -> generation:int -> - new_files_path:string -> - string -> + new_files_path:Eio.Fs.dir_ty Eio.Path.t -> + Eio.Fs.dir_ty Eio.Path.t -> Args.key -> int63 -> unit diff --git a/src/irmin-pack/io/io_intf.ml b/src/irmin-pack/io/io_intf.ml index c0cff7f66d..061c9dc3e1 100644 --- a/src/irmin-pack/io/io_intf.ml +++ b/src/irmin-pack/io/io_intf.ml @@ -64,8 +64,18 @@ module type S = sig {2 Life Cycle} *) - val create : path:string -> overwrite:bool -> (t, [> create_error ]) result - val open_ : path:string -> readonly:bool -> (t, [> open_error ]) result + val create : + sw:Eio.Switch.t -> + path:Eio.Fs.dir_ty Eio.Path.t -> + overwrite:bool -> + (t, [> create_error ]) result + + val open_ : + sw:Eio.Switch.t -> + path:Eio.Fs.dir_ty Eio.Path.t -> + readonly:bool -> + (t, [> open_error ]) result + val close : t -> (unit, [> close_error ]) result (** {2 Write Functions} *) @@ -78,16 +88,23 @@ module type S = sig write. *) val move_file : - src:string -> dst:string -> (unit, [> `Sys_error of string ]) result + src:Eio.Fs.dir_ty Eio.Path.t -> + dst:Eio.Fs.dir_ty Eio.Path.t -> + (unit, [> `Sys_error of string ]) result val copy_file : - src:string -> dst:string -> (unit, [> `Sys_error of string ]) result + src:Eio.Fs.dir_ty Eio.Path.t -> + dst:Eio.Fs.dir_ty Eio.Path.t -> + (unit, [> `Sys_error of string ]) result + + val mkdir : Eio.Fs.dir_ty Eio.Path.t -> (unit, [> mkdir_error ]) result + val rmdir : Eio.Fs.dir_ty Eio.Path.t -> unit - val mkdir : string -> (unit, [> mkdir_error ]) result - val rmdir : string -> unit - val unlink : string -> (unit, [> `Sys_error of string ]) result + val unlink : + Eio.Fs.dir_ty Eio.Path.t -> (unit, [> `Sys_error of string ]) result - val unlink_dont_wait : on_exn:(exn -> unit) -> string -> unit + val unlink_dont_wait : + on_exn:(exn -> unit) -> sw:Eio.Switch.t -> Eio.Fs.dir_ty Eio.Path.t -> unit (** [unlink_dont_wait file] attempts to unlink the named file but doesn't wait for the completion of the unlink operation. @@ -112,7 +129,7 @@ module type S = sig syscalls. *) val size_of_path : - string -> + Eio.Fs.dir_ty Eio.Path.t -> ( int63, [> `Io_misc of misc_error | `No_such_file_or_directory of string @@ -120,14 +137,15 @@ module type S = sig result val classify_path : - string -> [> `File | `Directory | `No_such_file_or_directory | `Other ] + Eio.Fs.dir_ty Eio.Path.t -> + [> `File | `Directory | `No_such_file_or_directory | `Other ] - val readdir : string -> string list + val readdir : Eio.Fs.dir_ty Eio.Path.t -> string list (** {1 MISC.} *) val readonly : t -> bool - val path : t -> string + val path : t -> Eio.Fs.dir_ty Eio.Path.t val page_size : int (** {1 Unsafe Functions} diff --git a/src/irmin-pack/io/lower.ml b/src/irmin-pack/io/lower.ml index 6799a11267..7742bb71f0 100644 --- a/src/irmin-pack/io/lower.ml +++ b/src/irmin-pack/io/lower.ml @@ -27,11 +27,12 @@ struct module Sparse = Sparse_file.Make (Io) type t = - | Empty of { path : string } + | Empty of { path : Eio.Fs.dir_ty Eio.Path.t; sw : Eio.Switch.t } | Nonempty of { - path : string; + path : Eio.Fs.dir_ty Eio.Path.t; control : Payload.t; mutable sparse : Sparse.t option; + sw : Eio.Switch.t; } type open_error = @@ -41,47 +42,48 @@ struct | `Corrupted_control_file of string | `Unknown_major_pack_version of string ] - let v volume_path = + let v ~sw volume_path = let open Result_syntax in let* control = let path = Layout.control ~root:volume_path in match Io.classify_path path with | `File -> - let+ payload = Control.read_payload ~path in + let+ payload = Control.read_payload ~sw ~path in Some payload | `Directory | `Other | `No_such_file_or_directory -> Ok None in Ok (let path = volume_path in match control with - | None -> Empty { path } - | Some control -> Nonempty { path; control; sparse = None }) + | None -> Empty { path; sw } + | Some control -> Nonempty { path; control; sparse = None; sw }) - let create_empty volume_path = + let create_empty ~sw volume_path = let open Result_syntax in (* 0. Validate volume directory does not already exist *) let* () = match Io.classify_path volume_path with - | `Directory | `File | `Other -> Error (`File_exists volume_path) + | `Directory | `File | `Other -> + Error (`File_exists (Eio.Path.native_exn volume_path)) | `No_such_file_or_directory -> Ok () in (* 1. Make directory *) let* () = Io.mkdir volume_path in (* 2. Make empty mapping *) let* () = - Io.create ~path:(Layout.mapping ~root:volume_path) ~overwrite:true + Io.create ~sw ~path:(Layout.mapping ~root:volume_path) ~overwrite:true >>= Io.close in (* 3. Make empty data *) let* () = - Io.create ~path:(Layout.data ~root:volume_path) ~overwrite:true + Io.create ~sw ~path:(Layout.data ~root:volume_path) ~overwrite:true >>= Io.close in (* TODO: handle failure to create all artifacts, either here or in a cleanup when the store starts. *) - v volume_path + v ~sw volume_path - let create_from ~src ~dead_header_size ~size lower_root = + let create_from ~sw ~src ~dead_header_size ~size lower_root = let open Result_syntax in let root = Layout.directory ~root:lower_root ~idx:0 in let data = Layout.data ~root in @@ -89,7 +91,7 @@ struct let* () = Io.mkdir root in let* () = Io.move_file ~src ~dst:data in let* mapping_end_poff = - Sparse.Wo.create_from_data ~mapping ~dead_header_size ~size ~data + Sparse.Wo.create_from_data ~sw ~mapping ~dead_header_size ~size ~data in let payload = { @@ -100,10 +102,10 @@ struct } in let control = Layout.control ~root in - Control.create_rw ~path:control ~tmp_path:None ~overwrite:false payload + Control.create_rw ~sw ~path:control ~tmp_path:None ~overwrite:false payload >>= Control.close - let path = function Empty { path } -> path | Nonempty { path; _ } -> path + let path = function Empty { path; _ } -> path | Nonempty { path; _ } -> path let control = function | Empty _ -> None @@ -119,7 +121,7 @@ struct let open_ = function | Empty _ -> Ok () (* Opening an empty volume is a no-op *) - | Nonempty ({ path = root; sparse; control; _ } as t) -> ( + | Nonempty ({ path = root; sparse; control; sw; _ } as t) -> ( match sparse with | Some _ -> Ok () (* Sparse file is already open *) | None -> @@ -127,7 +129,7 @@ struct let mapping = Layout.mapping ~root in let data = Layout.data ~root in let mapping_size = Int63.to_int control.Payload.mapping_end_poff in - let+ sparse = Sparse.open_ro ~mapping_size ~mapping ~data in + let+ sparse = Sparse.open_ro ~sw ~mapping_size ~mapping ~data in t.sparse <- Some sparse) let close = function @@ -140,7 +142,7 @@ struct let+ () = Sparse.close s in t.sparse <- None) - let identifier t = path t + let identifier t = Eio.Path.native_exn (path t) let identifier_eq ~id t = String.equal (identifier t) id let eq a b = identifier_eq ~id:(identifier b) a @@ -151,6 +153,8 @@ struct | None -> Errs.raise_error (`Invalid_volume_read (`Closed, off)) | Some s -> Sparse.read_range_exn s ~off ~min_len ~max_len b) + let get_switch = function Empty { sw; _ } | Nonempty { sw; _ } -> sw + let archive_seq ~upper_root ~generation ~is_first ~to_archive ~first_off t = let open Result_syntax in let root = path t in @@ -186,8 +190,9 @@ struct Io.size_of_path mapping | Nonempty { control; _ } -> Ok control.mapping_end_poff in + let sw = get_switch t in (* Append archived data *) - let* ao = Sparse.Ao.open_ao ~mapping_size ~mapping ~data in + let* ao = Sparse.Ao.open_ao ~sw ~mapping_size ~mapping ~data in List.iter (fun (off, seq) -> Sparse.Ao.append_seq_exn ao ~off seq) to_archive; @@ -210,7 +215,7 @@ struct Irmin_pack.Layout.V5.Volume.control_gc_tmp ~generation ~root in let* c = - Control.create_rw ~path:control_gc_tmp ~tmp_path:None ~overwrite:true + Control.create_rw ~sw ~path:control_gc_tmp ~tmp_path:None ~overwrite:true new_control in let* () = Control.close c in @@ -236,21 +241,24 @@ struct match Io.classify_path control_tmp with | `File -> Io.move_file ~src:control_tmp ~dst:control | `No_such_file_or_directory -> - [%log.info "No tmp volume control file to swap. %s" control]; + [%log.info + "No tmp volume control file to swap. %s" + (Fmt.str "%a" Eio.Path.pp control)]; Ok () | `Directory | `Other -> assert false let cleanup ~generation t = + let path = path t in let clean filename = match Irmin_pack.Layout.Classification.Volume.v filename with | `Control_tmp g when g = generation -> swap ~generation t | `Control_tmp g when g <> generation -> - Io.unlink filename + Io.unlink Eio.Path.(path / filename) |> Errs.log_if_error (Printf.sprintf "unlink %s" filename) |> Result.ok | _ -> Ok () in - path t |> Io.readdir |> List.iter_result clean + Io.readdir path |> List.iter_result clean end module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct @@ -259,10 +267,11 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct module Volume = Make_volume (Io) (Errs) type t = { - root : string; + root : Eio.Fs.dir_ty Eio.Path.t; mutable readonly : bool; mutable volumes : Volume.t array; mutable open_volume : Volume.t option; + sw : Eio.Switch.t; } type open_error = [ Volume.open_error | `Volume_missing of string ] @@ -295,9 +304,9 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct let path = Layout.directory ~root ~idx:i in match Io.classify_path path with | `File | `Other | `No_such_file_or_directory -> - raise (LoadVolumeError (`Volume_missing path)) + raise (LoadVolumeError (`Volume_missing (Eio.Path.native_exn path))) | `Directory -> ( - match Volume.v path with + match Volume.v ~sw:t.sw path with | Error e -> raise (LoadVolumeError e) | Ok v -> v) in @@ -307,9 +316,9 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct t.volumes <- volumes; Ok t - let v ~readonly ~volume_num root = + let v ~sw ~readonly ~volume_num root = load_volumes ~volume_num - { root; readonly; volumes = [||]; open_volume = None } + { root; readonly; volumes = [||]; open_volume = None; sw } let reload ~volume_num t = let open Result_syntax in @@ -336,7 +345,7 @@ module Make (Io : Io_intf.S) (Errs : Io_errors.S with module Io = Io) = struct let next_idx = volume_num t in Layout.directory ~root:t.root ~idx:next_idx in - let* vol = Volume.create_empty volume_path in + let* vol = Volume.create_empty ~sw:t.sw volume_path in t.volumes <- Array.append t.volumes [| vol |]; Ok vol diff --git a/src/irmin-pack/io/lower_intf.ml b/src/irmin-pack/io/lower_intf.ml index 88972cabac..c7a232295c 100644 --- a/src/irmin-pack/io/lower_intf.ml +++ b/src/irmin-pack/io/lower_intf.ml @@ -32,10 +32,11 @@ module type Volume = sig | `Corrupted_control_file of string | `Unknown_major_pack_version of string ] - val v : string -> (t, [> open_error ]) result + val v : + sw:Eio.Switch.t -> Eio.Fs.dir_ty Eio.Path.t -> (t, [> open_error ]) result (** [v path] loads the volume at [path] in read-only. *) - val path : t -> string + val path : t -> Eio.Fs.dir_ty Eio.Path.t (** [path t] is the directory that contains the volume. *) val is_empty : t -> bool @@ -66,7 +67,11 @@ module type S = sig | `Invalid_parent_directory ] val v : - readonly:bool -> volume_num:int -> string -> (t, [> open_error ]) result + sw:Eio.Switch.t -> + readonly:bool -> + volume_num:int -> + Eio.Fs.dir_ty Eio.Path.t -> + (t, [> open_error ]) result (** [v ~readonly ~volume_num lower_root] loads all volumes located in the directory [lower_root]. @@ -121,7 +126,7 @@ module type S = sig to temporarily allow RW before calling {!archive_seq_exn}. *) val archive_seq_exn : - upper_root:string -> + upper_root:Eio.Fs.dir_ty Eio.Path.t -> generation:int -> to_archive:(int63 * string Seq.t) list -> t -> @@ -152,10 +157,11 @@ module type S = sig [ open_error | close_error | add_error | `Sys_error of string ] val create_from : - src:string -> + sw:Eio.Switch.t -> + src:Eio.Fs.dir_ty Eio.Path.t -> dead_header_size:int -> size:Int63.t -> - string -> + Eio.Fs.dir_ty Eio.Path.t -> (unit, [> create_error ]) result (** [create_from ~src ~dead_header_size ~size lower_root] initializes the first lower volume in the directory [lower_root] by moving the suffix file diff --git a/src/irmin-pack/io/snapshot.ml b/src/irmin-pack/io/snapshot.ml index fdfccf3c67..51806a8121 100644 --- a/src/irmin-pack/io/snapshot.ml +++ b/src/irmin-pack/io/snapshot.ml @@ -25,10 +25,10 @@ module Make (Args : Args) = struct module Io = Fm.Io let rm_index path = - let path_index = Filename.concat path "index" in + let path_index = Eio.Path.(path / "index") in Io.readdir path_index |> List.iter (fun name -> - match Io.unlink (Filename.concat path_index name) with + match Io.unlink Eio.Path.(path_index / name) with | Ok () -> () | Error (`Sys_error msg) -> failwith msg); Io.rmdir path_index; @@ -60,11 +60,11 @@ module Make (Args : Args) = struct contents_pack : read Contents_pack.t; } - let v config contents_pack inode_pack = + let v ~sw ~fs config contents_pack inode_pack = (* In order to read from the pack files, we need to open at least two 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 fm = Fm.open_ro ~sw ~fs config |> 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 } @@ -202,7 +202,8 @@ module Make (Args : Args) = struct let run_on_disk path t f_contents f_inodes root_key = [%log.info "iter on disk"]; let index = - Index.v ~fresh:true ~readonly:false ~log_size:t.log_size path + Index.v ~fresh:true ~readonly:false ~log_size:t.log_size + (Eio.Path.native_exn path) in let visited h = Index.mem index h in let set_visit h = @@ -250,7 +251,7 @@ module Make (Args : Args) = struct module Index = Index.Make (Pack_index.Key) (Value) (Io_index) (Index.Cache.Unbounded) - type path = string + type path = Eio.Fs.dir_ty Eio.Path.t type t = { inode_pack : read Inode_pack.t; @@ -307,9 +308,12 @@ module Make (Args : Args) = struct let save_on_disk log_size path = (* Make sure we are not reusing the same index as irmin-pack. *) - let path = path ^ "_tmp" in - [%log.info "save on disk: %s" path]; - let index = Index.v ~fresh:true ~readonly:false ~log_size path in + let path, basename = Option.get @@ Eio.Path.split path in + let path = Eio.Path.(path / (basename ^ "_tmp")) in + [%log.info "save on disk: %a" Eio.Path.pp path]; + let index = + Index.v ~fresh:true ~readonly:false ~log_size (Eio.Path.native_exn path) + in let set_visit h k = let offset, length = diff --git a/src/irmin-pack/io/snapshot_intf.ml b/src/irmin-pack/io/snapshot_intf.ml index 3815d103cc..b40642749a 100644 --- a/src/irmin-pack/io/snapshot_intf.ml +++ b/src/irmin-pack/io/snapshot_intf.ml @@ -44,10 +44,16 @@ module type Sigs = sig module Export : sig type t - val v : Irmin.config -> read Contents_pack.t -> read Inode.Pack.t -> t + val v : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + Irmin.config -> + read Contents_pack.t -> + read Inode.Pack.t -> + t val run : - ?on_disk:[ `Path of string ] -> + ?on_disk:[ `Path of Eio.Fs.dir_ty Eio.Path.t ] -> t -> (Contents_pack.value -> unit) -> (Inode.Snapshot.inode -> unit) -> @@ -69,7 +75,7 @@ module type Sigs = sig type t val v : - ?on_disk:[ `Path of string | `Reuse ] -> + ?on_disk:[ `Path of Eio.Fs.dir_ty Eio.Path.t | `Reuse ] -> int -> read Contents_pack.t -> read Inode.Pack.t -> diff --git a/src/irmin-pack/io/sparse_file.ml b/src/irmin-pack/io/sparse_file.ml index 89d2b42dcf..98367ed8b1 100644 --- a/src/irmin-pack/io/sparse_file.ml +++ b/src/irmin-pack/io/sparse_file.ml @@ -23,7 +23,12 @@ type int64_bigarray = (int64, Bigarray.int64_elt, Bigarray.c_layout) BigArr1.t module Int64_mmap (Io : Io_intf.S) : sig type t - val open_ro : fn:string -> sz:int -> (t, [> Io.open_error ]) result + val open_ro : + sw:Eio.Switch.t -> + fn:Eio.Fs.dir_ty Eio.Path.t -> + sz:int -> + (t, [> Io.open_error ]) result + val length : t -> int val get : t -> int -> Int64.t val close : t -> (unit, [> Io.close_error ]) result @@ -33,10 +38,10 @@ end = struct let sector_size = 512 let length t = BigArr1.dim t.arr - let open_ro ~fn ~sz = + let open_ro ~sw ~fn ~sz = let open Result_syntax in assert (Io.classify_path fn = `File); - let+ fd = Io.open_ ~path:fn ~readonly:true in + let+ fd = Io.open_ ~sw ~path:fn ~readonly:true in let size = sz / 8 in let arr = BigArr1.create Bigarray.Int64 Bigarray.c_layout size in let loaded = Array.make (1 + (sz / sector_size)) false in @@ -76,17 +81,17 @@ module Make (Io : Io_intf.S) = struct type t = Int64_mmap.t - let open_map ~path ~size = + let open_map ~sw ~path ~size = match Io.classify_path path with | `File -> let open Result_syntax in - let* mmap = Int64_mmap.open_ro ~fn:path ~sz:size in + let* mmap = Int64_mmap.open_ro ~sw ~fn:path ~sz:size in if Int64_mmap.length mmap mod 3 = 0 then Ok mmap else Error (`Corrupted_mapping_file (__FILE__ ^ ": mapping mmap size did not meet size requirements")) - | _ -> Error (`No_such_file_or_directory path) + | _ -> Error (`No_such_file_or_directory (Eio.Path.native_exn path)) let close = Int64_mmap.close let entry_count t = Int64_mmap.length t / 3 @@ -129,14 +134,14 @@ module Make (Io : Io_intf.S) = struct type t = { mapping : Mapping_file.t; data : Io.t } - let open_ ~readonly ~mapping_size ~mapping ~data = + let open_ ~sw ~readonly ~mapping_size ~mapping ~data = let open Result_syntax in - let* mapping = Mapping_file.open_map ~path:mapping ~size:mapping_size in - let+ data = Io.open_ ~path:data ~readonly in + let* mapping = Mapping_file.open_map ~sw ~path:mapping ~size:mapping_size in + let+ data = Io.open_ ~sw ~path:data ~readonly in { mapping; data } - let open_ro ~mapping_size ~mapping ~data = - open_ ~readonly:true ~mapping_size ~mapping ~data + let open_ro ~sw ~mapping_size ~mapping ~data = + open_ ~sw ~readonly:true ~mapping_size ~mapping ~data let close t = let open Result_syntax in @@ -195,8 +200,8 @@ module Make (Io : Io_intf.S) = struct module Wo = struct type nonrec t = t - let open_wo ~mapping_size ~mapping ~data = - open_ ~readonly:false ~mapping_size ~mapping ~data + let open_wo ~sw ~mapping_size ~mapping ~data = + open_ ~sw ~readonly:false ~mapping_size ~mapping ~data let write_exn t ~off ~len str = let poff, max_entry_len = get_poff t ~off in @@ -206,14 +211,14 @@ module Make (Io : Io_intf.S) = struct let fsync t = Io.fsync t.data let close = close - let create_from_data ~mapping ~dead_header_size ~size ~data:_ = + let create_from_data ~sw ~mapping ~dead_header_size ~size ~data:_ = let open Result_syntax in let entry = make_entry ~off:Int64.zero ~poff:(Int64.of_int dead_header_size) ~len:(Int63.to_int64 size) in - let* mapping = Io.create ~path:mapping ~overwrite:false in + let* mapping = Io.create ~sw ~path:mapping ~overwrite:false in let* () = Io.write_string mapping ~off:Int63.zero entry in let+ () = Io.close mapping in Int63.of_int (String.length entry) @@ -227,19 +232,19 @@ module Make (Io : Io_intf.S) = struct let end_off t = t.end_off let mapping_size t = Ao.end_poff t.mapping - let create ~mapping ~data = + let create ~sw ~mapping ~data = let open Result_syntax in let ao_create path = Ao.create_rw ~path ~overwrite:false in - let* mapping = ao_create mapping in - let+ data = ao_create data in + let* mapping = ao_create ~sw mapping in + let+ data = ao_create ~sw data in { mapping; data; end_off = Int63.zero } - let open_ao ~mapping_size ~mapping ~data = + let open_ao ~sw ~mapping_size ~mapping ~data = let open Result_syntax in let ao_open ~end_poff path = Ao.open_rw ~path ~end_poff ~dead_header_size:0 in - let* ao_mapping = ao_open ~end_poff:mapping_size mapping in + let* ao_mapping = ao_open ~sw ~end_poff:mapping_size mapping in let* end_off, end_poff = if mapping_size <= Int63.zero then Ok (Int63.zero, Int63.zero) else @@ -256,7 +261,7 @@ module Make (Io : Io_intf.S) = struct let open Int63.Syntax in (end_off + len, end_poff + len) in - let+ ao_data = ao_open ~end_poff data in + let+ ao_data = ao_open ~sw ~end_poff data in { mapping = ao_mapping; data = ao_data; end_off } let check_offset_exn { end_off; _ } ~off = diff --git a/src/irmin-pack/io/sparse_file_intf.ml b/src/irmin-pack/io/sparse_file_intf.ml index 4e335f53d7..943bb6b13b 100644 --- a/src/irmin-pack/io/sparse_file_intf.ml +++ b/src/irmin-pack/io/sparse_file_intf.ml @@ -24,9 +24,10 @@ module type S = sig type open_error := [ Io.open_error | `Corrupted_mapping_file of string ] val open_ro : + sw:Eio.Switch.t -> mapping_size:int -> - mapping:string -> - data:string -> + mapping:Eio.Fs.dir_ty Eio.Path.t -> + data:Eio.Fs.dir_ty Eio.Path.t -> (t, [> open_error ]) result (** [open_ro ~mapping_size ~mapping ~data] returns a new read-only view of the sparse file, represented on disk by two files named [mapping] and [data]. @@ -67,9 +68,10 @@ module type S = sig type t val open_wo : + sw:Eio.Switch.t -> mapping_size:int -> - mapping:string -> - data:string -> + mapping:Eio.Fs.dir_ty Eio.Path.t -> + data:Eio.Fs.dir_ty Eio.Path.t -> (t, [> open_error ]) result (** [open_wo ~mapping_size ~mapping ~data] returns a write-only instance of the sparse file. @@ -90,10 +92,11 @@ module type S = sig (** Close the underlying files. *) val create_from_data : - mapping:string -> + sw:Eio.Switch.t -> + mapping:Eio.Fs.dir_ty Eio.Path.t -> dead_header_size:int -> size:Int63.t -> - data:string -> + data:Eio.Fs.dir_ty Eio.Path.t -> (int63, [> Io.create_error | Io.write_error | Io.close_error ]) result (** [create_from_data ~mapping ~dead_header_size ~size ~data] initializes a new sparse file on disk from the existing file [data], by creating the @@ -119,14 +122,18 @@ module type S = sig the file again. *) val create : - mapping:string -> data:string -> (t, [> Io.create_error ]) result + sw:Eio.Switch.t -> + mapping:Eio.Fs.dir_ty Eio.Path.t -> + data:Eio.Fs.dir_ty Eio.Path.t -> + (t, [> Io.create_error ]) result (** [create ~mapping ~data] initializes a new empty sparse file, represented on disk by two files named [mapping] and [data]. *) val open_ao : + sw:Eio.Switch.t -> mapping_size:Int63.t -> - mapping:string -> - data:string -> + mapping:Eio.Fs.dir_ty Eio.Path.t -> + data:Eio.Fs.dir_ty Eio.Path.t -> ( t, [> Io.open_error | `Closed diff --git a/src/irmin-pack/io/store.ml b/src/irmin-pack/io/store.ml index bef47fe962..7c08b58a19 100644 --- a/src/irmin-pack/io/store.ml +++ b/src/irmin-pack/io/store.ml @@ -121,8 +121,8 @@ struct module AW = Atomic_write.Make_persistent (Io) (Key) (Val) include Atomic_write.Closeable (AW) - let v ?fresh ?readonly path = - AW.v ?fresh ?readonly path |> make_closeable + let v ~sw ?fresh ?readonly path = + AW.v ~sw ?fresh ?readonly path |> make_closeable end module Slice = Irmin.Backend.Slice.Make (Contents) (Node) (Commit) @@ -160,6 +160,8 @@ struct during_batch : bool Atomic.t; running_gc : running_gc option Atomic.t; lock : Eio.Mutex.t; + fs : Eio.Fs.dir_ty Eio.Path.t; + sw : Eio.Switch.t; } let pp_key = Irmin.Type.pp XKey.t @@ -170,22 +172,26 @@ struct let config t = t.config let v config = - let root = Irmin_pack.Conf.root config in + let sw = Conf.switch config in + let fs = Conf.fs config in + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let fresh = Irmin_pack.Conf.fresh config in let fm = let readonly = Irmin_pack.Conf.readonly config in - if readonly then File_manager.open_ro config |> Errs.raise_if_error + if readonly then + File_manager.open_ro ~sw ~fs config |> Errs.raise_if_error else match (Io.classify_path root, fresh) with | `No_such_file_or_directory, _ -> - File_manager.create_rw ~overwrite:false config + File_manager.create_rw ~sw ~fs ~overwrite:false config |> Errs.raise_if_error | `Directory, true -> - File_manager.create_rw ~overwrite:true config + File_manager.create_rw ~sw ~fs ~overwrite:true config |> Errs.raise_if_error | `Directory, false -> - File_manager.open_rw config |> Errs.raise_if_error - | (`File | `Other), _ -> Errs.raise_error (`Not_a_directory root) + File_manager.open_rw ~sw ~fs config |> Errs.raise_if_error + | (`File | `Other), _ -> + Errs.raise_error (`Not_a_directory (Eio.Path.native_exn root)) in let dict = File_manager.dict fm in let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in @@ -194,11 +200,11 @@ struct let node = Node.CA.v ~config ~fm ~dict ~dispatcher ~lru in let commit = Commit.CA.v ~config ~fm ~dict ~dispatcher ~lru in let branch = - let root = Conf.root config in + let root = Eio.Path.(fs / Conf.root config) in let fresh = Conf.fresh config in let readonly = Conf.readonly config in let path = Irmin_pack.Layout.V4.branch ~root in - Branch.v ~fresh ~readonly path + Branch.v ~sw ~fresh ~readonly path in let during_batch = Atomic.make false in let running_gc = Atomic.make None in @@ -215,6 +221,8 @@ struct running_gc; dispatcher; lock; + fs; + sw; } let flush t = File_manager.flush ?hook:None t.fm |> Errs.raise_if_error @@ -248,7 +256,8 @@ struct (Irmin.Type.to_string XKey.t key)) | Some (k, _kind) -> Ok k) - let start ~unlink ~use_auto_finalisation ~output t commit_key = + let start ~fs ~domain_mgr ~unlink ~use_auto_finalisation ~output t + commit_key = let open Result_syntax in [%log.info "GC: Starting on %a" pp_key commit_key]; let* () = @@ -256,7 +265,7 @@ struct else Ok () in let* commit_key = direct_commit_key t commit_key in - let root = Conf.root t.config in + let root = Eio.Path.(t.fs / Conf.root t.config) in let* () = if not (is_allowed t) then Error (`Gc_disallowed "Store does not support GC") @@ -265,16 +274,21 @@ struct Eio.Mutex.use_rw ~protect:false t.lock @@ fun () -> let current_generation = File_manager.generation t.fm in let next_generation = current_generation + 1 in - let lower_root = Conf.lower_root t.config in + let lower_root = + Option.map + (fun path -> Eio.Path.(t.fs / path)) + (Conf.lower_root t.config) + in 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 ~output commit_key + Gc.v ~sw:t.sw ~fs ~domain_mgr ~root ~lower_root + ~generation:next_generation ~unlink ~dispatcher:t.dispatcher + ~fm:t.fm ~contents:t.contents ~node:t.node ~commit:t.commit + ~output commit_key in Atomic.set t.running_gc (Some { gc; use_auto_finalisation }); Ok () - let start_exn ?(unlink = true) ?(output = `Root) + let start_exn ~fs ~domain_mgr ?(unlink = true) ?(output = `Root) ~use_auto_finalisation t commit_key = match Atomic.get t.running_gc with | Some _ -> @@ -282,7 +296,8 @@ struct false | None -> ( let result = - start ~unlink ~use_auto_finalisation ~output t commit_key + start ~fs ~domain_mgr ~unlink ~use_auto_finalisation ~output t + commit_key in match result with Ok _ -> true | Error e -> Errs.raise_error e) @@ -293,7 +308,7 @@ struct | Some { gc; _ } -> if Atomic.get t.during_batch then Error `Gc_forbidden_during_batch - else Gc.finalise ~wait gc + else Gc.finalise ~sw:t.sw ~wait gc in match result with | Ok (`Finalised _ as x) -> @@ -346,7 +361,7 @@ struct let key = Pack_key.v_direct ~offset ~length entry.hash in Some key) - let create_one_commit_store t commit_key path = + let create_one_commit_store ~fs ~domain_mgr t commit_key path = let () = match Io.classify_path path with | `Directory -> () @@ -360,8 +375,8 @@ struct (* The GC action here does not matter, since we'll not fully finalise it *) let launched = - start_exn ~use_auto_finalisation:false ~output:(`External path) t - commit_key + start_exn ~fs ~domain_mgr ~use_auto_finalisation:false + ~output:(`External path) t commit_key in let () = if not launched then Errs.raise_error `Forbidden_during_gc @@ -373,14 +388,19 @@ struct Eio.Mutex.use_rw ~protect:false t.lock @@ fun () -> Gc.finalise_without_swap gc in - let config = Irmin.Backend.Conf.add t.config Conf.Key.root path in + let config = + (* TODO: why native_exn? *) + Irmin.Backend.Conf.add t.config Conf.Key.root + (Eio.Path.native_exn path) + in let () = - File_manager.create_one_commit_store t.fm config gced commit_key + File_manager.create_one_commit_store ~fs t.fm config gced + commit_key |> Errs.raise_if_error in let branch_path = Irmin_pack.Layout.V4.branch ~root:path in let branch_store = - Branch.v ~fresh:true ~readonly:false branch_path + Branch.v ~sw:t.sw ~fresh:true ~readonly:false branch_path in Branch.close branch_store end @@ -630,14 +650,15 @@ struct let finalise_exn = X.Repo.Gc.finalise_exn - let start_exn ?unlink t = - X.Repo.Gc.start_exn ?unlink ~use_auto_finalisation:false t + let start_exn ~fs ~domain_mgr ?unlink t = + X.Repo.Gc.start_exn ~fs ~domain_mgr ?unlink ~use_auto_finalisation:false + t - let start repo commit_key = + let start ~fs ~domain_mgr repo commit_key = try let started = - X.Repo.Gc.start_exn ~unlink:true ~use_auto_finalisation:true repo - commit_key + X.Repo.Gc.start_exn ~fs ~domain_mgr ~unlink:true + ~use_auto_finalisation:true repo commit_key in Ok started with exn -> catch_errors "Start GC" exn @@ -655,8 +676,8 @@ struct | `Finalised stats -> Ok (Some stats) with exn -> catch_errors "Wait for GC" exn - let run ?(finished = fun _ -> ()) repo commit_key = - let started = start repo commit_key in + let run ~fs ~domain_mgr ?(finished = fun _ -> ()) repo commit_key = + let started = start ~fs ~domain_mgr repo commit_key in match started with | Ok r -> if r then @@ -710,7 +731,9 @@ struct [%log.debug "Iterate over a tree"]; let contents = X.Repo.contents_t repo in let nodes = X.Repo.node_t repo |> snd in - let export = S.Export.v repo.config contents nodes in + let export = + S.Export.v ~sw:repo.sw ~fs:repo.fs repo.config contents nodes + in let f_contents x = f (Blob x) in let f_nodes x = f (Inode x) in match root_key with diff --git a/src/irmin-pack/io/store_intf.ml b/src/irmin-pack/io/store_intf.ml index ceb1ec671c..00220bac86 100644 --- a/src/irmin-pack/io/store_intf.ml +++ b/src/irmin-pack/io/store_intf.ml @@ -46,6 +46,8 @@ module type S = sig ([> `No_error ], [> `Cannot_fix of string ]) result val traverse_pack_file : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> [ `Reconstruct_index of [ `In_place | `Output of string ] | `Check_index | `Check_and_fix_index ] -> @@ -53,6 +55,8 @@ module type S = sig unit val test_traverse_pack_file : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> [ `Reconstruct_index of [ `In_place | `Output of string ] | `Check_index | `Check_and_fix_index ] -> @@ -101,7 +105,13 @@ module type S = sig (** [flush t] flush read-write pack on disk. Raises [RO_Not_Allowed] if called by a readonly instance.*) - val create_one_commit_store : repo -> commit_key -> string -> unit + val create_one_commit_store : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + repo -> + commit_key -> + Eio.Fs.dir_ty Eio.Path.t -> + unit (** [create_one_commit_store t key path] creates a new store at [path] from the existing one, containing only one commit, specified by the [key]. Note that this operation is blocking. @@ -119,7 +129,13 @@ module type S = sig (** {1 Low-level API} *) - val start_exn : ?unlink:bool -> repo -> commit_key -> bool + val start_exn : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + ?unlink:bool -> + repo -> + commit_key -> + bool (** [start_exn] tries to start the GC process and returns true if the GC is launched. If a GC is already running, a new one is not started. @@ -157,6 +173,8 @@ module type S = sig logging *) val run : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> ?finished:((Stats.Latest_gc.stats, msg) result -> unit) -> repo -> commit_key -> @@ -237,7 +255,7 @@ module type S = sig [@@deriving irmin] val export : - ?on_disk:[ `Path of string ] -> + ?on_disk:[ `Path of Eio.Fs.dir_ty Eio.Path.t ] -> repo -> (t -> unit) -> root_key:Tree.kinded_key -> @@ -267,7 +285,10 @@ module type S = sig module Import : sig type process - val v : ?on_disk:[ `Path of string | `Reuse ] -> repo -> process + val v : + ?on_disk:[ `Path of Eio.Fs.dir_ty Eio.Path.t | `Reuse ] -> + repo -> + process (** [v ?on_disk repo] create a [snaphot] instance. The traversal requires an index to keep track of visited elements. diff --git a/src/irmin-pack/io/traverse_pack_file.ml b/src/irmin-pack/io/traverse_pack_file.ml index 1b0215368d..ddd338270c 100644 --- a/src/irmin-pack/io/traverse_pack_file.ml +++ b/src/irmin-pack/io/traverse_pack_file.ml @@ -70,6 +70,8 @@ end module Make (Args : Args) : sig val run : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> [ `Reconstruct_index of [ `In_place | `Output of string ] | `Check_index | `Check_and_fix_index ] -> @@ -77,6 +79,8 @@ module Make (Args : Args) : sig unit val test : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> [ `Reconstruct_index of [ `In_place | `Output of string ] | `Check_index | `Check_and_fix_index ] -> @@ -115,22 +119,26 @@ end = struct false module Index_reconstructor = struct - let create ~dest config = + let create ~fs ~dest config = let dest = match dest with | `Output path -> + let path = Eio.Path.(fs / path) in if Io.classify_path path <> `No_such_file_or_directory then Fmt.invalid_arg "Can't reconstruct index. File already exits."; path | `In_place -> if Conf.readonly config then raise Irmin_pack.RO_not_allowed; - Conf.root config + Eio.Path.(fs / Conf.root config) in let log_size = Conf.index_log_size config in [%log.app "Beginning index reconstruction with parameters: { log_size = %d }" log_size]; - let index = Index.v_exn ~fresh:true ~readonly:false ~log_size dest in + let index = + Index.v_exn ~fresh:true ~readonly:false ~log_size + (Eio.Path.native_exn dest) + in index let iter_pack_entry ~always index key data = @@ -364,7 +372,7 @@ end = struct refill_buffer ~from:Int63.zero; loop_entries ~buffer_off:0 Int63.zero None - let run_or_test ~initial_buffer_size mode config = + let run_or_test ~sw ~fs ~initial_buffer_size mode config = let always = Conf.indexing_strategy config |> Irmin_pack.Indexing_strategy.is_minimal @@ -374,7 +382,7 @@ end = struct match mode with | `Reconstruct_index dest -> let open Index_reconstructor in - let v = create ~dest config in + let v = create ~fs ~dest config in (iter_pack_entry ~always v, finalise v, "Reconstructing index") | `Check_index -> let open Index_checker in @@ -386,7 +394,7 @@ end = struct (iter_pack_entry ~always v, finalise v, "Checking and fixing index") in let run_duration = Io.Clock.counter () in - let fm = File_manager.open_ro config |> Errs.raise_if_error in + let fm = File_manager.open_ro ~sw ~fs config |> Errs.raise_if_error in let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in let total = Dispatcher.end_offset dispatcher in let ingest_data progress = diff --git a/src/irmin-pack/irmin_pack_intf.ml b/src/irmin-pack/irmin_pack_intf.ml index edfebbcd26..463d5525c7 100644 --- a/src/irmin-pack/irmin_pack_intf.ml +++ b/src/irmin-pack/irmin_pack_intf.ml @@ -70,6 +70,8 @@ module type Sigs = sig module Conf = Conf val config : + sw:Eio.Switch.t -> + fs:_ Eio.Path.t -> ?fresh:bool -> ?readonly:bool -> ?lru_size:int -> @@ -79,8 +81,8 @@ module type Sigs = sig ?indexing_strategy:Indexing_strategy.t -> ?use_fsync:bool -> ?no_migrate:bool -> - ?lower_root:string option -> - string -> + ?lower_root:Eio.Fs.dir_ty Eio.Path.t option -> + Eio.Fs.dir_ty Eio.Path.t -> Irmin.config (** Configuration options for stores. See {!Irmin_pack.Conf} for more details. *) diff --git a/src/irmin-pack/layout.ml b/src/irmin-pack/layout.ml index e96d49fe62..f3a255edbd 100644 --- a/src/irmin-pack/layout.ml +++ b/src/irmin-pack/layout.ml @@ -14,7 +14,9 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -let toplevel name ~root = Filename.(concat root name) +open Eio.Path + +let toplevel name ~root : Eio.Fs.dir_ty t = root / name module V1_and_v2 = struct let pack = toplevel "store.pack" @@ -53,6 +55,7 @@ end module V4 = struct let branch = toplevel "store.branches" let dict = toplevel "store.dict" + let dict_tmp = toplevel "store.dict.tmp" let control = toplevel "store.control" let control_tmp = toplevel "store.control.tmp" @@ -110,6 +113,7 @@ module Classification = struct | `Control | `Control_tmp | `Dict + | `Dict_tmp | `Gc_result of int | `Mapping of int | `Prefix of int @@ -127,6 +131,7 @@ module Classification = struct | [ "store"; "control" ] -> `Control | [ "store"; "control"; "tmp" ] -> `Control_tmp | [ "store"; "dict" ] -> `Dict + | [ "store"; "dict"; "tmp" ] -> `Dict_tmp | [ "store"; g; "out" ] when is_number g -> `Gc_result (int_of_string g) | [ "store"; g; "reachable" ] when is_number g -> `Reachable (int_of_string g) diff --git a/src/irmin-pack/unix/async.ml b/src/irmin-pack/unix/async.ml index bf2caf81a9..97497d4762 100644 --- a/src/irmin-pack/unix/async.ml +++ b/src/irmin-pack/unix/async.ml @@ -17,108 +17,49 @@ open! Irmin_pack_io.Import module Unix = struct - let kill_no_err pid = - try Unix.kill pid Sys.sigkill - with Unix.Unix_error (e, s1, s2) -> - [%log.warn - "Killing process with pid %d failed with error (%s, %s, %s)" pid - (Unix.error_message e) s1 s2] - - (** [Exit] is a stack of PIDs that will be killed [at_exit]. *) - module Exit = struct - let proc_list = Atomic.make [] - - let rec add pid = - let pids = Atomic.get proc_list in - if not (Atomic.compare_and_set proc_list pids (pid :: pids)) then add pid - - let rec remove pid = - let pids = Atomic.get proc_list in - let new_pids = List.filter (fun pid' -> pid <> pid') pids in - if not (Atomic.compare_and_set proc_list pids new_pids) then remove pid - - let () = - at_exit @@ fun () -> - let pids = Atomic.exchange proc_list [] in - List.iter kill_no_err pids - end - type outcome = [ `Success | `Cancelled | `Failure of string ] [@@deriving irmin] type status = [ `Running | `Success | `Cancelled | `Failure of string ] [@@deriving irmin] - type t = { pid : int; mutable status : status; lock : Eio.Mutex.t } - - module Exit_code = struct - let success = 0 - let unhandled_exn = 42 - end + type t = Eio.Switch.t * outcome Eio.Promise.or_exn - let async f = + let async ~sw ~domain_mgr f = + let run f () = + Logs.set_level None; + match f () with + | () -> `Success + | exception _ -> `Failure "Unhandled exception" + in Stdlib.flush_all (); - match Unix.fork () with - | 0 -> - (* Lwt_main.Exit_hooks.remove_all (); - Lwt_main.abandon_yielded_and_paused (); *) - let exit_code = - match f () with - | () -> Exit_code.success - | exception e -> - [%log.err - "Unhandled exception in child process %s" (Printexc.to_string e)]; - Exit_code.unhandled_exn - in - (* Use [Unix._exit] to avoid calling [at_exit] hooks. *) - Unix._exit exit_code - | pid -> - Exit.add pid; - { pid; status = `Running; lock = Eio.Mutex.create () } + let gc_sw_promise, gc_sw_resolver = Eio.Promise.create ~label:"gc_sw" () in + let promise = + Eio.Fiber.fork_promise ~sw (fun () -> + Eio.Switch.run @@ fun sw' -> + Eio.Promise.resolve gc_sw_resolver sw'; + Eio.Domain_manager.run domain_mgr (run f)) + in + let gc_sw = Eio.Promise.await gc_sw_promise in + (gc_sw, promise) - let status_of_process_outcome = function - | Unix.WEXITED n when n = Exit_code.success -> `Success - | Unix.WEXITED n when n = Exit_code.unhandled_exn -> - `Failure "Unhandled exception" - | Unix.WSIGNALED n -> `Failure (Fmt.str "Signaled %d" n) - | Unix.WEXITED n -> `Failure (Fmt.str "Exited %d" n) - | Unix.WSTOPPED n -> `Failure (Fmt.str "Stopped %d" n) + let await (_, p) : [> outcome ] = + match Eio.Promise.await p with + | Ok (#outcome as outcome) -> outcome + | Error _ -> `Failure "Unhandled exception" - let cancel t = - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> - match t.status with - | `Running -> - let pid, _ = Unix.waitpid [ Unix.WNOHANG ] t.pid in - if pid = 0 then ( - (* Child process is still running. *) - kill_no_err t.pid; - Exit.remove t.pid; - t.status <- `Cancelled; - true) - else false - | _ -> false + let status (_, p) : [> status ] = + match Eio.Promise.peek p with + | Some (Ok (#outcome as outcome)) -> outcome + | Some (Error e) -> `Failure (Printexc.to_string e) + | None -> `Running - let status t = - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> - match t.status with - | `Running -> - let pid, status = Unix.waitpid [ Unix.WNOHANG ] t.pid in - if pid = 0 then `Running - else - let s = status_of_process_outcome status in - Exit.remove pid; - t.status <- s; - s - | #outcome as s -> s + exception Cancelled - let await t = - Eio.Mutex.use_rw ~protect:true t.lock @@ fun () -> - match t.status with - | `Running -> - let pid, status = Unix.waitpid [] t.pid in - let s = status_of_process_outcome status in - Exit.remove pid; - t.status <- s; - s - | #outcome as s -> s + let cancel (sw, p) = + match Eio.Promise.peek p with + | None -> + Eio.Switch.fail sw Cancelled; + true + | Some _ -> false end diff --git a/src/irmin-pack/unix/io.ml b/src/irmin-pack/unix/io.ml index 2ddc92e946..8d460f102f 100644 --- a/src/irmin-pack/unix/io.ml +++ b/src/irmin-pack/unix/io.ml @@ -14,135 +14,154 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +module Eio_temp = Eio open! Irmin_pack_io.Import +module Eio = Eio_temp module Errors = Irmin_pack_io.Errors -module Syscalls = Index_unix.Syscalls (* File utils, taken from index.unix package. These functions need to read from a loop because the underlying implementation will not read/write more than a constant called [UNIX_BUFFER_SIZE]. *) + +(** TODO *) module Util = struct - let really_write fd fd_offset buffer buffer_offset length = - let rec aux fd_offset buffer_offset length = - let w = Syscalls.pwrite ~fd ~fd_offset ~buffer ~buffer_offset ~length in - if w = 0 || w = length then () - else - (aux [@tailcall]) - Int63.Syntax.(fd_offset + Int63.of_int w) - (buffer_offset + w) (length - w) - in - aux fd_offset buffer_offset length - - let really_read fd fd_offset length buffer = - let rec aux fd_offset buffer_offset length = - let r = Syscalls.pread ~fd ~fd_offset ~buffer ~buffer_offset ~length in - if r = 0 then buffer_offset (* end of file *) - else if r = length then buffer_offset + r - else - (aux [@tailcall]) - Int63.Syntax.(fd_offset + Int63.of_int r) - (buffer_offset + r) (length - r) - in - aux fd_offset 0 length + let really_write fd file_offset buffer buffer_offset length = + let cs = Cstruct.of_bytes ~off:buffer_offset ~len:length buffer in + Eio.File.pwrite_all fd ~file_offset [ cs ] + + let really_read fd file_offset length buffer = + let cs = Cstruct.create length in + Eio.File.pread_exact fd ~file_offset [ cs ]; + Cstruct.blit_to_bytes cs 0 buffer 0 length end module Unix = struct type misc_error = Unix.error * string * string + (** TODO *) + (** TODO *) let unix_error_t = Irmin.Type.(map string (fun _str -> assert false) Unix.error_message) + (** TODO *) let misc_error_t = Irmin.Type.(triple unix_error_t string string) type create_error = [ `Io_misc of misc_error | `File_exists of string ] + (** TODO *) type open_error = [ `Io_misc of misc_error | `No_such_file_or_directory of string | `Not_a_file ] + (** TODO *) type read_error = [ `Io_misc of misc_error | `Read_out_of_bounds | `Closed | `Invalid_argument ] + (** TODO *) type write_error = [ `Io_misc of misc_error | `Ro_not_allowed | `Closed ] + (** TODO *) + type close_error = [ `Io_misc of misc_error | `Double_close ] + (** TODO *) type mkdir_error = [ `Io_misc of misc_error | `File_exists of string | `No_such_file_or_directory of string | `Invalid_parent_directory ] + (** TODO *) + (** TODO *) let raise_misc_error (x, y, z) = raise (Unix.Unix_error (x, y, z)) + (** TODO *) let catch_misc_error f = try Ok (f ()) with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) + type file = + | RO of Eio.File.ro_ty Eio.Resource.t + | RW of Eio.File.rw_ty Eio.Resource.t + + let get_file_as_ro = function + | RO file -> file + | RW file -> (file :> Eio.File.ro_ty Eio.Resource.t) + type t = { - fd : Unix.file_descr; + file : file; mutable closed : bool; - readonly : bool; - path : string; + path : Eio.Fs.dir_ty Eio.Path.t; } - let classify_path p = - Unix.( - try - match (stat p).st_kind with - | S_REG -> `File - | S_DIR -> `Directory - | _ -> `Other - with _ -> `No_such_file_or_directory) + let classify_path path = + match Eio.Path.kind ~follow:false path with + | `Regular_file -> `File + | `Directory -> `Directory + | `Not_found -> `No_such_file_or_directory + | _ -> `Other + + (** TODO *) + let readdir p = Eio.Path.read_dir p - let readdir p = Sys.readdir p |> Array.to_list let default_create_perm = 0o644 - let default_open_perm = 0o644 + (* let default_open_perm = 0o644 *) + (* CHECK *) + let default_mkdir_perm = 0o755 - let create ~path ~overwrite = + (** TODO *) + let create ~sw ~path ~overwrite = try - match Sys.file_exists path with - | false -> - let fd = - Unix.( - openfile path - [ O_CREAT; O_RDWR; O_EXCL; O_CLOEXEC ] - default_create_perm) + match Eio.Path.kind ~follow:false path with + | `Not_found -> + let file = + RW + (Eio.Path.open_out ~sw ~create:(`Exclusive default_create_perm) + path) in - Ok { fd; closed = false; readonly = false; path } - | true -> ( + Ok { file; closed = false; path } + | `Regular_file -> ( match overwrite with | true -> (* The file exists, truncate it and use it. An exception will be triggered if we don't have the permissions *) - let fd = - Unix.( - openfile path - [ O_RDWR; O_CLOEXEC; O_TRUNC ] - default_create_perm) + let file = + RW + (Eio.Path.open_out ~sw + ~create:(`Or_truncate default_create_perm) path) in - Ok { fd; closed = false; readonly = false; path } - | false -> Error (`File_exists path)) + Ok { file; closed = false; path } + | false -> Error (`File_exists (Eio.Path.native_exn path))) + | _ -> assert false with - | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) + | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) (* TODO *) | Sys_error _ -> assert false - let open_ ~path ~readonly = - match classify_path path with - | `Directory | `Other -> Error `Not_a_file - | `No_such_file_or_directory -> Error (`No_such_file_or_directory path) - | `File -> ( - let mode = Unix.(if readonly then O_RDONLY else O_RDWR) in - try - let fd = Unix.(openfile path [ mode; O_CLOEXEC ] default_open_perm) in - Ok { fd; closed = false; readonly; path } - with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) + let open_ ~sw ~path ~readonly = + match Eio.Path.kind ~follow:false path with + | `Not_found -> + Error (`No_such_file_or_directory (Eio.Path.native_exn path)) + | `Regular_file -> ( + match readonly with + | true -> ( + try + let file = RO (Eio.Path.open_in ~sw path) in + Ok { file; closed = false; path } + with Unix.Unix_error (e, s1, s2) -> + Error (`Io_misc (e, s1, s2)) (* TODO *)) + | false -> ( + try + let file = RW (Eio.Path.open_out ~sw ~create:`Never path) in + Ok { file; closed = false; path } + with Unix.Unix_error (e, s1, s2) -> + Error (`Io_misc (e, s1, s2)) (* TODO *))) + | _ -> Error `Not_a_file let close t = match t.closed with @@ -152,25 +171,29 @@ module Unix = struct (* mark [t] as closed, even if [Unix.close] fails, since it is recommended to not retry after an error. see: https://man7.org/linux/man-pages/man2/close.2.html *) try - Unix.close t.fd; + let file = get_file_as_ro t.file in + Eio.Resource.close file; Ok () with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) + (* TODO *) + (** TODO *) let write_exn t ~off ~len s = if String.length s < len then raise (Errors.Pack_error `Invalid_argument); - match (t.closed, t.readonly) with + match (t.closed, t.file) with | true, _ -> raise Errors.Closed - | _, true -> raise Errors.RO_not_allowed - | _ -> + | _, RO _ -> raise Errors.RO_not_allowed + | _, RW file -> (* Bytes.unsafe_of_string usage: s has shared ownership; we assume that Util.really_write does not mutate buf (i.e., only needs shared ownership). This usage is safe. *) let buf = Bytes.unsafe_of_string s in - let () = Util.really_write t.fd off buf 0 len in + let () = Util.really_write file off buf 0 len in (* TODO: Index.Stats is not domain-safe Index.Stats.add_write len; *) () + (** TODO *) let write_string t ~off s = let len = String.length s in try Ok (write_exn t ~off ~len s) with @@ -178,30 +201,39 @@ module Unix = struct | Errors.RO_not_allowed -> Error `Ro_not_allowed | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) + (** TODO *) let fsync t = - match (t.closed, t.readonly) with + match (t.closed, t.file) with | true, _ -> Error `Closed - | _, true -> Error `Ro_not_allowed - | _ -> ( + | _, RO _ -> Error `Ro_not_allowed + | _, RW file -> ( try - Unix.fsync t.fd; + Eio.File.sync file; Ok () with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) + (** TODO *) let read_exn t ~off ~len buf = if len > Bytes.length buf then raise (Errors.Pack_error `Invalid_argument); match t.closed with | true -> raise Errors.Closed - | false -> - let nread = Util.really_read t.fd off len buf in - (* TODO: Index.Stats is not domain-safe - Index.Stats.add_read nread; *) - if nread <> len then - (* didn't manage to read the desired amount; in this case the interface seems to - require we return `Read_out_of_bounds FIXME check this, because it is unusual - - the normal API allows return of a short string *) - raise (Errors.Pack_error `Read_out_of_bounds) - + | false -> ( + try + let file = get_file_as_ro t.file in + Util.really_read file off len buf + with exn -> + Printexc.print_backtrace stderr; + raise exn) + (* TODO: Index.Stats is not domain-safe + Index.Stats.add_read nread; *) + (* if nread <> len then *) + (* TODO: vérifier que c'est bon *) + (* didn't manage to read the desired amount; in this case the interface seems to + require we return `Read_out_of_bounds FIXME check this, because it is unusual + - the normal API allows return of a short string *) + (* raise (Errors.Pack_error `Read_out_of_bounds) *) + + (** TODO *) let read_to_string t ~off ~len = let buf = Bytes.create len in try @@ -217,23 +249,23 @@ module Unix = struct | Errors.Closed -> Error `Closed | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) + (** TODO *) let page_size = 4096 + (** TODO *) let read_all_to_string t = let open Result_syntax in let* () = if t.closed then Error `Closed else Ok () in let buf = Buffer.create 0 in let len = page_size in - let bytes = Bytes.create len in + let cs = Cstruct.create len in let rec aux ~off = - let nread = - Syscalls.pread ~fd:t.fd ~fd_offset:off ~buffer:bytes ~buffer_offset:0 - ~length:len - in + let file = get_file_as_ro t.file in + let nread = Eio.File.pread file ~file_offset:off [ cs ] in if nread > 0 then ( (* TODO: Index.Stats is not domain-safe Index.Stats.add_read nread; *) - Buffer.add_subbytes buf bytes 0 nread; + Buffer.add_subbytes buf (Cstruct.to_bytes ~off:0 ~len:nread cs) 0 nread; if nread = len then aux ~off:Int63.(add off (of_int nread))) in try @@ -241,16 +273,21 @@ module Unix = struct Ok (Buffer.contents buf) with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) + (** TODO *) let read_size t = match t.closed with | true -> Error `Closed | false -> ( - try Ok Unix.LargeFile.((fstat t.fd).st_size |> Int63.of_int64) + try + let file = get_file_as_ro t.file in + Ok Eio.File.(stat file).size with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) + (** TODO *) let size_of_path s = let open Result_syntax in - let* io = open_ ~path:s ~readonly:true in + Eio.Switch.run @@ fun sw -> + let* io = open_ ~path:s ~readonly:true ~sw in let res = match read_size io with | Error `Closed -> assert false @@ -262,46 +299,58 @@ module Unix = struct | Error (`Io_misc _) as x -> x | Ok () -> res - let readonly t = t.readonly + let readonly t = match t.file with RO _ -> true | RW _ -> false let path t = t.path let move_file ~src ~dst = try - Sys.rename src dst; + Eio.Path.rename src dst; Ok () - with Sys_error msg -> Error (`Sys_error msg) + with Eio.Io (err, _context) -> + Error (`Sys_error (Fmt.str "%a" Eio.Exn.pp_err err)) let copy_file ~src ~dst = - let cmd = Filename.quote_command "cp" [ "-p"; src; dst ] in - match Sys.command cmd with - | 0 -> Ok () - | n -> Error (`Sys_error (Int.to_string n)) + let stats = Eio.Path.stat ~follow:false src in + try + Eio.Path.with_open_in src (fun in_flow -> + Eio.Path.with_open_out ~create:(`Or_truncate stats.perm) dst + (fun out_flow -> Eio.Flow.copy in_flow out_flow)); + Ok () + with Eio.Io (err, _context) -> + Error (`Sys_error (Fmt.str "%a" Eio.Exn.pp_err err)) + (** TODO *) let mkdir path = - match (classify_path (Filename.dirname path), classify_path path) with - | `Directory, `No_such_file_or_directory -> ( + let dirname, _ = Option.get @@ Eio.Path.split path in + match + (Eio.Path.kind ~follow:false dirname, Eio.Path.kind ~follow:false path) + with + | `Directory, `Not_found -> ( try - Unix.mkdir path default_mkdir_perm; + Eio.Path.mkdir ~perm:default_mkdir_perm path; Ok () with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) - | `Directory, (`File | `Directory | `Other) -> Error (`File_exists path) - | `No_such_file_or_directory, `No_such_file_or_directory -> - Error (`No_such_file_or_directory path) + | `Directory, _ -> Error (`File_exists (Eio.Path.native_exn path)) + | `Not_found, `Not_found -> + Error (`No_such_file_or_directory (Eio.Path.native_exn path)) | _ -> Error `Invalid_parent_directory - let rmdir path = Sys.rmdir path + let rmdir path = Eio.Path.rmdir path let unlink path = try - Sys.remove path; + Eio.Path.unlink path; Ok () - with Sys_error msg -> Error (`Sys_error msg) + with Eio.Io (err, _context) -> + Error (`Sys_error (Fmt.str "%a" Eio.Exn.pp_err err)) - let unlink_dont_wait ~on_exn path = - (* TODO: Lwt.dont_wait (fun () -> Lwt_unix.unlink path) on_exn *) - try Sys.remove path with err -> on_exn err + let unlink_dont_wait ~on_exn ~sw path = + Eio.Fiber.fork ~sw (fun () -> + try Eio.Path.unlink path with err -> on_exn err) + (** TODO *) module Stats = struct + (** TODO *) let is_darwin = lazy (try @@ -310,12 +359,17 @@ module Unix = struct | _ -> false with Unix.Unix_error _ -> false) + (** TODO *) let get_wtime () = (Mtime_clock.now () |> Mtime.to_uint64_ns |> Int64.to_float) /. 1e9 + (** TODO *) let get_stime () = Rusage.((get Self).stime) + + (** TODO *) let get_utime () = Rusage.((get Self).utime) + (** TODO *) let get_rusage () = let Rusage.{ maxrss; minflt; majflt; inblock; oublock; nvcsw; nivcsw; _ } = @@ -329,5 +383,8 @@ module Unix = struct end module Clock = Mtime_clock + (** TODO *) + module Progress = Progress + (** TODO *) end diff --git a/src/irmin/conf.ml b/src/irmin/conf.ml index c694a1241d..0df9db9457 100644 --- a/src/irmin/conf.ml +++ b/src/irmin/conf.ml @@ -93,6 +93,8 @@ module Spec = struct dest.keys src in { name = !name; keys } + + let copy { name; keys } = { name; keys } end type t = Spec.t * Univ.t M.t diff --git a/src/irmin/conf.mli b/src/irmin/conf.mli index 533d277bb8..4d8514a01b 100644 --- a/src/irmin/conf.mli +++ b/src/irmin/conf.mli @@ -47,6 +47,9 @@ module Spec : sig The name of the resulting spec will be the name of [a] and the names of the specs in [b] joined by hyphens. *) + + val copy : t -> t + (** [copy t] returns a fresh spec with the same keys as [t]. *) end module Typ : sig diff --git a/src/libirmin/util.ml b/src/libirmin/util.ml index e2ab02c80c..b63b0e9beb 100644 --- a/src/libirmin/util.ml +++ b/src/libirmin/util.ml @@ -46,6 +46,14 @@ module Make (I : Cstubs_inverted.INTERNAL) = struct let run_env fn = Eio_main.run @@ fun env -> Lwt_eio.with_event_loop ~clock:env#clock @@ fun () -> + Eio.Switch.run @@ fun sw -> + let env = + object + method cwd = Eio.Stdenv.cwd env + method clock = Eio.Stdenv.clock env + method sw = sw + end + in fn (env :> Irmin_cli.eio) let run fn = run_env (fun _ -> fn ()) diff --git a/test/irmin-bench/replay.ml b/test/irmin-bench/replay.ml index d59704705d..c77735b0ca 100644 --- a/test/irmin-bench/replay.ml +++ b/test/irmin-bench/replay.ml @@ -1,6 +1,6 @@ open! Import -let test_dir = Filename.concat "_build" "test-pack-trace-replay" +let test_dir fs = Eio.Path.(fs / "_build" / "test-pack-trace-replay") let () = Logs.set_level (Some Logs.Debug); @@ -16,14 +16,12 @@ module Store = struct type key = commit_key - let create_repo ~root () = + let create_repo ~sw ~fs ~root () = (* make sure the parent dir exists *) - let () = - match Sys.file_exists (Filename.dirname root) with - | false -> Unix.mkdir (Filename.dirname root) 0o755 - | true -> () - in - let conf = Irmin_pack.config ~readonly:false ~fresh:true root in + let dirname, _ = Option.get (Eio.Path.split root) in + if Eio.Path.kind ~follow:false dirname = `Not_found then + Eio.Path.mkdir ~perm:0o755 dirname; + let conf = Irmin_pack.config ~sw ~fs ~readonly:false ~fresh:true root in let repo = Store.Repo.v conf in let on_commit _ _ = () in let on_end () = () in @@ -33,13 +31,13 @@ module Store = struct let r = Store.Gc.wait repo in match r with Ok _ -> () | Error (`Msg err) -> failwith err - let gc_run ?(finished = fun _ -> ()) repo key = + let gc_run ~fs ~domain_mgr ?(finished = fun _ -> ()) repo key = let f (result : (_, Store.Gc.msg) result) = match result with | Error (`Msg err) -> finished @@ Error err | Ok stats -> finished @@ Ok stats in - let launched = Store.Gc.run ~finished:f repo key in + let launched = Store.Gc.run ~fs ~domain_mgr ~finished:f repo key in match launched with | Ok true -> () | Ok false -> [%logs.app "GC skipped"] @@ -63,23 +61,19 @@ let goto_project_root () = Unix.chdir (Fpath.to_string root) | _ -> () -let setup_env () = +let setup_env ~fs = goto_project_root (); let trace_path = - let open Fpath in - v "test" / "irmin-bench" / "data" / "tezos_actions_1commit.repr" - |> to_string + Eio.Path.( + fs / "test" / "irmin-bench" / "data" / "tezos_actions_1commit.repr") in - assert (Sys.file_exists trace_path); - if Sys.file_exists test_dir then ( - let cmd = Printf.sprintf "rm -rf %s" test_dir in - [%logs.debug "exec: %s\n%!" cmd]; - let _ = Sys.command cmd in - ()); + let test_dir = test_dir fs in + if Eio.Path.kind ~follow:false test_dir <> `Not_found then + Eio.Path.rmtree test_dir; trace_path -let replay_1_commit () = - let trace_path = setup_env () in +let replay_1_commit ~fs ~domain_mgr () = + let trace_path = setup_env ~fs in let replay_config : _ Replay.config = { number_of_commits_to_replay = 1; @@ -87,7 +81,7 @@ let replay_1_commit () = inode_config = (Conf.entries, Conf.stable_hash); store_type = `Pack; replay_trace_path = trace_path; - artefacts_path = test_dir; + artefacts_path = test_dir fs; keep_store = false; keep_stat_trace = false; empty_blobs = false; @@ -98,7 +92,7 @@ let replay_1_commit () = add_volume_every = 0; } in - let summary = Replay.run () replay_config in + let summary = Replay.run ~fs ~domain_mgr () replay_config in [%logs.debug "%a" (Irmin_traces.Trace_stat_summary_pp.pp 5) ([ "" ], [ summary ])]; let check name = Alcotest.(check int) ("Stats_counters" ^ name) in @@ -134,8 +128,8 @@ module Store_mem = struct type key = commit_key - let create_repo ~root () = - let conf = Irmin_pack.config ~readonly:false ~fresh:true root in + let create_repo ~sw ~fs ~root () = + let conf = Irmin_pack.config ~sw ~fs ~readonly:false ~fresh:true root in let repo = Store.Repo.v conf in let on_commit _ _ = () in let on_end () = () in @@ -144,13 +138,13 @@ module Store_mem = struct let split _repo = () let add_volume _repo = () let gc_wait _repo = () - let gc_run ?finished:_ _repo _key = () + let gc_run ~fs:_ ~domain_mgr:_ ?finished:_ _repo _key = () end module Replay_mem = Irmin_traces.Trace_replay.Make (Store_mem) -let replay_1_commit_mem () = - let trace_path = setup_env () in +let replay_1_commit_mem ~fs ~domain_mgr () = + let trace_path = setup_env ~fs in let replay_config : _ Irmin_traces.Trace_replay.config = { number_of_commits_to_replay = 1; @@ -158,7 +152,7 @@ let replay_1_commit_mem () = inode_config = (Conf.entries, Conf.stable_hash); store_type = `Pack; replay_trace_path = trace_path; - artefacts_path = test_dir; + artefacts_path = test_dir fs; keep_store = false; keep_stat_trace = false; empty_blobs = false; @@ -169,17 +163,17 @@ let replay_1_commit_mem () = add_volume_every = 0; } in - let summary = Replay_mem.run () replay_config in + let summary = Replay_mem.run ~fs ~domain_mgr () replay_config in [%logs.debug "%a" (Irmin_traces.Trace_stat_summary_pp.pp 5) ([ "" ], [ summary ])]; () -let test_cases = +let test_cases ~fs ~domain_mgr = let tc msg f = Alcotest.test_case msg `Quick f in [ ( "replay", [ - tc "replay_1_commit" replay_1_commit; - tc "replay_1_commit_in_memory" replay_1_commit_mem; + tc "replay_1_commit" (replay_1_commit ~fs ~domain_mgr); + tc "replay_1_commit_in_memory" (replay_1_commit_mem ~fs ~domain_mgr); ] ); ] diff --git a/test/irmin-bench/test.ml b/test/irmin-bench/test.ml index 4afc178092..3af38b4296 100644 --- a/test/irmin-bench/test.ml +++ b/test/irmin-bench/test.ml @@ -15,6 +15,8 @@ *) let () = - Eio_main.run @@ fun _env -> + Eio_main.run @@ fun env -> + let domain_mgr = Eio.Stdenv.domain_mgr env in + let fs = Eio.Stdenv.fs env in Alcotest.run "irmin-bench" - (Ema.test_cases @ Misc.test_cases @ Replay.test_cases) + (Ema.test_cases @ Misc.test_cases @ Replay.test_cases ~fs ~domain_mgr) diff --git a/test/irmin-cli/test.ml b/test/irmin-cli/test.ml index d04fbe4802..53e63948e4 100644 --- a/test/irmin-cli/test.ml +++ b/test/irmin-cli/test.ml @@ -40,5 +40,12 @@ end let () = Eio_main.run @@ fun env -> - let env = (env :> Irmin_cli.eio) in + Eio.Switch.run @@ fun sw -> + let env :> Irmin_cli.eio = + object + method cwd = Eio.Stdenv.cwd env + method clock = Eio.Stdenv.clock env + method sw = sw + end + in Alcotest.run "irmin-cli" [ ("conf", Conf.misc ~env) ] diff --git a/test/irmin-pack/bench_multicore/bench.ml b/test/irmin-pack/bench_multicore/bench.ml index 919b8f5aac..73b4169d28 100644 --- a/test/irmin-pack/bench_multicore/bench.ml +++ b/test/irmin-pack/bench_multicore/bench.ml @@ -14,16 +14,16 @@ let goto_project_root () = Unix.chdir @@ String.concat Fpath.dir_sep @@ List.rev root | _ -> () -let root = Filename.concat "_build" "bench-multicore" +let root fs = Eio.Path.(fs / "_build" / "bench-multicore") -let reset_test_env () = +let reset_test_env ~fs () = goto_project_root (); - Common.rm_dir root + Common.rm_dir (root fs) let info () = S.Info.empty -let open_repo ~fresh ~readonly () = - let conf = Irmin_pack.Conf.init ~fresh ~readonly root in +let open_repo ~sw ~fs ~fresh ~readonly () = + let conf = Irmin_pack.Conf.init ~sw ~fs ~fresh ~readonly (root fs) in S.Repo.v conf let apply_op tree = function @@ -82,20 +82,21 @@ let get_tree ~config repo tasks = Array.iter (warmup_task tree) tasks; fun () -> tree -let setup_tree ~readonly paths = +let setup_tree ~sw ~fs ~readonly paths = let tree = make_tree_of_paths paths in - reset_test_env (); - let repo = open_repo ~fresh:true ~readonly:false () in + reset_test_env ~fs (); + let repo = open_repo ~sw ~fs ~fresh:true ~readonly:false () in let () = S.set_tree_exn ~info (S.main repo) [] tree in S.Repo.close repo; - let repo = open_repo ~fresh:false ~readonly () in + let repo = open_repo ~sw ~fs ~fresh:false ~readonly () in Format.printf "# domains,min_time,median_time,max_time,min_ratio,median_ratio,max_ratio@."; repo -let half ~d_mgr ~(config : Gen.config) = +let half ~fs ~d_mgr ~(config : Gen.config) = + Eio.Switch.run @@ fun sw -> let paths, tasks = Gen.make ~config in - let repo = setup_tree ~readonly:true paths in + let repo = setup_tree ~sw ~fs ~readonly:true paths in let get_tree = get_tree ~config repo tasks in let _, sequential, _ = @@ -118,9 +119,10 @@ let half ~d_mgr ~(config : Gen.config) = done; S.Repo.close repo -let full ~d_mgr ~(config : Gen.config) = +let full ~fs ~d_mgr ~(config : Gen.config) = + Eio.Switch.run @@ fun sw -> let paths, tasks = Gen.make_full ~config in - let repo = setup_tree ~readonly:false paths in + let repo = setup_tree ~sw ~fs ~readonly:false paths in let get_tree = get_tree ~config repo tasks in let parents = [ S.Commit.key @@ S.Head.get @@ S.main repo ] in diff --git a/test/irmin-pack/bench_multicore/main.ml b/test/irmin-pack/bench_multicore/main.ml index 1b53002356..0026277b93 100644 --- a/test/irmin-pack/bench_multicore/main.ml +++ b/test/irmin-pack/bench_multicore/main.ml @@ -120,11 +120,11 @@ let config = let bench_half config = Logs.set_level None; - Eio_main.run @@ fun env -> Bench.half ~d_mgr:env#domain_mgr ~config + Eio_main.run @@ fun env -> Bench.half ~fs:env#fs ~d_mgr:env#domain_mgr ~config let bench_full config = Logs.set_level None; - Eio_main.run @@ fun env -> Bench.full ~d_mgr:env#domain_mgr ~config + Eio_main.run @@ fun env -> Bench.full ~fs:env#fs ~d_mgr:env#domain_mgr ~config let cmd_half = let doc = "Half-diamond benchmark" in diff --git a/test/irmin-pack/common.ml b/test/irmin-pack/common.ml index a8db0ca762..98529a5c7b 100644 --- a/test/irmin-pack/common.ml +++ b/test/irmin-pack/common.ml @@ -20,14 +20,7 @@ module Int63 = Optint.Int63 let get = function Some x -> x | None -> Alcotest.fail "None" let sha1 x = Irmin.Hash.SHA1.hash (fun f -> f x) let sha1_contents x = sha1 ("B" ^ x) - -let rm_dir root = - if Sys.file_exists root then ( - let cmd = Printf.sprintf "rm -rf %s" root in - [%logs.info "exec: %s\n%!" cmd]; - let _ = Sys.command cmd in - ()) - +let rm_dir root = Eio.Path.rmtree ~missing_ok:true root let index_log_size = Some 1_000 let () = Random.self_init () let random_char () = char_of_int (Random.int 256) @@ -98,16 +91,17 @@ module Branch = (Irmin_pack.Atomic_write.Value.Of_hash (Schema.Hash)) module Make_context (Config : sig - val root : string + val root : fs:Eio.Fs.dir_ty Eio.Path.t -> Eio.Fs.dir_ty Eio.Path.t end) = struct let fresh_name = let c = ref 0 in - fun object_type -> + fun ~fs object_type -> incr c; - - let name = Filename.concat Config.root ("pack_" ^ string_of_int !c) in - [%logs.info "Constructing %s context object: %s" object_type name]; + let name = Eio.Path.(Config.root ~fs / ("pack_" ^ string_of_int !c)) in + [%logs.info + "Constructing %s context object: %s" object_type + (Eio.Path.native_exn name)]; name let mkdir_dash_p dirname = @@ -120,7 +114,11 @@ struct in aux dirname - type d = { name : string; fm : File_manager.t; dict : Dict.t } + type d = { + name : Eio.Fs.dir_ty Eio.Path.t; + fm : File_manager.t; + dict : Dict.t; + } (* TODO : test the indexing_strategy minimal. *) let config ~readonly ~fresh name = @@ -128,37 +126,39 @@ struct ~indexing_strategy:Irmin_pack.Indexing_strategy.always ~lru_size:0 name (* TODO : remove duplication with irmin_pack/ext.ml *) - let get_fm config = + let get_fm ~sw ~fs config = let readonly = Irmin_pack.Conf.readonly config in - if readonly then File_manager.open_ro config |> Errs.raise_if_error + if readonly then File_manager.open_ro ~sw ~fs config |> Errs.raise_if_error else let fresh = Irmin_pack.Conf.fresh config in if fresh then ( let root = Irmin_pack.Conf.root config in mkdir_dash_p root; - File_manager.create_rw ~overwrite:true config |> Errs.raise_if_error) - else File_manager.open_rw config |> Errs.raise_if_error - - let get_dict ?name ~readonly ~fresh () = - let name = Option.value name ~default:(fresh_name "dict") in - let fm = config ~readonly ~fresh name |> get_fm in + File_manager.create_rw ~sw ~fs ~overwrite:true config + |> Errs.raise_if_error) + else File_manager.open_rw ~sw ~fs config |> Errs.raise_if_error + + let get_dict ~sw ~fs ?name ~readonly ~fresh () = + let name = Option.value name ~default:(fresh_name ~fs "dict") in + let config = config ~sw ~fs ~readonly ~fresh name in + let fm = get_fm ~sw ~fs config in let dict = File_manager.dict fm in { name; dict; fm } let close_dict d = File_manager.close d.fm |> Errs.raise_if_error type t = { - name : string; + name : Eio.Fs.dir_ty Eio.Path.t; fm : File_manager.t; index : Index.t; pack : read Pack.t; dict : Pack.dict; } - let create ~readonly ~fresh name = + let create ~sw ~fs ~readonly ~fresh name = let f = ref (fun () -> ()) in - let config = config ~readonly ~fresh name in - let fm = get_fm config in + let config = config ~sw ~fs ~readonly ~fresh name in + let fm = get_fm ~sw ~fs config 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 @@ -168,12 +168,12 @@ struct (f := fun () -> File_manager.flush fm |> Errs.raise_if_error); { name; index; pack; dict; fm } - let get_rw_pack () = - let name = fresh_name "" in - create ~readonly:false ~fresh:true name + let get_rw_pack ~sw ~fs = + let name = fresh_name ~fs "" in + create ~sw ~fs ~readonly:false ~fresh:true name - let get_ro_pack name = create ~readonly:true ~fresh:false name - let reopen_rw name = create ~readonly:false ~fresh:false name + let get_ro_pack ~sw ~fs name = create ~sw ~fs ~readonly:true ~fresh:false name + let reopen_rw ~sw ~fs name = create ~sw ~fs ~readonly:false ~fresh:false name let close_pack t = let _ = File_manager.flush t.fm in @@ -352,23 +352,15 @@ let goto_project_root () = Unix.chdir (Fpath.to_string root) | _ -> () -let rec unlink_path path = - match Irmin_pack_unix.Io.Unix.classify_path path with - | `No_such_file_or_directory -> () - | `Directory -> - Sys.readdir path - |> Array.map (fun p -> Filename.concat path p) - |> Array.iter unlink_path; - Unix.rmdir path - | _ -> Unix.unlink path - -let create_lower_root = +let unlink_path path = Eio.Path.rmtree ~missing_ok:true path + +let create_lower_root ~fs = let counter = ref 0 in let ( let$ ) res f = f @@ Result.get_ok res in fun ?(mkdir = true) () -> let lower_root = "test_lower_" ^ string_of_int !counter in incr counter; - let lower_path = Filename.concat "_build" lower_root in + let lower_path = Eio.Path.(fs / "_build" / lower_root) in unlink_path lower_path; let$ _ = if mkdir then Irmin_pack_unix.Io.Unix.mkdir lower_path else Result.ok () @@ -378,6 +370,8 @@ let create_lower_root = let setup_test_env ~root_archive ~root_local_build = goto_project_root (); rm_dir root_local_build; + let root_archive = Eio.Path.native_exn root_archive in + let root_local_build = Eio.Path.native_exn root_local_build in let cmd = Filename.quote_command "cp" [ "-R"; "-p"; root_archive; root_local_build ] in diff --git a/test/irmin-pack/common.mli b/test/irmin-pack/common.mli index f05fc317fc..54e74fb8a8 100644 --- a/test/irmin-pack/common.mli +++ b/test/irmin-pack/common.mli @@ -84,43 +84,72 @@ module Pack : (** Helper constructors for fresh pre-initialised dictionaries and packs *) module Make_context (Config : sig - val root : string + val root : fs:Eio.Fs.dir_ty Eio.Path.t -> Eio.Fs.dir_ty Eio.Path.t end) : sig - val fresh_name : string -> string + val fresh_name : + fs:Eio.Fs.dir_ty Eio.Path.t -> string -> Eio.Fs.dir_ty Eio.Path.t (** [fresh_name typ] is a clean directory for a resource of type [typ]. *) - type d = { name : string; fm : File_manager.t; dict : Dict.t } + type d = { + name : Eio.Fs.dir_ty Eio.Path.t; + fm : File_manager.t; + dict : Dict.t; + } + + val get_dict : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + ?name:Eio.Fs.dir_ty Eio.Path.t -> + readonly:bool -> + fresh:bool -> + unit -> + d - val get_dict : ?name:string -> readonly:bool -> fresh:bool -> unit -> d val close_dict : d -> unit type t = { - name : string; + name : Eio.Fs.dir_ty Eio.Path.t; fm : File_manager.t; index : Index.t; pack : read Pack.t; dict : Dict.t; } - val get_rw_pack : unit -> t - val get_ro_pack : string -> t - val reopen_rw : string -> t + val get_rw_pack : sw:Eio.Switch.t -> fs:Eio.Fs.dir_ty Eio.Path.t -> t + + val get_ro_pack : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + Eio.Fs.dir_ty Eio.Path.t -> + t + + val reopen_rw : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + Eio.Fs.dir_ty Eio.Path.t -> + t + val close_pack : t -> unit end val get : 'a option -> 'a val sha1 : string -> Schema.Hash.t val sha1_contents : string -> Schema.Hash.t -val rm_dir : string -> unit +val rm_dir : Eio.Fs.dir_ty Eio.Path.t -> unit val index_log_size : int option val random_string : int -> string val random_letters : int -> string -val unlink_path : string -> unit -val create_lower_root : ?mkdir:bool -> unit -> string +val unlink_path : Eio.Fs.dir_ty Eio.Path.t -> unit + +val create_lower_root : + fs:Eio.Fs.dir_ty Eio.Path.t -> ?mkdir:bool -> unit -> Eio.Fs.dir_ty Eio.Path.t val exec_cmd : string -> (unit, int) result (** Exec a command, and return [Ok ()] or [Error n] if return code is n <> 0 *) -val setup_test_env : root_archive:string -> root_local_build:string -> unit +val setup_test_env : + root_archive:Eio.Fs.dir_ty Eio.Path.t -> + root_local_build:Eio.Fs.dir_ty Eio.Path.t -> + unit (** [setup_test_env ~root_archive ~root_local_build] copies an existing store to a temporary location, to be used by the test. *) diff --git a/test/irmin-pack/dune b/test/irmin-pack/dune index 87d5e3f31c..713af2e3b8 100644 --- a/test/irmin-pack/dune +++ b/test/irmin-pack/dune @@ -48,12 +48,7 @@ ;; Attached to `irmin-tezos` to avoid a cyclic dependency with `irmin-pack` (package irmin-tezos) (action - (run ./test.exe -q --color=always)) - ; TODO: Fix unix waitpid error in irmin-pack GC - (enabled_if - (and - (<> %{system} macosx) - (<> %{system} freebsd)))) + (run ./test.exe -q --color=always))) (library (name common) @@ -67,7 +62,6 @@ irmin-pack.unix irmin-tezos logs - lwt hex fpath) (preprocess diff --git a/test/irmin-pack/test.ml b/test/irmin-pack/test.ml index 8a12515664..e8a83092b8 100644 --- a/test/irmin-pack/test.ml +++ b/test/irmin-pack/test.ml @@ -16,7 +16,13 @@ let () = Eio_main.run @@ fun env -> + let sr = Eio.Stdenv.secure_random env in + let fs = Eio.Stdenv.cwd env in + let domain_mgr = Eio.Stdenv.domain_mgr env in + (* **/** *) + Eio.Switch.run @@ fun sw -> + let test_suite = Test_pack.suite ~sw ~fs in Irmin_test.Store.run "irmin-pack" - ~misc:(Test_pack.misc @@ Eio.Stdenv.domain_mgr env) + ~misc:(Test_pack.misc ~sr ~fs ~domain_mgr) ~sleep:Eio_unix.sleep - (List.map (fun s -> (`Quick, s)) Test_pack.suite) + (List.map (fun s -> (`Quick, s)) test_suite) diff --git a/test/irmin-pack/test_async.ml b/test/irmin-pack/test_async.ml index 32f24e2fc6..b7ff34f194 100644 --- a/test/irmin-pack/test_async.ml +++ b/test/irmin-pack/test_async.ml @@ -20,20 +20,23 @@ module Async = Irmin_pack_unix.Async.Unix let check_outcome = Alcotest.check_repr Async.outcome_t -let test_success () = +let test_success ~domain_mgr () = + Eio.Switch.run @@ fun sw -> let f () = assert true in - let task = Async.async f in + let task = Async.async ~sw ~domain_mgr f in let result = Async.await task in - check_outcome "should succeed" result `Success + check_outcome "should succeed" `Success result -let test_exception_in_task () = +let test_exception_in_task ~domain_mgr () = + Eio.Switch.run @@ fun sw -> let f () = assert false in - let task = Async.async f in + let task = Async.async ~sw ~domain_mgr f in let result = Async.await task in - check_outcome "should fail" result (`Failure "Unhandled exception") + check_outcome "should fail" (`Failure "Unhandled exception") result -let tests = +let tests ~domain_mgr = [ - Alcotest.test_case "Successful task" `Quick test_success; - Alcotest.test_case "Exception occurs in task" `Quick test_exception_in_task; + Alcotest.test_case "Successful task" `Quick (test_success ~domain_mgr); + Alcotest.test_case "Exception occurs in task" `Quick + (test_exception_in_task ~domain_mgr); ] diff --git a/test/irmin-pack/test_async.mli b/test/irmin-pack/test_async.mli index 57112a0179..2ffcc59dd5 100644 --- a/test/irmin-pack/test_async.mli +++ b/test/irmin-pack/test_async.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest.test_case list +val tests : domain_mgr:_ Eio.Domain_manager.t -> unit Alcotest.test_case list diff --git a/test/irmin-pack/test_corrupted.ml b/test/irmin-pack/test_corrupted.ml index 76b3272e04..ed68dc7252 100644 --- a/test/irmin-pack/test_corrupted.ml +++ b/test/irmin-pack/test_corrupted.ml @@ -17,7 +17,7 @@ open! Import open Common -let root = Filename.concat "_build" "test-corrupted" +let root fs = Eio.Path.(fs / "_build" / "test-corrupted") module Conf = Irmin_tezos.Conf @@ -26,12 +26,13 @@ module Store = struct include Maker.Make (Schema) end -let config ?(readonly = false) ?(fresh = true) root = - Irmin_pack.config ~readonly ?index_log_size ~fresh root +let config ~sw ~fs ?(readonly = false) ?(fresh = true) root = + Irmin_pack.config ~sw ~fs ~readonly ?index_log_size ~fresh root let info () = Store.Info.empty let read_file path = + let path = Eio.Path.native_exn path in let ch = open_in_bin path in Fun.protect (fun () -> @@ -40,6 +41,7 @@ let read_file path = ~finally:(fun () -> close_in ch) let write_file path contents = + let path = Eio.Path.native_exn path in let ch = open_out_bin path in Fun.protect (fun () -> output_string ch contents) @@ -47,10 +49,12 @@ let write_file path contents = flush ch; close_out ch) -let test_corrupted_control_file () = +let test_corrupted_control_file ~fs () = + Eio.Switch.run @@ fun sw -> + let root = root fs in rm_dir root; - let control_file_path = Filename.concat root "store.control" in - let repo = Store.Repo.v (config ~fresh:true root) in + let control_file_path = Eio.Path.(root / "store.control") in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true root) in let control_file_blob0 = read_file control_file_path in let store = Store.main repo in let () = Store.set_exn ~info store [ "a" ] "b" in @@ -69,16 +73,17 @@ let test_corrupted_control_file () = assert (not (String.equal control_file_blob1 control_file_mix)); write_file control_file_path control_file_mix; let error = - try Ok (Store.Repo.v (config ~fresh:false root)) with exn -> Error exn + try Ok (Store.Repo.v (config ~sw ~fs ~fresh:false root) : Store.Repo.t) + with exn -> Error exn in match error with | Error (Irmin_pack_unix.Errors.Pack_error (`Corrupted_control_file s)) -> Alcotest.(check string) - "path is corrupted" s "_build/test-corrupted/store.control" + "path is corrupted" s "./_build/test-corrupted/store.control" | _ -> Alcotest.fail "unexpected error" -let tests = +let tests ~fs = [ Alcotest.test_case "Corrupted control file" `Quick - test_corrupted_control_file; + (test_corrupted_control_file ~fs); ] diff --git a/test/irmin-pack/test_corrupted.mli b/test/irmin-pack/test_corrupted.mli index 0793cf46c1..a37de62c47 100644 --- a/test/irmin-pack/test_corrupted.mli +++ b/test/irmin-pack/test_corrupted.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest.test_case list +val tests : fs:Eio.Fs.dir_ty Eio.Path.t -> unit Alcotest.test_case list diff --git a/test/irmin-pack/test_dispatcher.ml b/test/irmin-pack/test_dispatcher.ml index 854a61c44e..d2cc37dcd2 100644 --- a/test/irmin-pack/test_dispatcher.ml +++ b/test/irmin-pack/test_dispatcher.ml @@ -19,21 +19,22 @@ open Common module S = Test_gc.Store module Dispatcher = Irmin_pack_unix.Dispatcher.Make (File_manager) -let root = Filename.concat "_build" "test-dispatcher" +let root ~fs = Eio.Path.(fs / "_build" / "test-dispatcher") let src = Logs.Src.create "tests.dispatcher" ~doc:"Test dispatcher" module Log = (val Logs.src_log src : Logs.LOG) -let setup_store () = +let setup_store ~sw ~fs domain_mgr () = + let root = root ~fs in rm_dir root; - let config = S.config root in - let t = S.init_with_config config in + let config = S.config ~sw ~fs root in + let t = S.init_with_config ~fs config in let _ = S.commit_1 t in let t, c2 = S.commit_2 t in let t = S.checkout_exn t c2 in let t, _c3 = S.commit_3 t in [%log.debug "Gc c1, keep c2, c3"]; - let () = S.start_gc t c2 in + let () = S.start_gc ~fs ~domain_mgr t c2 in let () = S.finalise_gc t in let () = S.close t in config @@ -75,9 +76,10 @@ let check_hex msg buf expected = msg expected (Bytes.to_string buf |> Hex.of_string |> Hex.show) -let test_read () = - let config = setup_store () in - let fm = File_manager.open_ro config |> Errs.raise_if_error in +let test_read ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let config = setup_store ~sw ~fs domain_mgr () in + let fm = File_manager.open_ro ~sw ~fs config |> Errs.raise_if_error in let dsp = Dispatcher.v fm |> Errs.raise_if_error in let _ = Alcotest.check_raises "cannot read node_1" @@ -99,4 +101,5 @@ let test_read () = File_manager.close fm |> Errs.raise_if_error -let tests = [ Alcotest.test_case "read" `Quick test_read ] +let tests ~fs ~domain_mgr = + [ Alcotest.test_case "read" `Quick (test_read ~fs ~domain_mgr) ] diff --git a/test/irmin-pack/test_dispatcher.mli b/test/irmin-pack/test_dispatcher.mli index 2b40d2f891..fdcff8b3f8 100644 --- a/test/irmin-pack/test_dispatcher.mli +++ b/test/irmin-pack/test_dispatcher.mli @@ -14,4 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest.test_case list +val tests : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + unit Alcotest.test_case list diff --git a/test/irmin-pack/test_existing_stores.ml b/test/irmin-pack/test_existing_stores.ml index c8418c4317..d0a3ac681b 100644 --- a/test/irmin-pack/test_existing_stores.ml +++ b/test/irmin-pack/test_existing_stores.ml @@ -32,11 +32,11 @@ let archive = ("foo", [ ([ "b" ], "y") ]); ] -let root_v1_archive, root_v1, tmp = - let open Fpath in - ( v "test" / "irmin-pack" / "data" / "version_1" |> to_string, - v "_build" / "test_pack_version_1" |> to_string, - v "_build" / "test_index_reconstruct" |> to_string ) +let root_v1_archive ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_1") + +let root_v1 ~fs = Eio.Path.(fs / "_build" / "test_pack_version_1") +let tmp ~fs = Eio.Path.(fs / "_build" / "test_index_reconstruct") module Test (S : Irmin.Generic_key.KV with type Schema.Contents.t = string) = struct @@ -117,24 +117,29 @@ module Test_reconstruct = struct module S = V2 () include Test (S) - let setup_test_env () = - setup_test_env ~root_archive:root_v1_archive ~root_local_build:root_v1; - setup_test_env ~root_archive:root_v1_archive ~root_local_build:tmp + let setup_test_env ~fs () = + setup_test_env ~root_archive:(root_v1_archive ~fs) + ~root_local_build:(root_v1 ~fs); + setup_test_env ~root_archive:(root_v1_archive ~fs) + ~root_local_build:(tmp ~fs) - let test_reconstruct () = + let test_reconstruct ~fs () = let module Kind = Irmin_pack.Pack_value.Kind in - setup_test_env (); - let conf = config ~readonly:false ~fresh:false root_v1 in + setup_test_env ~fs (); (* Open store in RW to migrate it to V3. *) + Eio.Switch.run @@ fun sw -> + let conf = config ~sw ~fs ~readonly:false ~fresh:false (root_v1 ~fs) in let repo = S.Repo.v conf in let () = S.Repo.close repo in (* Test on a V3 store. *) - S.test_traverse_pack_file (`Reconstruct_index `In_place) conf; + S.test_traverse_pack_file ~sw ~fs (`Reconstruct_index `In_place) conf; let index_old = - Index.v_exn ~fresh:false ~readonly:false ~log_size:500_000 tmp + Index.v_exn ~fresh:false ~readonly:false ~log_size:500_000 + (Eio.Path.native_exn @@ tmp ~fs) in let index_new = - Index.v_exn ~fresh:false ~readonly:false ~log_size:500_000 root_v1 + Index.v_exn ~fresh:false ~readonly:false ~log_size:500_000 + (Eio.Path.native_exn @@ root_v1 ~fs) in Index.iter (fun k (offset, length, kind) -> @@ -157,9 +162,10 @@ module Test_reconstruct = struct check_repo r archive; S.Repo.close r - let test_gc_allowed () = - setup_test_env (); - let conf = config ~readonly:false ~fresh:false root_v1 in + let test_gc_allowed ~fs () = + setup_test_env ~fs (); + Eio.Switch.run @@ fun sw -> + let conf = config ~sw ~fs ~readonly:false ~fresh:false (root_v1 ~fs) in let repo = S.Repo.v conf in let allowed = S.Gc.is_allowed repo in Alcotest.(check bool) @@ -168,19 +174,21 @@ module Test_reconstruct = struct end module Test_corrupted_stores = struct - let root_archive, root = - let open Fpath in - ( v "test" / "irmin-pack" / "data" / "corrupted" |> to_string, - v "_build" / "test_integrity" |> to_string ) + let root_archive ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "corrupted") + + let root ~fs = Eio.Path.(fs / "_build" / "test_integrity") - let setup_env () = setup_test_env ~root_archive ~root_local_build:root + let setup_env ~fs () = + setup_test_env ~root_archive:(root_archive ~fs) ~root_local_build:(root ~fs) module S = V2 () include Test (S) - let test () = - setup_env (); - let rw = S.Repo.v (config ~fresh:false root) in + let test ~fs () = + setup_env ~fs (); + Eio.Switch.run @@ fun sw -> + let rw = S.Repo.v (config ~sw ~fs ~fresh:false (root ~fs)) in [%log.app "integrity check on a store where 3 entries are missing from pack"]; let result = S.integrity_check ~auto_repair:false rw in @@ -198,18 +206,21 @@ module Test_corrupted_stores = struct | _ -> Alcotest.fail "Store is repaired, should return Ok"); S.Repo.close rw - let root_archive, root_local_build = - let open Fpath in - ( v "test" / "irmin-pack" / "data" / "version_3_minimal" |> to_string, - v "_build" / "test_corrupt_minimal" |> to_string ) + let root_archive ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_3_minimal") + + let root_local_build ~fs = Eio.Path.(fs / "_build" / "test_corrupt_minimal") - let setup_env () = setup_test_env ~root_archive ~root_local_build + let setup_env ~fs () = + setup_test_env ~root_archive:(root_archive ~fs) + ~root_local_build:(root_local_build ~fs) module IO = Irmin_pack_unix.Io.Unix - let write_corrupted_data_to_suffix () = - let path = Filename.concat root_local_build "store.0.suffix" in - let io = IO.open_ ~path ~readonly:false |> Result.get_ok in + let write_corrupted_data_to_suffix ~fs () = + Eio.Switch.run @@ fun sw -> + let path = Eio.Path.(root_local_build ~fs / "store.0.suffix") in + let io = IO.open_ ~sw ~path ~readonly:false |> Result.get_ok in let corrupted_node_hash = (* the correct hash starts with '9', modified it to have an incorrect hash on disk. *) @@ -221,12 +232,14 @@ module Test_corrupted_stores = struct IO.write_exn io ~off:(Int63.of_int 54) ~len s; IO.close io |> Result.get_ok - let test_minimal () = - setup_env (); + let test_minimal ~fs () = + setup_env ~fs (); [%log.app "integrity check on a good minimal store"]; + Eio.Switch.run @@ fun sw -> let config = - config ~fresh:false - ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal root_local_build + config ~sw ~fs ~fresh:false + ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal + (root_local_build ~fs) in let rw = S.Repo.v config in @@ -242,7 +255,7 @@ module Test_corrupted_stores = struct in let () = S.Repo.close rw in [%log.app "integrity check on a corrupted minimal store"]; - write_corrupted_data_to_suffix (); + write_corrupted_data_to_suffix ~fs (); let rw = S.Repo.v config in let result = S.integrity_check ~heads:[ commit ] ~auto_repair:false rw in let () = @@ -259,19 +272,21 @@ module Test_corrupted_stores = struct end module Test_corrupted_inode = struct - let root_archive, root = - let open Fpath in - ( v "test" / "irmin-pack" / "data" / "corrupted_inode" |> to_string, - v "_build" / "test_integrity_inode" |> to_string ) + let root_archive ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "corrupted_inode") - let setup_test_env () = setup_test_env ~root_archive ~root_local_build:root + let root ~fs = Eio.Path.(fs / "_build" / "test_integrity_inode") + + let setup_test_env ~fs () = + setup_test_env ~root_archive:(root_archive ~fs) ~root_local_build:(root ~fs) module S = V1 () include Test (S) - let test () = - setup_test_env (); - let rw = S.Repo.v (config ~fresh:false root) in + let test ~fs () = + setup_test_env ~fs (); + Eio.Switch.run @@ fun sw -> + let rw = S.Repo.v (config ~sw ~fs ~fresh:false (root ~fs)) in [%log.app "integrity check of inodes on a store with one corrupted inode"]; let c2 = "8d89b97726d9fb650d088cb7e21b78d84d132c6e" in let c2 = commit_of_string rw c2 in @@ -293,17 +308,21 @@ module Test_corrupted_inode = struct end module Test_traverse_gced = struct - let root_archive, root_local_build = - let open Fpath in - ( v "test" / "irmin-pack" / "data" / "version_3_minimal" |> to_string, - v "_build" / "test_reconstruct" |> to_string ) + let root_archive ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_3_minimal") + + let root_local_build ~fs = Eio.Path.(fs / "_build" / "test_reconstruct") - let setup_test_env () = setup_test_env ~root_archive ~root_local_build + let setup_test_env ~fs () = + setup_test_env ~root_archive:(root_archive ~fs) + ~root_local_build:(root_local_build ~fs) module S = V2 () include Test (S) - let commit_and_gc conf = + let commit_and_gc ~fs ~domain_mgr conf = + Eio.Switch.run @@ fun sw -> + let conf = conf ~sw ~fs in let repo = S.Repo.v conf in let commit = commit_of_string repo "22e159de13b427226e5901defd17f0c14e744205" @@ -312,7 +331,7 @@ module Test_traverse_gced = struct let tree = S.Tree.add tree [ "abba"; "baba" ] "x" in let commit = S.Commit.v repo ~info:S.Info.empty ~parents:[] tree in let commit_key = S.Commit.key commit in - let _launched = S.Gc.start_exn ~unlink:false repo commit_key in + let _ = S.Gc.start_exn ~fs ~domain_mgr ~unlink:false repo commit_key in let result = S.Gc.finalise_exn ~wait:true repo in let () = match result with @@ -322,28 +341,31 @@ module Test_traverse_gced = struct in S.Repo.close repo - let test_traverse_pack () = + let test_traverse_pack ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> let module Kind = Irmin_pack.Pack_value.Kind in - setup_test_env (); + setup_test_env ~fs (); let conf = config ~readonly:false ~fresh:false - ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal root_local_build + ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal + (root_local_build ~fs) in - let () = commit_and_gc conf in - S.test_traverse_pack_file `Check_index conf + let () = commit_and_gc ~fs ~domain_mgr conf in + S.test_traverse_pack_file ~sw ~fs `Check_index (conf ~sw ~fs) end -let tests = +let tests ~fs ~domain_mgr = [ Alcotest.test_case "Test index reconstruction" `Quick - Test_reconstruct.test_reconstruct; + (Test_reconstruct.test_reconstruct ~fs); Alcotest.test_case "Test gc not allowed" `Quick - Test_reconstruct.test_gc_allowed; - Alcotest.test_case "Test integrity check" `Quick Test_corrupted_stores.test; + (Test_reconstruct.test_gc_allowed ~fs); + Alcotest.test_case "Test integrity check" `Quick + (Test_corrupted_stores.test ~fs); Alcotest.test_case "Test integrity check minimal stores" `Quick - Test_corrupted_stores.test_minimal; + (Test_corrupted_stores.test_minimal ~fs); Alcotest.test_case "Test integrity check for inodes" `Quick - Test_corrupted_inode.test; + (Test_corrupted_inode.test ~fs); Alcotest.test_case "Test traverse pack on gced store" `Quick - Test_traverse_gced.test_traverse_pack; + (Test_traverse_gced.test_traverse_pack ~fs ~domain_mgr); ] diff --git a/test/irmin-pack/test_existing_stores.mli b/test/irmin-pack/test_existing_stores.mli index 2b40d2f891..fdcff8b3f8 100644 --- a/test/irmin-pack/test_existing_stores.mli +++ b/test/irmin-pack/test_existing_stores.mli @@ -14,4 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest.test_case list +val tests : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + unit Alcotest.test_case list diff --git a/test/irmin-pack/test_flush_reload.ml b/test/irmin-pack/test_flush_reload.ml index 345b67c1b0..261058337c 100644 --- a/test/irmin-pack/test_flush_reload.ml +++ b/test/irmin-pack/test_flush_reload.ml @@ -100,9 +100,9 @@ let write1_no_flush bstore nstore cstore = () (* These tests always open both RW and RO without any data in the model. *) -let start t = - let () = start_rw t in - let () = open_ro t S2_before_write in +let start ~sw ~fs t = + let () = start_rw ~sw ~fs t in + let () = open_ro ~sw ~fs t S2_before_write in let rw = Option.get t.rw |> snd in let ro = Option.get t.ro |> snd in (rw, ro) @@ -110,13 +110,14 @@ let start t = (* Open both stores. RW writes but does not flush - we do this by running the rest of the test inside the [batch]. Then reload the RO at different phases during the flush. *) -let test_one t ~(ro_reload_at : phase_flush) = +let test_one ~fs t ~(ro_reload_at : phase_flush) = + Eio.Switch.run @@ fun sw -> let aux phase = let () = check_ro t in if ro_reload_at = phase then reload_ro t phase; check_ro t in - let rw, _ = start t in + let rw, _ = start ~sw ~fs t in Store.S.Backend.Repo.batch rw (fun bstore nstore cstore -> let () = write1_no_flush bstore nstore cstore in let () = aux S1_before_flush in @@ -130,9 +131,9 @@ let test_one t ~(ro_reload_at : phase_flush) = in aux S4_after_flush) -let test_one_guarded setup ~ro_reload_at = - let t = create_test_env setup in - let () = test_one t ~ro_reload_at in +let test_one_guarded ~fs setup ~ro_reload_at = + let t = create_test_env ~fs setup in + let () = test_one ~fs t ~ro_reload_at in close_everything t let setup = @@ -140,8 +141,8 @@ let setup = for the flush/reload tests. *) { start_mode = From_scratch; indexing_strategy = `always; lru_size = 0 } -let test_flush () = - let t = test_one_guarded setup in +let test_flush ~fs () = + let t = test_one_guarded ~fs setup in let () = t ~ro_reload_at:S1_before_flush in let () = t ~ro_reload_at:S2_after_flush_dict in let () = t ~ro_reload_at:S3_after_flush_suffix in @@ -191,9 +192,10 @@ let flush_rw t (current_phase : phase_reload) = in match t.rw with None -> assert false | Some (_, repo) -> Store.S.flush repo -let test_one t ~(rw_flush_at : phase_reload) = +let test_one ~fs t ~(rw_flush_at : phase_reload) = + Eio.Switch.run @@ fun sw -> let aux phase = if rw_flush_at = phase then flush_rw t phase in - let rw, ro = start t in + let rw, ro = start ~sw ~fs t in let reload_ro () = Store.S.Backend.Repo.batch rw (fun bstore nstore cstore -> let () = write1_no_flush bstore nstore cstore in @@ -213,13 +215,13 @@ let test_one t ~(rw_flush_at : phase_reload) = let () = reload_ro () in check_ro t -let test_one_guarded setup ~rw_flush_at = - let t = create_test_env setup in - let () = test_one t ~rw_flush_at in +let test_one_guarded setup ~fs ~rw_flush_at = + let t = create_test_env ~fs setup in + let () = test_one ~fs t ~rw_flush_at in close_everything t -let test_reload () = - let t = test_one_guarded setup in +let test_reload ~fs () = + let t = test_one_guarded setup ~fs in let () = t ~rw_flush_at:S1_before_reload in let () = t ~rw_flush_at:S2_after_reload_index in let () = t ~rw_flush_at:S3_after_reload_control in @@ -227,8 +229,8 @@ let test_reload () = let () = t ~rw_flush_at:S5_after_reload in () -let tests = +let tests ~fs = [ - Alcotest.test_case "Reload during flush stages" `Quick test_flush; - Alcotest.test_case "Flush during reload stages" `Quick test_reload; + Alcotest.test_case "Reload during flush stages" `Quick (test_flush ~fs); + Alcotest.test_case "Flush during reload stages" `Quick (test_reload ~fs); ] diff --git a/test/irmin-pack/test_gc.ml b/test/irmin-pack/test_gc.ml index 5e6081890d..0b160324ff 100644 --- a/test/irmin-pack/test_gc.ml +++ b/test/irmin-pack/test_gc.ml @@ -23,31 +23,33 @@ module Log = (val Logs.src_log src : Logs.LOG) let test_dir = "_build" -let fresh_name = +let fresh_name ~fs = let c = ref 0 in fun () -> incr c; - let name = Filename.concat test_dir ("test-gc" ^ string_of_int !c) in - name + Eio.Path.(fs / test_dir / ("test-gc" ^ string_of_int !c)) -let create_v1_test_env () = - let ( / ) = Filename.concat in - let root_archive = "test" / "irmin-pack" / "data" / "version_1_large" in - let root_local_build = "_build" / "test-v1-gc" in +let create_v1_test_env ~fs () = + let root_archive = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_1_large") + in + let root_local_build = Eio.Path.(fs / "_build" / "test-v1-gc") in setup_test_env ~root_archive ~root_local_build; root_local_build -let create_from_v2_always_test_env () = - let ( / ) = Filename.concat in - let root_archive = "test" / "irmin-pack" / "data" / "version_2_to_3_always" in - let root_local_build = "_build" / "test-from-v2-always-gc" in +let create_from_v2_always_test_env ~fs () = + let root_archive = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_2_to_3_always") + in + let root_local_build = Eio.Path.(fs / "_build" / "test-from-v2-always-gc") in setup_test_env ~root_archive ~root_local_build; root_local_build -let create_test_env () = - let ( / ) = Filename.concat in - let root_archive = "test" / "irmin-pack" / "data" / "version_3_minimal" in - let root_local_build = "_build" / "test-gc" in +let create_test_env ~fs () = + let root_archive = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_3_minimal") + in + let root_local_build = Eio.Path.(fs / "_build" / "test-gc") in setup_test_env ~root_archive ~root_local_build; root_local_build @@ -60,22 +62,22 @@ module Store = struct end type t = { - root : string; + root : Eio.Fs.dir_ty Eio.Path.t; repo : S.Repo.t; parents : S.Commit.t list; tree : S.tree; } - let config ~lru_size ~readonly ~fresh ?lower_root root = - Irmin_pack.config ~readonly ?lower_root + let config ~sw ~fs ~lru_size ~readonly ~fresh ?lower_root root = + Irmin_pack.config ~sw ~fs ~readonly ?lower_root ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal ~fresh ~lru_size root let info = S.Info.empty - let start_gc ?(unlink = false) t commit = + let start_gc ~fs ~domain_mgr ?(unlink = false) t commit = let commit_key = S.Commit.key commit in - let _launched = S.Gc.start_exn ~unlink t.repo commit_key in + let _ = S.Gc.start_exn ~fs ~domain_mgr ~unlink t.repo commit_key in () let finalise_gc_with_stats t = @@ -116,23 +118,25 @@ module Store = struct let o = checkout t key in match o with None -> raise Not_found | Some p -> p - let init ?(lru_size = 0) ?(readonly = false) ?(fresh = true) ?root + let init ~sw ~fs ?(lru_size = 0) ?(readonly = false) ?(fresh = true) ?root ?(lower_root = None) () = (* start with a clean dir if fresh *) - let root = Option.value root ~default:(fresh_name ()) in + let root = Option.value root ~default:(fresh_name ~fs ()) in if fresh then ( rm_dir root; Option.iter rm_dir lower_root); - let repo = S.Repo.v (config ~readonly ~fresh ~lru_size ~lower_root root) in + let repo = + S.Repo.v (config ~sw ~fs ~readonly ~fresh ~lru_size ~lower_root root) + in let tree = S.Tree.empty () in { root; repo; tree; parents = [] } - let config root = - config ~lru_size:0 ~readonly:false ~fresh:true ~lower_root:None root + let config ~sw ~fs root = + config ~sw ~fs ~lru_size:0 ~readonly:false ~fresh:true ~lower_root:None root - let init_with_config config = + let init_with_config ~fs config = let repo = S.Repo.v config in - let root = Irmin_pack.Conf.root config in + let root = Eio.Path.(fs / Irmin_pack.Conf.root config) in let tree = S.Tree.empty () in { root; repo; tree; parents = [] } @@ -252,33 +256,44 @@ let check_not_found t key msg = module type Gc_backend = sig val init : - ?lru_size:int -> ?readonly:bool -> ?fresh:bool -> ?root:string -> unit -> t + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + ?lru_size:int -> + ?readonly:bool -> + ?fresh:bool -> + ?root:Eio.Fs.dir_ty Eio.Path.t -> + unit -> + t val check_gced : t -> S.commit -> string -> unit val check_removed : t -> S.commit -> string -> unit end +let file_exists path = + match Eio.Path.kind ~follow:false path with `Not_found -> false | _ -> true + let rec check_async_unlinked ?(timeout = 3.141) file = if timeout < 0.0 then false - else if Sys.file_exists file then ( + else if file_exists file then ( Unix.sleepf 0.2; check_async_unlinked ~timeout:(timeout -. 0.2) file) else true module Gc_common (B : Gc_backend) = struct (** Check that gc preserves and deletes commits accordingly. *) - let one_gc () = + let one_gc ~fs ~domain_mgr () = (* c1 - c2 *) (* \---- c3 *) (* gc(c3) *) - let t = B.init () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in let t = checkout_exn t c1 in let t, c3 = commit_3 t in [%log.debug "Gc c1, c2, keep c3"]; - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in let () = B.check_gced t c1 "gced c1" in let () = B.check_removed t c2 "gced c2" in @@ -286,11 +301,12 @@ module Gc_common (B : Gc_backend) = struct S.Repo.close t.repo (** Check that calling gc twice works. *) - let two_gc () = + let two_gc ~fs ~domain_mgr () = (* gc(c4) gc(c5) *) (* c1 - c2 --- c4 -------- c5 *) (* \---- c3 *) - let t = B.init () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in @@ -299,13 +315,13 @@ module Gc_common (B : Gc_backend) = struct let t = checkout_exn t c2 in let t, c4 = commit_4 t in [%log.debug "Gc c1, c2, c3, keep c4"]; - let () = start_gc t c4 in + let () = start_gc ~fs ~domain_mgr t c4 in let () = finalise_gc t in let t = checkout_exn t c4 in let t, c5 = commit_5 t in let () = check_5 t c5 in [%log.debug "Gc c4, keep c5"]; - let () = start_gc t c5 in + let () = start_gc ~fs ~domain_mgr t c5 in let () = finalise_gc t in let () = check_5 t c5 in let () = B.check_gced t c1 "gced c1" in @@ -315,17 +331,18 @@ module Gc_common (B : Gc_backend) = struct S.Repo.close t.repo (** Check that calling gc on first commit of chain keeps everything. *) - let gc_keeps_all () = + let gc_keeps_all ~fs ~domain_mgr () = (* c1 - c2 - c3 *) (* gc(c1) *) - let t = B.init () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in let t = checkout_exn t c2 in let t, c3 = commit_3 t in [%log.debug "Keep c1, c2, c3"]; - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let () = finalise_gc t in let () = check_1 t c1 in let () = check_2 t c2 in @@ -333,17 +350,18 @@ module Gc_common (B : Gc_backend) = struct S.Repo.close t.repo (** Check that adding back gced commits works. *) - let gc_add_back () = + let gc_add_back ~fs ~domain_mgr () = (* c1 - c_del - c3 ------ c1 - c2 ------- c3 *) (* gc(c3) gc(c1) *) - let t = B.init () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c_del = commit_del t in let t = checkout_exn t c_del in let t, c3 = commit_3 t in [%log.debug "Gc c1, c_del, keep c3"]; - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in let () = B.check_gced t c1 "gced c1" in let () = B.check_gced t c_del "gced c_del" in @@ -357,7 +375,7 @@ module Gc_common (B : Gc_backend) = struct let t, c2 = commit_2 t in let () = check_2 t c2 in [%log.debug "Gc c3, keep c1, c2"]; - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let () = finalise_gc t in let () = B.check_gced t c3 "gced c3" in let () = check_2 t c2 in @@ -369,60 +387,67 @@ module Gc_common (B : Gc_backend) = struct S.Repo.close t.repo (** Check that gc and close work together. *) - let close () = + let close ~fs ~domain_mgr () = (* c1 ------ c2 *) (* gc(c1) gc(c2) *) (* close close close *) - let t = B.init () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let store_name = t.root in let t, c1 = commit_1 t in - let () = start_gc ~unlink:false t c1 in + let () = start_gc ~fs ~domain_mgr ~unlink:false t c1 in let () = finalise_gc t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in let () = S.Repo.close t.repo in Alcotest.(check bool) "unlink:false" true - (Sys.file_exists (Filename.concat store_name "store.0.suffix")); - let t = B.init ~readonly:true ~fresh:false ~root:store_name () in + (file_exists Eio.Path.(store_name / "store.0.suffix")); + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs ~readonly:true ~fresh:false ~root:store_name () in let () = S.Repo.close t.repo in Alcotest.(check bool) "RO no clean up" true - (Sys.file_exists (Filename.concat store_name "store.0.suffix")); - let t = B.init ~readonly:false ~fresh:false ~root:store_name () in + (file_exists Eio.Path.(store_name / "store.0.suffix")); + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs ~readonly:false ~fresh:false ~root:store_name () in let () = S.Repo.close t.repo in Alcotest.(check bool) "RW cleaned up" true - (check_async_unlinked (Filename.concat store_name "store.0.prefix")); - let t = B.init ~readonly:false ~fresh:false ~root:store_name () in + (check_async_unlinked Eio.Path.(store_name / "store.0.prefix")); + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs ~readonly:false ~fresh:false ~root:store_name () in let () = check_1 t c1 in let () = check_2 t c2 in let () = S.Repo.close t.repo in - let t = B.init ~readonly:false ~fresh:false ~root:store_name () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs ~readonly:false ~fresh:false ~root:store_name () in [%log.debug "Gc c1, keep c2"]; - let () = start_gc ~unlink:true t c2 in + let () = start_gc ~fs ~domain_mgr ~unlink:true t c2 in let () = finalise_gc t in let () = S.Repo.close t.repo in Alcotest.(check bool) "unlink:true" true - (check_async_unlinked (Filename.concat store_name "store.1.suffix")); - let t = B.init ~readonly:false ~fresh:false ~root:store_name () in + (check_async_unlinked Eio.Path.(store_name / "store.1.suffix")); + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs ~readonly:false ~fresh:false ~root:store_name () in let () = B.check_gced t c1 "gced c1" in let () = check_2 t c2 in S.Repo.close t.repo (** Check that gc works on a commit with two parents. *) - let gc_commit_with_two_parents () = + let gc_commit_with_two_parents ~fs ~domain_mgr () = (* gc(c3) *) (* c1 - c3 *) (* c2 -/ *) - let t = B.init () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in let t = { t with parents = [ c1; c2 ] } in let t, c3 = commit_3 t in - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in let () = B.check_gced t c1 "gced c1" in let () = B.check_gced t c2 "gced c2" in @@ -430,13 +455,14 @@ module Gc_common (B : Gc_backend) = struct S.Repo.close t.repo (** Check that gc preserves and deletes commits from RO. *) - let gc_ro () = + let gc_ro ~fs ~domain_mgr () = (* c1 ---- c3 ------------------- c4 - c5 *) (* \- c2 *) (* gc(c3) gc(c4) *) (* reload reload reload reload *) - let t = B.init () in - let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in + let ro_t = B.init ~sw ~fs ~readonly:true ~fresh:false ~root:t.root () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in @@ -444,7 +470,7 @@ module Gc_common (B : Gc_backend) = struct let t, c3 = commit_3 t in S.reload ro_t.repo; [%log.debug "Gc c1, c2, keeps c3"]; - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in [%log.debug "RO finds everything before reload"]; let () = check_1 ro_t c1 in @@ -461,7 +487,7 @@ module Gc_common (B : Gc_backend) = struct let t, c5 = commit_5 t in S.reload ro_t.repo; [%log.debug "Gc c3, keep c4, c5"]; - let () = start_gc t c4 in + let () = start_gc ~fs ~domain_mgr t c4 in let () = finalise_gc t in [%log.debug "RO finds c3, c4, c5 before reload"]; let () = check_3 ro_t c3 in @@ -476,19 +502,20 @@ module Gc_common (B : Gc_backend) = struct S.Repo.close ro_t.repo (** Check that RO works if reload is called after two gcs. *) - let ro_after_two_gc () = + let ro_after_two_gc ~fs ~domain_mgr () = (* c1 ------- c2 *) (* gc(c1) gc(c2) *) (* reload *) - let t = B.init () in - let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in + let ro_t = B.init ~sw ~fs ~readonly:true ~fresh:false ~root:t.root () in let t, c1 = commit_1 t in S.reload ro_t.repo; - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let () = finalise_gc t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in [%log.debug "RO finds c1, but c2 gced before reload"]; let () = check_1 ro_t c1 in @@ -501,17 +528,18 @@ module Gc_common (B : Gc_backend) = struct S.Repo.close ro_t.repo (** Check that gc and close and ro work together. *) - let ro_close () = - let t = B.init () in - let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + let ro_close ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in + let ro_t = B.init ~sw ~fs ~readonly:true ~fresh:false ~root:t.root () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in let () = S.Repo.close ro_t.repo in - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in [%log.debug "RO reopens is similar to a reload"]; - let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + let ro_t = B.init ~sw ~fs ~readonly:true ~fresh:false ~root:t.root () in let () = check_2 ro_t c2 in let () = B.check_gced ro_t c1 "gced c1" in let t = checkout_exn t c2 in @@ -524,10 +552,11 @@ module Gc_common (B : Gc_backend) = struct S.Repo.close ro_t.repo (** Check opening RO store and calling reload right after. *) - let ro_reload_after_v () = - let t = B.init () in + let ro_reload_after_v ~fs () = + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in - let ro_t = B.init ~readonly:true ~fresh:false ~root:t.root () in + let ro_t = B.init ~sw ~fs ~readonly:true ~fresh:false ~root:t.root () in S.reload ro_t.repo; let () = check_1 ro_t c1 in let () = S.Repo.close t.repo in @@ -535,7 +564,7 @@ module Gc_common (B : Gc_backend) = struct (** Check that gc works when the lru caches some objects that are delete by consequent commits. See https://github.com/mirage/irmin/issues/1920. *) - let gc_lru () = + let gc_lru ~fs ~domain_mgr () = let check t c = S.Commit.of_key t.repo (S.Commit.key c) |> function | None -> Alcotest.fail "no hash found in repo" @@ -543,7 +572,8 @@ module Gc_common (B : Gc_backend) = struct let tree = S.Commit.tree commit in check_blob tree [ "a"; "b"; "c" ] "b" in - let t = B.init ~lru_size:100 () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs ~lru_size:100 () in let t = set t [ "a"; "b"; "c" ] "b" in let c1 = commit t in let t = checkout_exn t c1 in @@ -555,38 +585,40 @@ module Gc_common (B : Gc_backend) = struct let t = checkout_exn t c3 in let t = set t [ "a"; "b"; "e" ] "a" in let c4 = commit t in - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in let () = check t c4 in S.Repo.close t.repo (** Check that calling gc during a batch raises an error. *) - let gc_during_batch () = - let t = B.init () in + let gc_during_batch ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in let _ = Alcotest.check_raises "Should not call gc in batch" (Irmin_pack_unix.Errors.Pack_error `Gc_forbidden_during_batch) (fun () -> S.Backend.Repo.batch t.repo (fun _ _ _ -> - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in finalise_gc t)) in S.Repo.close t.repo (** Add back commits after they were gced. *) - let add_back_gced_commit () = + let add_back_gced_commit ~fs ~domain_mgr () = (* c1 - c2 - c3 *) (* gc(c3) *) (* c1 - c2 *) - let t = B.init () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in let t = checkout_exn t c2 in let t, c3 = commit_3 t in [%log.debug "Keep c3 gc c1 c2"]; - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in let () = B.check_gced t c1 "gced c1" in let () = B.check_gced t c2 "gced c2" in @@ -604,21 +636,23 @@ module Gc_common (B : Gc_backend) = struct let () = check_3 t c3 in S.Repo.close t.repo - let gc_similar_commits () = - let t = B.init () in + let gc_similar_commits ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let () = finalise_gc t in let t = checkout_exn t c1 in let t, c1_again = commit_1_different_author t in - let () = start_gc t c1_again in + let () = start_gc ~fs ~domain_mgr t c1_again in let () = finalise_gc t in let () = check_1 t c1_again in S.Repo.close t.repo (** Check [Gc.latest_gc_target]. *) - let latest_gc_target () = - let t = B.init () in + let latest_gc_target ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let check_latest_gc_target expected = let got = S.Gc.latest_gc_target t.repo in match (got, expected) with @@ -633,18 +667,18 @@ module Gc_common (B : Gc_backend) = struct let t = checkout_exn t c1 in check_latest_gc_target None; let t, c2 = commit_2 t in - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in check_latest_gc_target (Some c2); let t = checkout_exn t c2 in let t, c3 = commit_3 t in - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in check_latest_gc_target (Some c3); S.Repo.close t.repo (** Check Gc stats. *) - let gc_stats () = + let gc_stats ~fs ~domain_mgr () = let check_stats (stats : Irmin_pack_unix.Stats.Latest_gc.stats) = let objects_traversed = stats.worker.objects_traversed |> Int63.to_int in Alcotest.(check int) "objects_traversed" objects_traversed 8; @@ -663,22 +697,24 @@ module Gc_common (B : Gc_backend) = struct files in - let t = B.init () in + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () 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 () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in let t = checkout_exn t c2 in let t, c3 = commit_3 t in - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let stats = finalise_gc_with_stats t in check_stats (Option.get stats); S.Repo.close t.repo (** Check that a GC clears the LRU *) - let gc_clears_lru () = - let t = init ~lru_size:100 () in + let gc_clears_lru ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~lru_size:100 () in (* Rreate some commits *) let t, c1 = commit_1 t in let t = checkout_exn t c1 in @@ -689,33 +725,36 @@ module Gc_common (B : Gc_backend) = struct let () = check_2 t c2 in let () = check_3 t c3 in (* GC *) - let count_before_gc = lru_hits () in - let () = start_gc t c2 in + (* TODO: Now that the GC is not in another process, it cleans every stats. + Make the stats domain dependant ? *) + (* let count_before_gc = lru_hits () in *) + let () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in (* Read data again *) let () = check_3 t c3 in - Alcotest.(check int) "GC does clear LRU" count_before_gc (lru_hits ()); + Alcotest.(check int) "GC does clear LRU" 0 (lru_hits ()); S.Repo.close t.repo - let tests = + let tests ~fs ~domain_mgr = [ - tc "Test one gc" one_gc; - tc "Test twice gc" two_gc; - tc "Test gc keeps commits" gc_keeps_all; - tc "Test adding back commits" gc_add_back; - tc "Test close" close; - tc "Test gc commit with two parents" gc_commit_with_two_parents; - tc "Test gc ro" gc_ro; - tc "Test reload after two gc" ro_after_two_gc; - tc "Test ro close" ro_close; - tc "Test ro reload after open" ro_reload_after_v; - tc "Test lru" gc_lru; - tc "Test gc during batch" gc_during_batch; - tc "Test add back gced commit" add_back_gced_commit; - tc "Test gc on similar commits" gc_similar_commits; - tc "Test oldest live commit" latest_gc_target; - tc "Test worker gc stats" gc_stats; - tc "Test gc_clears_lru" gc_clears_lru; + tc "Test one gc" (one_gc ~fs ~domain_mgr); + tc "Test twice gc" (two_gc ~fs ~domain_mgr); + tc "Test gc keeps commits" (gc_keeps_all ~fs ~domain_mgr); + tc "Test adding back commits" (gc_add_back ~fs ~domain_mgr); + tc "Test close" (close ~fs ~domain_mgr); + tc "Test gc commit with two parents" + (gc_commit_with_two_parents ~fs ~domain_mgr); + tc "Test gc ro" (gc_ro ~fs ~domain_mgr); + tc "Test reload after two gc" (ro_after_two_gc ~fs ~domain_mgr); + tc "Test ro close" (ro_close ~fs ~domain_mgr); + tc "Test ro reload after open" (ro_reload_after_v ~fs); + tc "Test lru" (gc_lru ~fs ~domain_mgr); + tc "Test gc during batch" (gc_during_batch ~fs ~domain_mgr); + tc "Test add back gced commit" (add_back_gced_commit ~fs ~domain_mgr); + tc "Test gc on similar commits" (gc_similar_commits ~fs ~domain_mgr); + tc "Test oldest live commit" (latest_gc_target ~fs ~domain_mgr); + tc "Test worker gc stats" (gc_stats ~fs ~domain_mgr); + tc "Test gc_clears_lru" (gc_clears_lru ~fs ~domain_mgr); ] end @@ -735,9 +774,10 @@ module Gc_archival = struct in Alcotest.testable pp Stdlib.( = ) - let gc_availability_recent () = - let lower_root = create_lower_root ~mkdir:false () in - let t = init ~lower_root:(Some lower_root) () in + let gc_availability_recent ~fs () = + Eio.Switch.run @@ fun sw -> + let lower_root = create_lower_root ~fs ~mkdir:false () in + let t = init ~sw ~fs ~lower_root:(Some lower_root) () in Alcotest.(check gc_behaviour) "recent stores with a lower use archiving gc" (S.Gc.behaviour t.repo) `Archive; @@ -745,7 +785,8 @@ module Gc_archival = struct "archiving gc allowed on recent stores with a lower" (S.Gc.is_allowed t.repo) true; let () = S.Repo.close t.repo in - let t = init () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in Alcotest.(check gc_behaviour) "recent stores without a lower use deleting gc" (S.Gc.behaviour t.repo) `Delete; @@ -754,10 +795,11 @@ module Gc_archival = struct (S.Gc.is_allowed t.repo) true; S.Repo.close t.repo - let gc_availability_old () = - let root = create_v1_test_env () in - let lower_root = create_lower_root () in - let t = init ~root ~fresh:false ~lower_root:(Some lower_root) () in + let gc_availability_old ~fs () = + Eio.Switch.run @@ fun sw -> + let root = create_v1_test_env ~fs () in + let lower_root = create_lower_root ~fs () in + let t = init ~sw ~fs ~root ~fresh:false ~lower_root:(Some lower_root) () in Alcotest.(check gc_behaviour) "old stores with a lower use archiving gc" (S.Gc.behaviour t.repo) `Archive; @@ -765,8 +807,9 @@ module Gc_archival = struct "archiving gc allowed on old stores with a lower" (S.Gc.is_allowed t.repo) true; let () = S.Repo.close t.repo in - let root = create_v1_test_env () in - let t = init ~root ~fresh:false () in + let root = create_v1_test_env ~fs () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~root ~fresh:false () in Alcotest.(check gc_behaviour) "old stores without a lower use deleting gc" (S.Gc.behaviour t.repo) `Delete; @@ -775,11 +818,12 @@ module Gc_archival = struct (S.Gc.is_allowed t.repo) false; S.Repo.close t.repo - let gc_reachability_old () = - let root = create_v1_test_env () in - let lower_root = create_lower_root () in + let gc_reachability_old ~fs ~domain_mgr () = + let root = create_v1_test_env ~fs () in + let lower_root = create_lower_root ~fs () in [%log.debug "Open v1 store to trigger migration"]; - let t = init ~root ~fresh:false ~lower_root:(Some lower_root) () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~root ~fresh:false ~lower_root:(Some lower_root) () in let main = S.main t.repo in [%log.debug "Run GC on commit that is now in lower"]; let head = S.Head.get main in @@ -792,15 +836,17 @@ module Gc_archival = struct true | _ -> assert false in - let () = start_gc t head in + let () = start_gc ~fs ~domain_mgr t head in let () = finalise_gc t in S.Repo.close t.repo module B = struct - let init ?lru_size ?readonly ?fresh ?root () = - let root = Option.value root ~default:(fresh_name ()) in - let lower_root = root ^ ".lower" in - init ?lru_size ?readonly ?fresh ~root ~lower_root:(Some lower_root) () + let init ~sw ~fs ?lru_size ?readonly ?fresh ?root () = + let root = Option.value root ~default:(fresh_name ~fs ()) in + let dir_name, root_name = Option.get @@ Eio.Path.split root in + let lower_root = Eio.Path.(dir_name / (root_name ^ ".lower")) in + init ~sw ~fs ?lru_size ?readonly ?fresh ~root + ~lower_root:(Some lower_root) () let check_gced t c s = let c = S.Commit.of_key t.repo (S.Commit.key c) in @@ -809,8 +855,9 @@ module Gc_archival = struct let check_removed = check_not_found end - let gc_archival_multiple_volumes () = - let t = B.init () in + let gc_archival_multiple_volumes ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = B.init ~sw ~fs () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in @@ -819,7 +866,7 @@ module Gc_archival = struct let t = checkout_exn t c2 in let t, c4 = commit_4 t in [%log.debug "Gc c1, c2, c3, keep c4"]; - let () = start_gc t c4 in + let () = start_gc ~fs ~domain_mgr t c4 in let () = finalise_gc t in [%log.debug "Add a new volume"]; S.add_volume t.repo; @@ -827,7 +874,7 @@ module Gc_archival = struct let t, c5 = commit_5 t in let () = check_5 t c5 in [%log.debug "Gc c4, keep c5"]; - let () = start_gc t c5 in + let () = start_gc ~fs ~domain_mgr t c5 in let () = finalise_gc t in let () = check_5 t c5 in let () = B.check_gced t c1 "gced c1" in @@ -837,34 +884,35 @@ module Gc_archival = struct let () = Alcotest.check_raises_pack_error "Cannot GC on commit older than c5" (function `Gc_disallowed _ -> true | _ -> false) - (fun () -> start_gc t c4) + (fun () -> start_gc ~fs ~domain_mgr t c4) in S.Repo.close t.repo module Gc_common_tests = Gc_common (B) - let tests = + let tests ~fs ~domain_mgr = [ tc "Test availability of different gc modes on recent stores" - gc_availability_recent; + (gc_availability_recent ~fs); tc "Test availability of different gc modes on old stores" - gc_availability_old; + (gc_availability_old ~fs); tc "Test archiving twice on different volumes" - gc_archival_multiple_volumes; - tc "Test reachability on old stores" gc_reachability_old; + (gc_archival_multiple_volumes ~fs ~domain_mgr); + tc "Test reachability on old stores" (gc_reachability_old ~fs ~domain_mgr); ] - @ Gc_common_tests.tests + @ Gc_common_tests.tests ~fs ~domain_mgr end module Concurrent_gc = struct (** Check that finding old objects during a gc works. *) - let find_running_gc ~lru_size () = - let t = init ~lru_size () in + let find_running_gc ~fs ~domain_mgr ~lru_size () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~lru_size () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = check_1 t c1 in let () = check_2 t c2 in let () = finalise_gc t in @@ -873,13 +921,14 @@ module Concurrent_gc = struct S.Repo.close t.repo (** Check adding new objects during a gc and finding them after the gc. *) - let add_running_gc ~lru_size () = - let t = init ~lru_size () in + let add_running_gc ~fs ~domain_mgr ~lru_size () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~lru_size () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let t = checkout_exn t c2 in let t, c3 = commit_3 t in let () = finalise_gc t in @@ -889,22 +938,23 @@ module Concurrent_gc = struct S.Repo.close t.repo (** Check adding new objects during a gc and finding them after the gc. *) - let several_gc ~lru_size () = - let t = init ~lru_size () in + let several_gc ~fs ~domain_mgr ~lru_size () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~lru_size () in let t, c1 = commit_1 t in - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let t = checkout_exn t c1 in let t, c2 = commit_2 t in let () = finalise_gc t in - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let t = checkout_exn t c2 in let t, c3 = commit_3 t in let () = finalise_gc t in - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let t = checkout_exn t c3 in let t, c4 = commit_4 t in let () = finalise_gc t in - let () = start_gc t c4 in + let () = start_gc ~fs ~domain_mgr t c4 in let t = checkout_exn t c4 in let t, c5 = commit_5 t in let () = finalise_gc t in @@ -924,14 +974,15 @@ module Concurrent_gc = struct (** Check that RO can find old objects during gc. Also that RO can still find removed objects before a call to [reload]. *) - let ro_find_running_gc () = - let t = init () in - let ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let ro_find_running_gc ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in + let ro_t = init ~sw ~fs ~readonly:true ~fresh:false ~root:t.root () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in S.reload ro_t.repo; let () = check_1 ro_t c1 in S.reload ro_t.repo; @@ -947,14 +998,15 @@ module Concurrent_gc = struct (** Check that RO can find objects added during gc, but only after a call to [reload]. *) - let ro_add_running_gc () = - let t = init () in - let ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let ro_add_running_gc ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in + let ro_t = init ~sw ~fs ~readonly:true ~fresh:false ~root:t.root () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in S.reload ro_t.repo; let t = checkout_exn t c2 in let t, c3 = commit_3 t in @@ -974,19 +1026,20 @@ module Concurrent_gc = struct (** Check that RO can call [reload] during a second gc, even after no reloads occured during the first gc. *) - let ro_reload_after_second_gc () = - let t = init () in - let ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let ro_reload_after_second_gc ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in + let ro_t = init ~sw ~fs ~readonly:true ~fresh:false ~root:t.root () in let t, c1 = commit_1 t in let t = checkout_exn t c1 in let t, c2 = commit_2 t in [%log.debug "Gc c1 keep c2"]; - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in let t = checkout_exn t c2 in let t, c3 = commit_3 t in [%log.debug "Gc c2 keep c3"]; - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in S.reload ro_t.repo; let () = check_not_found ro_t c1 "removed c1" in @@ -996,10 +1049,11 @@ module Concurrent_gc = struct S.Repo.close ro_t.repo (** Check that calling reload in RO will clear the LRU only after GC. *) - let ro_reload_clears_lru () = - let rw_t = init () in + let ro_reload_clears_lru ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let rw_t = init ~sw ~fs () in let ro_t = - init ~lru_size:100 ~readonly:true ~fresh:false ~root:rw_t.root () + init ~sw ~fs ~lru_size:100 ~readonly:true ~fresh:false ~root:rw_t.root () in (* Create some commits in RW *) let rw_t, c1 = commit_1 rw_t in @@ -1018,35 +1072,39 @@ module Concurrent_gc = struct "reload does not clear LRU" true (count_before_reload < lru_hits ()); (* GC *) - let count_before_gc = lru_hits () in - let () = start_gc rw_t c2 in + (* let count_before_gc = lru_hits () in *) + let () = start_gc ~fs ~domain_mgr rw_t c2 in let () = finalise_gc rw_t in (* Reload RO to get changes and clear LRU, and read some data *) S.reload ro_t.repo; let () = check_3 ro_t c3 in - Alcotest.(check int) "reload does clear LRU" count_before_gc (lru_hits ()); + (* TODO: GC resets the stats now that it is not another process *) + Alcotest.(check int) "reload does clear LRU" 0 (lru_hits ()); let () = S.Repo.close rw_t.repo in S.Repo.close ro_t.repo (** Check that calling close during a gc kills the gc without finalising it. On reopening the store, the following gc works fine. *) - let close_running_gc () = - let t = init () in + let close_running_gc ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let () = S.Repo.close t.repo in - let t = init ~readonly:false ~fresh:false ~root:t.root () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~readonly:false ~fresh:false ~root:t.root () in let () = check_1 t c1 in let t = checkout_exn t c1 in let t, c2 = commit_2 t in - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in let t = checkout_exn t c2 in S.Repo.close t.repo (** Check that the cleanup routine in file manager deletes correct files. *) - let test_cancel_cleanup () = - let t = init () in + let test_cancel_cleanup ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in (* chunk 0, commit 1 *) let t, c1 = commit_1 t in let () = S.split t.repo in @@ -1056,18 +1114,19 @@ module Concurrent_gc = struct let () = S.split t.repo in (* GC chunk 0 - important to have at least one GC to test the cleanup routine's usage of generation *) - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in (* chunk 2, commit 3 *) let t = checkout_exn t c2 in let t, c3 = commit_3 t in let () = S.split t.repo in (* Start GC and then close repo before finalise *) - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = S.Repo.close t.repo in (* Reopen store. If the cleanup on cancel deletes wrong files, the store will fail to open. *) - let t = init ~readonly:false ~fresh:false ~root:t.root () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~readonly:false ~fresh:false ~root:t.root () in (* Check commits *) let () = check_not_found t c1 "removed c1" in (* commit 2 is still around because its GC was interrupted *) @@ -1076,15 +1135,16 @@ module Concurrent_gc = struct S.Repo.close t.repo (** Check starting a gc before a previous is finalised. *) - let test_skip () = - let t = init () in + let test_skip ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () 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 () = start_gc ~fs ~domain_mgr t c2 in let t = checkout_exn t c2 in let t, c3 = commit_3 t in - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in let () = check_not_found t c1 "removed c1" in let () = check_2 t c2 in @@ -1096,10 +1156,11 @@ module Concurrent_gc = struct if S.Internal.kill_gc repo then true else Alcotest.failf "running_gc missing after call to start" - let test_kill_gc_and_finalise () = - let t = init () in + let test_kill_gc_and_finalise ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let killed = kill_gc t in let () = if killed then @@ -1111,36 +1172,41 @@ module Concurrent_gc = struct in S.Repo.close t.repo - let test_kill_gc_and_close () = - let t = init () in + let test_kill_gc_and_close ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let _killed = kill_gc t in S.Repo.close t.repo - let tests = + let tests ~fs ~domain_mgr = [ - tc "Test find_running_gc" find_running_gc; - tc "Test add_running_gc" add_running_gc; - tc "Test several_gc" several_gc; - tc "Test find_running_gc_with_lru" find_running_gc_with_lru; - tc "Test add_running_gc_with_lru" add_running_gc_with_lru; - tc "Test several_gc_with_lru" several_gc_with_lru; - tc "Test ro_find_running_gc" ro_find_running_gc; - tc "Test ro_add_running_gc" ro_add_running_gc; - tc "Test ro_reload_after_second_gc" ro_reload_after_second_gc; - tc "Test ro_reload_clears_lru" ro_reload_clears_lru; - tc "Test close_running_gc" close_running_gc; - tc "Test skip gc" test_skip; - tc "Test kill gc and finalise" test_kill_gc_and_finalise; - tc "Test kill gc and close" test_kill_gc_and_close; - tc "Test gc cancel cleanup" test_cancel_cleanup; + tc "Test find_running_gc" (find_running_gc ~fs ~domain_mgr); + tc "Test add_running_gc" (add_running_gc ~fs ~domain_mgr); + tc "Test several_gc" (several_gc ~fs ~domain_mgr); + tc "Test find_running_gc_with_lru" + (find_running_gc_with_lru ~fs ~domain_mgr); + tc "Test add_running_gc_with_lru" + (add_running_gc_with_lru ~fs ~domain_mgr); + tc "Test several_gc_with_lru" (several_gc_with_lru ~fs ~domain_mgr); + tc "Test ro_find_running_gc" (ro_find_running_gc ~fs ~domain_mgr); + tc "Test ro_add_running_gc" (ro_add_running_gc ~fs ~domain_mgr); + tc "Test ro_reload_after_second_gc" + (ro_reload_after_second_gc ~fs ~domain_mgr); + tc "Test ro_reload_clears_lru" (ro_reload_clears_lru ~fs ~domain_mgr); + tc "Test close_running_gc" (close_running_gc ~fs ~domain_mgr); + tc "Test skip gc" (test_skip ~fs ~domain_mgr); + tc "Test kill gc and finalise" (test_kill_gc_and_finalise ~fs ~domain_mgr); + tc "Test kill gc and close" (test_kill_gc_and_close ~fs ~domain_mgr); + tc "Test gc cancel cleanup" (test_cancel_cleanup ~fs ~domain_mgr); ] end module Split = struct - let two_splits () = - let t = init () in + let two_splits ~fs () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in let () = S.split t.repo in let t = checkout_exn t c1 in @@ -1156,9 +1222,10 @@ module Split = struct let () = check_3 t c3 in S.Repo.close t.repo - let ro_two_splits () = - let t = init () in - let ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let ro_two_splits ~fs () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in + let ro_t = init ~sw ~fs ~readonly:true ~fresh:false ~root:t.root () in let t, c1 = commit_1 t in let () = S.split t.repo in let t = checkout_exn t c1 in @@ -1197,9 +1264,10 @@ module Split = struct let got = S.Tree.find tree [ "step-n01"; "step-b01" ] in Alcotest.(check (option string)) "find blob" (Some "b01") got - let v3_migrated_store_splits_and_gc () = - let root = create_test_env () in - let t = init ~readonly:false ~fresh:false ~root () in + let v3_migrated_store_splits_and_gc ~fs ~domain_mgr () = + let root = create_test_env ~fs () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~readonly:false ~fresh:false ~root () in let c0 = load_commit t "22e159de13b427226e5901defd17f0c14e744205" in let t, c1 = commit_1 t in let () = S.split t.repo in @@ -1212,33 +1280,34 @@ module Split = struct let () = check_1 t c1 in let () = check_2 t c2 in [%log.debug "GC at c0"]; - let () = start_gc ~unlink:true t c0 in + let () = start_gc ~fs ~domain_mgr ~unlink:true t c0 in let () = finalise_gc t in let () = check_preexisting_commit t in let () = check_1 t c1 in let () = check_2 t c2 in Alcotest.(check bool) "Chunk0 still exists" true - (Sys.file_exists (Filename.concat t.root "store.0.suffix")); + (file_exists Eio.Path.(t.root / "store.0.suffix")); [%log.debug "GC at c1"]; - let () = start_gc ~unlink:true t c1 in + let () = start_gc ~fs ~domain_mgr ~unlink:true t c1 in let () = finalise_gc t in let () = check_not_found t c0 "removed c0" in let () = check_1 t c1 in let () = check_2 t c2 in Alcotest.(check bool) "Chunk0 removed" true - (check_async_unlinked (Filename.concat t.root "store.0.suffix")); + (check_async_unlinked Eio.Path.(t.root / "store.0.suffix")); [%log.debug "GC at c2"]; - let () = start_gc ~unlink:true t c2 in + let () = start_gc ~fs ~domain_mgr ~unlink:true t c2 in let () = finalise_gc t in let () = check_not_found t c0 "removed c0" in let () = check_not_found t c1 "removed c1" in let () = check_2 t c2 in S.Repo.close t.repo - let close_and_split () = - let t = init () in + let close_and_split ~fs () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let root = t.root in let t, c1 = commit_1 t in let () = S.split t.repo in @@ -1246,7 +1315,8 @@ module Split = struct let t, c2 = commit_2 t in [%log.debug "created chunk1, chunk2"]; let () = S.Repo.close t.repo in - let t = init ~readonly:false ~fresh:false ~root () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~readonly:false ~fresh:false ~root () in let () = check_1 t c1 in let () = check_2 t c2 in let () = S.split t.repo in @@ -1254,22 +1324,24 @@ module Split = struct let t, c3 = commit_3 t in [%log.debug "created chunk3"]; let () = S.Repo.close t.repo in - let t = init ~readonly:true ~fresh:false ~root () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~readonly:true ~fresh:false ~root () in let () = check_1 t c1 in let () = check_2 t c2 in let () = check_3 t c3 in S.Repo.close t.repo - let two_gc_then_split () = - let t = init () in + let two_gc_then_split ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () 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 () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in let t = checkout_exn t c2 in let t, c3 = commit_3 t in - let () = start_gc t c3 in + let () = start_gc ~fs ~domain_mgr t c3 in let () = finalise_gc t in let () = S.split t.repo in let t = checkout_exn t c3 in @@ -1280,12 +1352,13 @@ module Split = struct let () = check_4 t c4 in S.Repo.close t.repo - let multi_split_and_gc () = + let multi_split_and_gc ~fs ~domain_mgr () = (* This test primarily checks that dead byte calculation happens correctly by testing GCs on chunks past the first one. When the calculation is incorrect, exceptions are thrown when attempting to lookup keys in the store. *) - let t = init () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in let () = S.split t.repo in @@ -1293,14 +1366,14 @@ module Split = struct let t, c2 = commit_2 t in let () = S.split t.repo in - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let () = finalise_gc t in let t = checkout_exn t c2 in let t, c3 = commit_3 t in let () = S.split t.repo in - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in let t = checkout_exn t c3 in @@ -1312,34 +1385,37 @@ module Split = struct let () = check_4 t c4 in S.Repo.close t.repo - let split_and_gc () = - let t = init () in + let split_and_gc ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in let () = S.split t.repo in let t = checkout_exn t c1 in let t, c2 = commit_2 t in - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = finalise_gc t in let () = check_2 t c2 in let () = check_not_found t c1 "removed c1" in S.Repo.close t.repo - let another_split_and_gc () = - let t = init () in + let another_split_and_gc ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in let () = S.split t.repo in let t = checkout_exn t c1 in let t, c2 = commit_2 t in - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let () = finalise_gc t in let () = check_1 t c1 in let () = check_2 t c2 in S.Repo.close t.repo - let split_during_gc () = - let t = init () in + let split_during_gc ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in - let () = start_gc t c1 in + let () = start_gc ~fs ~domain_mgr t c1 in let () = S.split t.repo in let t = checkout_exn t c1 in let t, c2 = commit_2 t in @@ -1348,17 +1424,18 @@ module Split = struct let () = check_2 t c2 in S.Repo.close t.repo - let commits_and_splits_during_gc () = + let commits_and_splits_during_gc ~fs ~domain_mgr () = (* This test primarily ensures that chunk num is calculated correctly by intentionally creating chunks during a GC. *) - let t = init () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in let () = S.split t.repo in let t = checkout_exn t c1 in let t, c2 = commit_2 t in - let () = start_gc t c2 in + let () = start_gc ~fs ~domain_mgr t c2 in let () = S.split t.repo in let t = checkout_exn t c2 in @@ -1375,9 +1452,10 @@ module Split = struct let () = check_4 t c4 in S.Repo.close t.repo - let split_always_indexed_from_v2_store () = - let root = create_from_v2_always_test_env () in - let t = init ~readonly:false ~fresh:false ~root () in + let split_always_indexed_from_v2_store ~fs () = + let root = create_from_v2_always_test_env ~fs () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~readonly:false ~fresh:false ~root () in let _c0 = load_commit t "22e159de13b427226e5901defd17f0c14e744205" in let t, _c1 = commit_1 t in let f () = S.split t.repo in @@ -1388,33 +1466,36 @@ module Split = struct (S.is_split_allowed t.repo)); S.Repo.close t.repo - let tests = + let tests ~fs ~domain_mgr = [ - tc "Test two splits" two_splits; - tc "Test two splits for ro" ro_two_splits; - tc "Test splits and GC on V3 store" v3_migrated_store_splits_and_gc; - tc "Test split and close" close_and_split; - tc "Test two gc followed by split" two_gc_then_split; - tc "Test split and GC" split_and_gc; - tc "Test multi split and GC" multi_split_and_gc; - tc "Test another split and GC" another_split_and_gc; - tc "Test split during GC" split_during_gc; - tc "Test commits and splits during GC" commits_and_splits_during_gc; + tc "Test two splits" (two_splits ~fs); + tc "Test two splits for ro" (ro_two_splits ~fs); + tc "Test splits and GC on V3 store" + (v3_migrated_store_splits_and_gc ~fs ~domain_mgr); + tc "Test split and close" (close_and_split ~fs); + tc "Test two gc followed by split" (two_gc_then_split ~fs ~domain_mgr); + tc "Test split and GC" (split_and_gc ~fs ~domain_mgr); + tc "Test multi split and GC" (multi_split_and_gc ~fs ~domain_mgr); + tc "Test another split and GC" (another_split_and_gc ~fs ~domain_mgr); + tc "Test split during GC" (split_during_gc ~fs ~domain_mgr); + tc "Test commits and splits during GC" + (commits_and_splits_during_gc ~fs ~domain_mgr); tc "Test split for always indexed from v2 store" - split_always_indexed_from_v2_store; + (split_always_indexed_from_v2_store ~fs); ] end module Snapshot = struct - let export t commit = + let export ~fs ~domain_mgr t commit = let commit_key = S.Commit.key commit in - S.create_one_commit_store t.repo commit_key + S.create_one_commit_store ~fs ~domain_mgr t.repo commit_key - let snapshot_rw () = - let t = init () in + let snapshot_rw ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in - let root_snap = Filename.concat t.root "snap" in - let () = export t c1 root_snap in + let root_snap = Eio.Path.(t.root / "snap") in + let () = export ~fs ~domain_mgr t c1 root_snap in [%log.debug "store works after export"]; let t = checkout_exn t c1 in let t, c2 = commit_2 t in @@ -1422,7 +1503,8 @@ module Snapshot = struct let () = check_2 t c2 in let () = S.Repo.close t.repo in [%log.debug "open store from import in rw"]; - let t = init ~readonly:false ~fresh:false ~root:root_snap () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~readonly:false ~fresh:false ~root:root_snap () in let t = checkout_exn t c1 in let () = check_1 t c1 in let () = check_not_found t c2 "c2 not commited yet" in @@ -1430,32 +1512,37 @@ module Snapshot = struct let () = check_2 t c2 in S.Repo.close t.repo - let snapshot_import_in_ro () = - let t = init () in + let snapshot_import_in_ro ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in - let root_snap = Filename.concat t.root "snap" in - let () = export t c1 root_snap in + let root_snap = Eio.Path.(t.root / "snap") in + let () = export ~fs ~domain_mgr t c1 root_snap in let () = S.Repo.close t.repo in [%log.debug "open store from import in ro"]; - let t = init ~readonly:true ~fresh:false ~root:root_snap () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~readonly:true ~fresh:false ~root:root_snap () in let t = checkout_exn t c1 in let () = check_1 t c1 in S.Repo.close t.repo - let snapshot_export_in_ro () = - let t = init () in + let snapshot_export_in_ro ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs () in let t, c1 = commit_1 t in let () = S.Repo.close t.repo in [%log.debug "open store in readonly to export"]; - let t = init ~readonly:false ~fresh:false ~root:t.root () in - let root_snap = Filename.concat t.root "snap" in - let () = export t c1 root_snap in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~readonly:false ~fresh:false ~root:t.root () in + let root_snap = Eio.Path.(t.root / "snap") in + let () = export ~fs ~domain_mgr t c1 root_snap in [%log.debug "store works after export in readonly"]; let t = checkout_exn t c1 in let () = check_1 t c1 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 + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~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 @@ -1464,30 +1551,32 @@ module Snapshot = struct (* 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 snapshot_gced_commit ~fs ~domain_mgr () = + let lower_root = create_lower_root ~fs ~mkdir:false () in + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~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 () = start_gc ~fs ~domain_mgr 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 root_snap = Eio.Path.(t.root / "snap") in + let () = export ~fs ~domain_mgr 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 + Eio.Switch.run @@ fun sw -> + let t = init ~sw ~fs ~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 = + let tests ~fs ~domain_mgr = [ - 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; + tc "Import/export in rw" (snapshot_rw ~fs ~domain_mgr); + tc "Import in ro" (snapshot_import_in_ro ~fs ~domain_mgr); + tc "Export in ro" (snapshot_export_in_ro ~fs ~domain_mgr); + tc "Snapshot gced commit" (snapshot_gced_commit ~fs ~domain_mgr); ] end diff --git a/test/irmin-pack/test_gc.mli b/test/irmin-pack/test_gc.mli index 431ad1d82a..bba067343b 100644 --- a/test/irmin-pack/test_gc.mli +++ b/test/irmin-pack/test_gc.mli @@ -15,23 +15,38 @@ *) module Gc : sig - val tests : unit Alcotest.test_case list + val tests : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + unit Alcotest.test_case list end module Gc_archival : sig - val tests : unit Alcotest.test_case list + val tests : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + unit Alcotest.test_case list end module Concurrent_gc : sig - val tests : unit Alcotest.test_case list + val tests : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + unit Alcotest.test_case list end module Split : sig - val tests : unit Alcotest.test_case list + val tests : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + unit Alcotest.test_case list end module Snapshot : sig - val tests : unit Alcotest.test_case list + val tests : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + unit Alcotest.test_case list end module Store : sig @@ -39,10 +54,23 @@ module Store : sig type t - val config : string -> Irmin.config - val init_with_config : Irmin.config -> t + val config : + sw:Eio.Switch.t -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + Eio.Fs.dir_ty Eio.Path.t -> + Irmin.config + + val init_with_config : fs:Eio.Fs.dir_ty Eio.Path.t -> Irmin.config -> t val close : t -> unit - val start_gc : ?unlink:bool -> t -> S.commit -> unit + + val start_gc : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + ?unlink:bool -> + t -> + S.commit -> + unit + val finalise_gc : t -> unit val commit_1 : t -> t * S.commit val commit_2 : t -> t * S.commit diff --git a/test/irmin-pack/test_hashes.ml b/test/irmin-pack/test_hashes.ml index 9935f00452..7ab65798df 100644 --- a/test/irmin-pack/test_hashes.ml +++ b/test/irmin-pack/test_hashes.ml @@ -17,10 +17,11 @@ open! Import open Common -let root = Filename.concat "_build" "test-irmin-tezos" +let root fs = Eio.Path.(fs / "_build" / "test-irmin-tezos") -let conf = - Irmin_pack.config ~readonly:false ~fresh:true ~index_log_size:1000 root +let conf ~sw ~fs = + Irmin_pack.config ~sw ~fs ~readonly:false ~fresh:true ~index_log_size:1000 + (root fs) let zero = Bytes.make 10 '0' @@ -70,8 +71,8 @@ struct in tree - let persist_tree tree = - let repo = Repo.v conf in + let persist_tree ~sw ~fs tree = + let repo = Repo.v (conf ~sw ~fs) in let init_commit = Commit.v ~parents:[] ~info:Info.empty repo (Tree.singleton [ "singleton-step" ] (Bytes.of_string "singleton-val")) @@ -144,9 +145,10 @@ module Test_tezos_conf = struct in ("len of values", nb_steps) :: checks - let inode_values_hash () = + let inode_values_hash ~fs () = + Eio.Switch.run @@ fun sw -> let tree = Store.build_tree some_steps in - let repo, tree, _ = Store.persist_tree tree in + let repo, tree, _ = Store.persist_tree ~sw ~fs tree in let root_node = match Store.Tree.destruct tree with | `Contents _ -> Alcotest.fail "Expected root to be node" @@ -164,9 +166,10 @@ module Test_tezos_conf = struct "CoVeCU4o3dqmfdwqt2vh8LDz9X6qGbTUyLhgVvFReyzAvTf92AKx" h; Store.Repo.close repo - let commit_hash () = + let commit_hash ~fs () = + Eio.Switch.run @@ fun sw -> let tree = Store.build_tree some_steps in - let repo, _, commit = Store.persist_tree tree in + let repo, _, commit = Store.persist_tree ~sw ~fs tree in let commit_val = Store.to_backend_commit commit in let h = Commit.Hash.hash commit_val in let encode_bin_hash = Irmin.Type.(unstage (encode_bin Commit.Hash.t)) in @@ -239,9 +242,10 @@ module Test_small_conf = struct "821707c86f7030b1102397feb88d454076ec64744dfd9811b8254bd61d396cfe" ); ] - let inode_tree_hash () = + let inode_tree_hash ~fs () = + Eio.Switch.run @@ fun sw -> let tree = Store.build_tree many_steps in - let repo, tree, _ = Store.persist_tree tree in + let repo, tree, _ = Store.persist_tree ~sw ~fs tree in let root_node = match Store.Tree.destruct tree with | `Contents _ -> Alcotest.fail "Expected root to be node" @@ -280,9 +284,10 @@ module Test_V1 = struct let many_steps = [ "00"; "01"; "02"; "03"; "04"; "05" ] - let commit_hash () = + let commit_hash ~fs () = + Eio.Switch.run @@ fun sw -> let tree = Store.build_tree many_steps in - let repo, _, commit = Store.persist_tree tree in + let repo, _, commit = Store.persist_tree ~sw ~fs tree in let commit_val = Store.to_backend_commit commit in let checks = [ @@ -305,12 +310,12 @@ module Test_V1 = struct Store.Repo.close repo end -let tests = +let tests ~fs = let tc name f = Alcotest.test_case name `Quick f in [ tc "contents hash" Test_tezos_conf.contents_hash; - tc "inode_values hash" Test_tezos_conf.inode_values_hash; - tc "inode_tree hash" Test_small_conf.inode_tree_hash; - tc "commit hash" Test_tezos_conf.commit_hash; - tc "V1 commit hash" Test_V1.commit_hash; + tc "inode_values hash" (Test_tezos_conf.inode_values_hash ~fs); + tc "inode_tree hash" (Test_small_conf.inode_tree_hash ~fs); + tc "commit hash" (Test_tezos_conf.commit_hash ~fs); + tc "V1 commit hash" (Test_V1.commit_hash ~fs); ] diff --git a/test/irmin-pack/test_hashes.mli b/test/irmin-pack/test_hashes.mli index 3e8b1f82b6..0e2361c412 100644 --- a/test/irmin-pack/test_hashes.mli +++ b/test/irmin-pack/test_hashes.mli @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest.test_case list +val tests : fs:Eio.Fs.dir_ty Eio.Path.t -> unit Alcotest.test_case list val check_iter : string -> diff --git a/test/irmin-pack/test_indexing_strategy.ml b/test/irmin-pack/test_indexing_strategy.ml index 708aa5e910..bb642861fc 100644 --- a/test/irmin-pack/test_indexing_strategy.ml +++ b/test/irmin-pack/test_indexing_strategy.ml @@ -17,6 +17,8 @@ open! Import open Common +let root fs = Eio.Path.(fs / "_build" / "test_indexing_strategy") + let src = Logs.Src.create "tests.indexing_strategy" ~doc:"Test indexing strategy" @@ -27,11 +29,12 @@ module Store = struct include Maker.Make (Schema) end -let config ~indexing_strategy ?(readonly = false) ?(fresh = false) () = - let root = Filename.concat "_build" "test_indexing_strategy" in +let config ~indexing_strategy ?(readonly = false) ?(fresh = false) root = Irmin_pack.config ~readonly ~indexing_strategy ~fresh root -let test_unique_when_switched () = +let test_unique_when_switched ~fs () = + let root = root fs in + rm_dir root; let value = "Welt" in let get_contents_key store path = let k = Store.key store path in @@ -55,10 +58,11 @@ let test_unique_when_switched () = in (* 1. open store with always indexing, verify same offsets *) + Eio.Switch.run @@ fun sw -> let repo = Store.Repo.v - @@ config ~indexing_strategy:Irmin_pack.Indexing_strategy.always ~fresh:true - () + @@ config ~sw ~fs ~indexing_strategy:Irmin_pack.Indexing_strategy.always + ~fresh:true root in let store = Store.main repo in let first_key = @@ -85,8 +89,8 @@ let test_unique_when_switched () = (* 2. re-open store with minimal indexing, verify new offset *) let repo = Store.Repo.v - @@ config ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal - ~fresh:false () + @@ config ~sw ~fs ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal + ~fresh:false root in let store = Store.main repo in let third_key = @@ -107,8 +111,8 @@ let test_unique_when_switched () = Store.Repo.close repo -let tests = +let tests ~fs = [ Alcotest.test_case "test unique when switching strategies" `Quick - test_unique_when_switched; + (test_unique_when_switched ~fs); ] diff --git a/test/irmin-pack/test_indexing_strategy.mli b/test/irmin-pack/test_indexing_strategy.mli index 601ae9bf53..43c7f318ab 100644 --- a/test/irmin-pack/test_indexing_strategy.mli +++ b/test/irmin-pack/test_indexing_strategy.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest.test_case list +val tests : fs:Eio.Fs.dir_ty Eio.Path.t -> unit Alcotest.test_case list diff --git a/test/irmin-pack/test_inode.ml b/test/irmin-pack/test_inode.ml index e7791b0d73..a98a250429 100644 --- a/test/irmin-pack/test_inode.ml +++ b/test/irmin-pack/test_inode.ml @@ -17,7 +17,7 @@ open! Import open Common -let root = Filename.concat "_build" "test-inode" +let root ~fs = Eio.Path.(fs / "_build" / "test-inode") let src = Logs.Src.create "tests.instances" ~doc:"Tests" module Log = (val Logs.src_log src : Logs.LOG) @@ -111,10 +111,11 @@ struct Irmin_pack.Conf.init ~fresh ~readonly ~indexing_strategy ~lru_size:0 name (* TODO : remove duplication with irmin_pack/ext.ml *) - let get_fm config = + let get_fm ~sw ~fs config = let readonly = Irmin_pack.Conf.readonly config in - if readonly then File_manager.open_ro config |> Errs.raise_if_error + if readonly then + File_manager.open_ro ~sw ~fs config |> Errs.raise_if_error else let fresh = Irmin_pack.Conf.fresh config in let root = Irmin_pack.Conf.root config in @@ -124,21 +125,25 @@ struct | false -> Unix.mkdir (Filename.dirname root) 0o755 | true -> () in - match (Io.classify_path root, fresh) with + match (Io.classify_path Eio.Path.(fs / root), fresh) with | `No_such_file_or_directory, _ -> - File_manager.create_rw ~overwrite:false config + File_manager.create_rw ~sw ~fs ~overwrite:false config |> Errs.raise_if_error | `Directory, true -> - File_manager.create_rw ~overwrite:true config |> Errs.raise_if_error + File_manager.create_rw ~sw ~fs ~overwrite:true config + |> Errs.raise_if_error | `Directory, false -> - File_manager.open_rw config |> Errs.raise_if_error + File_manager.open_rw ~sw ~fs config |> Errs.raise_if_error | (`File | `Other), _ -> Errs.raise_error (`Not_a_directory root) - let get_store ~indexing_strategy () = + let get_store ~sw ~fs ~indexing_strategy () = [%log.app "Constructing a fresh context for use by the test"]; + let root = root ~fs in rm_dir root; - let config = config ~indexing_strategy ~readonly:false ~fresh:true root in - let fm = get_fm config in + let config = + config ~sw ~fs ~indexing_strategy ~readonly:false ~fresh:true root + in + let fm = get_fm ~sw ~fs config in let dict = File_manager.dict fm in let dispatcher = Dispatcher.v fm |> Errs.raise_if_error in let lru = Irmin_pack_unix.Lru.create config in @@ -342,9 +347,11 @@ let check_hardcoded_hash msg h v = | Ok hash -> check_hash msg hash (Inter.Val.hash_exn v) (** Test add values from an empty node. *) -let test_add_values ~indexing_strategy = +let test_add_values ~fs ~indexing_strategy = + let root = root ~fs in rm_dir root; - let t = Context.get_store ~indexing_strategy () in + Eio.Switch.run @@ fun sw -> + let t = Context.get_store ~sw ~fs ~indexing_strategy () in let { Context.foo; bar; _ } = t in check_node "hash empty node" (Inode.Val.empty ()) t; let v1 = Inode.Val.add (Inode.Val.empty ()) "x" (normal foo) in @@ -355,9 +362,9 @@ let test_add_values ~indexing_strategy = check_values "add x+y vs v x+y" v2 v3; Context.close t -let test_add_values () = - let () = test_add_values ~indexing_strategy:`always in - test_add_values ~indexing_strategy:`minimal +let test_add_values ~fs () = + let () = test_add_values ~fs ~indexing_strategy:`always in + test_add_values ~fs ~indexing_strategy:`minimal let integrity_check ?(stable = true) v = Alcotest.(check bool) "check stable" (Inter.Val.stable v) stable; @@ -367,9 +374,11 @@ let integrity_check ?(stable = true) v = v (** Test add to inodes. *) -let test_add_inodes ~indexing_strategy = +let test_add_inodes ~fs ~indexing_strategy = + let root = root ~fs in rm_dir root; - let t = Context.get_store ~indexing_strategy () in + Eio.Switch.run @@ fun sw -> + let t = Context.get_store ~sw ~fs ~indexing_strategy () in let { Context.foo; bar; _ } = t in let v1 = Inode.Val.of_list [ ("x", normal foo); ("y", normal bar) ] in let v2 = Inode.Val.add v1 "z" (normal foo) in @@ -396,14 +405,16 @@ let test_add_inodes ~indexing_strategy = integrity_check v4 ~stable:false; Context.close t -let test_add_inodes () = - let () = test_add_inodes ~indexing_strategy:`always in - test_add_inodes ~indexing_strategy:`minimal +let test_add_inodes ~fs () = + let () = test_add_inodes ~fs ~indexing_strategy:`always in + test_add_inodes ~fs ~indexing_strategy:`minimal (** Test remove values on an empty node. *) -let test_remove_values ~indexing_strategy = +let test_remove_values ~fs ~indexing_strategy = + let root = root ~fs in rm_dir root; - let t = Context.get_store ~indexing_strategy () in + Eio.Switch.run @@ fun sw -> + let t = Context.get_store ~sw ~fs ~indexing_strategy () in let { Context.foo; bar; _ } = t in let v1 = Inode.Val.of_list [ ("x", normal foo); ("y", normal bar) ] in let v2 = Inode.Val.remove v1 "y" in @@ -418,14 +429,16 @@ let test_remove_values ~indexing_strategy = Alcotest.(check bool) "v5 is empty" (Inode.Val.is_empty v5) true; Context.close t -let test_remove_values () = - let () = test_remove_values ~indexing_strategy:`always in - test_remove_values ~indexing_strategy:`minimal +let test_remove_values ~fs () = + let () = test_remove_values ~fs ~indexing_strategy:`always in + test_remove_values ~fs ~indexing_strategy:`minimal (** Test remove and add values to go from stable to unstable inodes. *) -let test_remove_inodes ~indexing_strategy = +let test_remove_inodes ~fs ~indexing_strategy = + let root = root ~fs in rm_dir root; - let t = Context.get_store ~indexing_strategy () in + Eio.Switch.run @@ fun sw -> + let t = Context.get_store ~sw ~fs ~indexing_strategy () in let { Context.foo; bar; _ } = t in let v1 = Inode.Val.of_list @@ -451,9 +464,9 @@ let test_remove_inodes ~indexing_strategy = integrity_check v5; Context.close t -let test_remove_inodes () = - let () = test_remove_inodes ~indexing_strategy:`always in - test_remove_inodes ~indexing_strategy:`minimal +let test_remove_inodes ~fs () = + let () = test_remove_inodes ~fs ~indexing_strategy:`always in + test_remove_inodes ~fs ~indexing_strategy:`minimal (** For each of the 256 possible inode trees with [depth <= 3] and [width = Conf.entries = 2] built by [Inode.Val.v], assert that @@ -503,8 +516,9 @@ let test_representation_uniqueness_maxdepth_3 () = (fun (ss, t) -> List.iter (fun s -> f ss t s) (P.steps p)) (P.trees p) -let test_truncated_inodes ~indexing_strategy = - let t = Context.get_store ~indexing_strategy () in +let test_truncated_inodes ~fs ~indexing_strategy = + Eio.Switch.run @@ fun sw -> + let t = Context.get_store ~sw ~fs ~indexing_strategy () in let { Context.foo; bar; _ } = t in let to_truncated inode = let encode, decode = @@ -566,12 +580,13 @@ let test_truncated_inodes ~indexing_strategy = (iter_steps_with_failure @@ fun step -> Inode.Val.remove v3 step); Context.close t -let test_truncated_inodes () = - let () = test_truncated_inodes ~indexing_strategy:`always in - test_truncated_inodes ~indexing_strategy:`minimal +let test_truncated_inodes ~fs () = + let () = test_truncated_inodes ~fs ~indexing_strategy:`always in + test_truncated_inodes ~fs ~indexing_strategy:`minimal -let test_intermediate_inode_as_root ~indexing_strategy = - let t = Context.get_store ~indexing_strategy () in +let test_intermediate_inode_as_root ~fs ~indexing_strategy = + Eio.Switch.run @@ fun sw -> + let t = Context.get_store ~sw ~fs ~indexing_strategy () in let { Context.foo; bar; _ } = t in let gen_step = Inode_permutations_generator.gen_step (module Inter) in let s000, s001, s010 = @@ -623,8 +638,9 @@ let test_intermediate_inode_as_root ~indexing_strategy = with_exn (fun () -> Inode.Val.add v s000 (normal foo)); Inode.batch t.store (fun store -> with_exn (fun () -> Inode.add store v)) -let test_invalid_depth_intermediate_inode ~indexing_strategy = - let t = Context_mock.get_store ~indexing_strategy () in +let test_invalid_depth_intermediate_inode ~fs ~indexing_strategy = + Eio.Switch.run @@ fun sw -> + let t = Context_mock.get_store ~sw ~fs ~indexing_strategy () in let { Context_mock.foo; bar; _ } = t in let gen_step = Inode_permutations_generator.gen_step (module Inter_mock) in let s000, s001, s010 = @@ -660,14 +676,19 @@ let test_invalid_depth_intermediate_inode ~indexing_strategy = in Context_mock.close t -let test_intermediate_inode_as_root () = - let () = test_invalid_depth_intermediate_inode ~indexing_strategy:`always in - let () = test_invalid_depth_intermediate_inode ~indexing_strategy:`minimal in - let () = test_intermediate_inode_as_root ~indexing_strategy:`always in - test_intermediate_inode_as_root ~indexing_strategy:`minimal +let test_intermediate_inode_as_root ~fs () = + let () = + test_invalid_depth_intermediate_inode ~fs ~indexing_strategy:`always + in + let () = + test_invalid_depth_intermediate_inode ~fs ~indexing_strategy:`minimal + in + let () = test_intermediate_inode_as_root ~fs ~indexing_strategy:`always in + test_intermediate_inode_as_root ~fs ~indexing_strategy:`minimal -let test_concrete_inodes ~indexing_strategy = - let t = Context.get_store ~indexing_strategy () in +let test_concrete_inodes ~fs ~indexing_strategy = + Eio.Switch.run @@ fun sw -> + let t = Context.get_store ~sw ~fs ~indexing_strategy () in let { Context.foo; bar; _ } = t in let pp_concrete = Irmin.Type.pp_json ~minify:false Inter.Val.Concrete.t in let result_t = Irmin.Type.result Inode.Val.t Inter.Val.Concrete.error_t in @@ -701,9 +722,10 @@ let test_concrete_inodes ~indexing_strategy = check v; Context.close t -let test_invalid_depth_concrete_inodes ~indexing_strategy = +let test_invalid_depth_concrete_inodes ~fs ~indexing_strategy = let module C = Inter.Val.Concrete in - let t = Context.get_store ~indexing_strategy () in + Eio.Switch.run @@ fun sw -> + let t = Context.get_store ~sw ~fs ~indexing_strategy () in (* idea is to try and directly construct a Concrete that has a bad depth structure ie *) (* "Tree": { *) @@ -738,11 +760,11 @@ let test_invalid_depth_concrete_inodes ~indexing_strategy = Context.close t -let test_concrete_inodes () = - let () = test_invalid_depth_concrete_inodes ~indexing_strategy:`always in - let () = test_invalid_depth_concrete_inodes ~indexing_strategy:`minimal in - let () = test_concrete_inodes ~indexing_strategy:`always in - test_concrete_inodes ~indexing_strategy:`minimal +let test_concrete_inodes ~fs () = + let () = test_invalid_depth_concrete_inodes ~fs ~indexing_strategy:`always in + let () = test_invalid_depth_concrete_inodes ~fs ~indexing_strategy:`minimal in + let () = test_concrete_inodes ~fs ~indexing_strategy:`always in + test_concrete_inodes ~fs ~indexing_strategy:`minimal module Inode_tezos = struct module S = @@ -761,9 +783,11 @@ module Inode_tezos = struct let hex_encode s = Hex.of_string s |> Hex.show - let test_encode_bin_values ~indexing_strategy = + let test_encode_bin_values ~fs ~indexing_strategy = + let root = root ~fs in rm_dir root; - let t = S.Context.get_store ~indexing_strategy () in + Eio.Switch.run @@ fun sw -> + let t = S.Context.get_store ~sw ~fs ~indexing_strategy () in let { S.Context.foo; _ } = t in let v = S.Inode.Val.of_list [ ("x", normal foo); ("z", normal foo) ] in let h = S.Inter.Val.hash_exn v in @@ -795,13 +819,15 @@ module Inode_tezos = struct check_iter "encode_bin" (encode_bin h) v checks; S.Context.close t - let test_encode_bin_values () = - let () = test_encode_bin_values ~indexing_strategy:`always in - test_encode_bin_values ~indexing_strategy:`minimal + let test_encode_bin_values ~fs () = + let () = test_encode_bin_values ~fs ~indexing_strategy:`always in + test_encode_bin_values ~fs ~indexing_strategy:`minimal - let test_encode_bin_tree ~indexing_strategy = + let test_encode_bin_tree ~fs ~indexing_strategy = + let root = root ~fs in rm_dir root; - let t = S.Context.get_store ~indexing_strategy () in + Eio.Switch.run @@ fun sw -> + let t = S.Context.get_store ~sw ~fs ~indexing_strategy () in let { S.Context.foo; bar; _ } = t in let v = S.Inode.Val.of_list @@ -840,9 +866,9 @@ module Inode_tezos = struct check_iter "encode_bin" (encode_bin h) v checks; S.Context.close t - let test_encode_bin_tree () = - let () = test_encode_bin_tree ~indexing_strategy:`always in - test_encode_bin_tree ~indexing_strategy:`minimal + let test_encode_bin_tree ~fs () = + let () = test_encode_bin_tree ~fs ~indexing_strategy:`always in + test_encode_bin_tree ~fs ~indexing_strategy:`minimal end module Child_ordering = struct @@ -988,23 +1014,25 @@ module Child_ordering = struct () end -let tests = +let tests ~fs = let tc_sync name f = Alcotest.test_case name `Quick f in let tc name f = tc_sync name f in (* Test disabled because it relies on being able to serialise concrete inodes, which is not possible following the introduction of structured keys. *) - let _ = tc "test truncated inodes" test_truncated_inodes in - let _ = tc "test encode bin of trees" Inode_tezos.test_encode_bin_tree in + let _ = tc "test truncated inodes" (test_truncated_inodes ~fs) in + let _ = + tc "test encode bin of trees" (Inode_tezos.test_encode_bin_tree ~fs) + in [ - tc "add values" test_add_values; - tc "add values to inodes" test_add_inodes; - tc "remove values" test_remove_values; - tc "remove inodes" test_remove_inodes; - tc "test concrete inodes" test_concrete_inodes; + tc "add values" (test_add_values ~fs); + tc "add values to inodes" (test_add_inodes ~fs); + tc "remove values" (test_remove_values ~fs); + tc "remove inodes" (test_remove_inodes ~fs); + tc "test concrete inodes" (test_concrete_inodes ~fs); tc "test representation uniqueness" test_representation_uniqueness_maxdepth_3; - tc "test encode bin of values" Inode_tezos.test_encode_bin_values; - tc "test intermediate inode as root" test_intermediate_inode_as_root; + tc "test encode bin of values" (Inode_tezos.test_encode_bin_values ~fs); + tc "test intermediate inode as root" (test_intermediate_inode_as_root ~fs); tc_sync "Child_ordering.seeded_hash" Child_ordering.test_seeded_hash; tc_sync "Child_ordering.hash_bits" Child_ordering.test_hash_bits; tc_sync "Child_ordering.custom" Child_ordering.test_custom; diff --git a/test/irmin-pack/test_inode.mli b/test/irmin-pack/test_inode.mli index 2b40d2f891..9893a1a314 100644 --- a/test/irmin-pack/test_inode.mli +++ b/test/irmin-pack/test_inode.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest.test_case list +val tests : fs:Eio.Fs.dir_ty Eio.Path.t -> unit Alcotest.test_case list diff --git a/test/irmin-pack/test_lower.ml b/test/irmin-pack/test_lower.ml index 58d5ed2f51..9b84b3530f 100644 --- a/test/irmin-pack/test_lower.ml +++ b/test/irmin-pack/test_lower.ml @@ -30,27 +30,30 @@ module Direct_tc = struct module Lower = Irmin_pack_unix.Lower.Make (Io) (Errs) module Sparse = Irmin_pack_unix.Sparse_file.Make (Io) - let create_control volume_path payload = + let create_control ~sw volume_path payload = let path = Irmin_pack.Layout.V5.Volume.control ~root:volume_path in - Control.create_rw ~path ~tmp_path:None ~overwrite:true payload + Control.create_rw ~sw ~path ~tmp_path:None ~overwrite:true payload - let test_empty () = - let lower_root = create_lower_root () in - let$ lower = Lower.v ~readonly:false ~volume_num:0 lower_root in + let test_empty ~fs () = + Eio.Switch.run @@ fun sw -> + let lower_root = create_lower_root ~fs () in + let$ lower = Lower.v ~sw ~readonly:false ~volume_num:0 lower_root in Alcotest.(check int) "0 volumes" 0 (Lower.volume_num lower); let _ = Lower.close lower in () - let test_volume_num () = - let lower_root = create_lower_root () in - let result = Lower.v ~readonly:false ~volume_num:1 lower_root in + let test_volume_num ~fs () = + Eio.Switch.run @@ fun sw -> + let lower_root = create_lower_root ~fs () in + let result = Lower.v ~sw ~readonly:false ~volume_num:1 lower_root in match result with | Error (`Volume_missing _) -> () | _ -> Alcotest.fail "volume_num too high should return an error" - let test_add_volume () = - let lower_root = create_lower_root () in - let$ lower = Lower.v ~readonly:false ~volume_num:0 lower_root in + let test_add_volume ~fs () = + Eio.Switch.run @@ fun sw -> + let lower_root = create_lower_root ~fs () in + let$ lower = Lower.v ~sw ~readonly:false ~volume_num:0 lower_root in let$ _ = Lower.add_volume lower in Alcotest.(check int) "1 volume" 1 (Lower.volume_num lower); let$ _ = Lower.reload ~volume_num:1 lower in @@ -58,9 +61,10 @@ module Direct_tc = struct let _ = Lower.close lower in () - let test_add_volume_ro () = - let lower_root = create_lower_root () in - let$ lower = Lower.v ~readonly:true ~volume_num:0 lower_root in + let test_add_volume_ro ~fs () = + Eio.Switch.run @@ fun sw -> + let lower_root = create_lower_root ~fs () in + let$ lower = Lower.v ~sw ~readonly:true ~volume_num:0 lower_root in let result = Lower.add_volume lower in let () = match result with @@ -70,9 +74,10 @@ module Direct_tc = struct let _ = Lower.close lower in () - let test_add_multiple_empty () = - let lower_root = create_lower_root () in - let$ lower = Lower.v ~readonly:false ~volume_num:0 lower_root in + let test_add_multiple_empty ~fs () = + Eio.Switch.run @@ fun sw -> + let lower_root = create_lower_root ~fs () in + let$ lower = Lower.v ~sw ~readonly:false ~volume_num:0 lower_root in let$ _ = Lower.add_volume lower in let result = Lower.add_volume lower |> Result.get_error in let () = @@ -83,9 +88,10 @@ module Direct_tc = struct let _ = Lower.close lower in () - let test_find_volume () = - let lower_root = create_lower_root () in - let$ lower = Lower.v ~readonly:false ~volume_num:0 lower_root in + let test_find_volume ~fs () = + Eio.Switch.run @@ fun sw -> + let lower_root = create_lower_root ~fs () in + let$ lower = Lower.v ~sw ~readonly:false ~volume_num:0 lower_root in let$ volume = Lower.add_volume lower in let payload = Irmin_pack_unix.Control_file.Payload.Volume.Latest. @@ -96,7 +102,7 @@ module Direct_tc = struct checksum = Int63.zero; } in - let _ = create_control (Lower.Volume.path volume) payload in + let _ = create_control ~sw (Lower.Volume.path volume) payload in let volume = Lower.find_volume ~off:(Int63.of_int 21) lower in Alcotest.(check bool) "volume not found before reload" false (Option.is_some volume); @@ -106,9 +112,10 @@ module Direct_tc = struct let _ = Lower.close lower in () - let test_read_exn () = - let lower_root = create_lower_root () in - let$ lower = Lower.v ~readonly:false ~volume_num:0 lower_root in + let test_read_exn ~fs () = + Eio.Switch.run @@ fun sw -> + let lower_root = create_lower_root ~fs () in + let$ lower = Lower.v ~sw ~readonly:false ~volume_num:0 lower_root in let$ volume = Lower.add_volume lower in (* Manually create mapping, data, and control file for volume. @@ -119,7 +126,7 @@ module Direct_tc = struct let test_str = "hello" in let len = String.length test_str in let$ sparse = - Sparse.Ao.open_ao ~mapping_size:Int63.zero ~mapping:mapping_path + Sparse.Ao.open_ao ~sw ~mapping_size:Int63.zero ~mapping:mapping_path ~data:data_path in let seq = List.to_seq [ test_str ] in @@ -137,7 +144,7 @@ module Direct_tc = struct checksum = Int63.zero; } in - let _ = create_control (Lower.Volume.path volume) payload in + let _ = create_control ~sw (Lower.Volume.path volume) payload in let$ _ = Lower.reload ~volume_num:1 lower in let buf = Bytes.create len in let _ = Lower.read_exn ~off:Int63.zero ~len lower buf in @@ -156,16 +163,16 @@ module Store_tc = struct let test_dir = "_build" - let fresh_roots = + let fresh_roots ~fs = let c = ref 0 in fun ?(make_root = true) () -> incr c; let name = - Filename.concat test_dir ("test_lower_store_" ^ string_of_int !c) + Eio.Path.(fs / test_dir / ("test_lower_store_" ^ string_of_int !c)) in Common.rm_dir name; let$ _ = if make_root then Io.mkdir name else Ok () in - let lower = Filename.concat name "lower" in + let lower = Eio.Path.(name / "lower") in Common.rm_dir lower; (name, lower) @@ -174,10 +181,11 @@ module Store_tc = struct config ~readonly ~indexing_strategy:Indexing_strategy.minimal ~fresh ~lower_root root) - let init ?(readonly = false) ?(fresh = true) ?(include_lower = true) () = - let root, lower_root = fresh_roots () in + let init ~sw ~fs ?(readonly = false) ?(fresh = true) ?(include_lower = true) + () = + let root, lower_root = fresh_roots ~fs () in let lower_root = if include_lower then Some lower_root else None in - config ~readonly ~fresh ?lower_root root |> Store.Repo.v + Store.Repo.v (config ~sw ~fs ~readonly ~fresh ?lower_root root) let count_volumes repo = let open Store.Internal in @@ -228,31 +236,35 @@ module Store_tc = struct | Some commit -> Store.Tree.fold (Store.Commit.tree commit) ()) !commits - let test_create () = - let repo = init () in + let test_create ~fs () = + Eio.Switch.run @@ fun sw -> + let repo = init ~sw ~fs () in (* A newly created store with a lower should have an empty volume. *) let volume_num = count_volumes repo in Alcotest.(check int) "volume_num is 1" 1 volume_num; Store.Repo.close repo - let test_create_nested () = - let root, lower_root = fresh_roots ~make_root:false () in - let repo = config ~fresh:true ~lower_root root |> Store.Repo.v in + let test_create_nested ~fs () = + Eio.Switch.run @@ fun sw -> + let root, lower_root = fresh_roots ~fs ~make_root:false () in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true ~lower_root root) in let volume_num = count_volumes repo in Alcotest.(check int) "volume_num is 1" 1 volume_num; Store.Repo.close repo - let test_open_rw_lower () = - let root, lower_root = fresh_roots ~make_root:false () in - let repo = config ~fresh:true root |> Store.Repo.v in + let test_open_rw_lower ~fs () = + Eio.Switch.run @@ fun sw -> + let root, lower_root = fresh_roots ~fs ~make_root:false () in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true root) in let () = Store.Repo.close repo in - let repo = config ~fresh:false ~lower_root root |> Store.Repo.v in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:false ~lower_root root) in let volume_num = count_volumes repo in Alcotest.(check int) "volume_num is 1" 1 volume_num; Store.Repo.close repo - let test_add_volume_during_gc () = - let repo = init () in + let test_add_volume_during_gc ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let repo = init ~sw ~fs () in let main = Store.main repo in let () = Store.set_exn @@ -260,7 +272,7 @@ module Store_tc = struct main [ "a" ] "a" in let c = Store.Head.get main in - let _ = Store.Gc.start_exn repo (Store.Commit.key c) in + let _ = Store.Gc.start_exn ~fs ~domain_mgr repo (Store.Commit.key c) in let () = Alcotest.check_raises "add volume during gc" (Irmin_pack_unix.Errors.Pack_error `Add_volume_forbidden_during_gc) @@ -268,8 +280,9 @@ module Store_tc = struct in Store.Repo.close repo - let test_add_volume_wo_lower () = - let repo = init ~include_lower:false () in + let test_add_volume_wo_lower ~fs () = + Eio.Switch.run @@ fun sw -> + let repo = init ~sw ~fs ~include_lower:false () in let () = Alcotest.check_raises "add volume w/o lower" (Irmin_pack_unix.Errors.Pack_error `Add_volume_requires_lower) @@ -277,33 +290,35 @@ module Store_tc = struct in Store.Repo.close repo - let test_add_volume_reopen () = - let root, lower_root = fresh_roots () in - let repo = Store.Repo.v (config ~fresh:true ~lower_root root) in + let test_add_volume_reopen ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let root, lower_root = fresh_roots ~fs () in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true ~lower_root root) in let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in let () = Store.set_exn ~info main [ "a" ] "a" in let c1 = Store.Head.get main in - let _ = Store.Gc.start_exn repo (Store.Commit.key c1) in + let _ = Store.Gc.start_exn ~fs ~domain_mgr repo (Store.Commit.key c1) in let _ = Store.Gc.finalise_exn ~wait:true repo in let () = Store.add_volume repo in Alcotest.(check int) "two volumes" 2 (count_volumes repo); let _ = Store.Repo.close repo in - let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:false ~lower_root root) in Alcotest.(check int) "two volumes after re-open" 2 (count_volumes repo); Store.Repo.close repo - let test_migrate () = - let root, lower_root = fresh_roots () in + let test_migrate ~fs () = + Eio.Switch.run @@ fun sw -> + let root, lower_root = fresh_roots ~fs () in (* Create without a lower *) - let repo = Store.Repo.v (config ~fresh:true root) in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true root) in Alcotest.(check int) "volume_num is 0" 0 (count_volumes repo); let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in let () = Store.set_exn ~info main [ "a" ] "a" in let () = Store.Repo.close repo in (* Reopen with a lower to trigger the migration *) - let repo = Store.Repo.v (config ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~lower_root root) in Alcotest.(check int) "volume_num is 1" 1 (count_volumes repo); let main = Store.main repo in let a = Store.get main [ "a" ] in @@ -314,7 +329,7 @@ module Store_tc = struct let () = Store.set_exn ~info main [ "a" ] "b" in let () = Store.Repo.close repo in (* Reopen with the same lower and check reads *) - let repo = Store.Repo.v (config ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~lower_root root) in Alcotest.(check int) "volume_num is 1" 1 (count_volumes repo); let main = Store.main repo in let b = Store.get main [ "a" ] in @@ -329,53 +344,57 @@ module Store_tc = struct Store.Repo.close repo (* Tests that dead header is handled appropriately *) - let test_migrate_v2 () = - let ( / ) = Filename.concat in + let test_migrate_v2 ~fs () = + Eio.Switch.run @@ fun sw -> let root_archive = - "test" / "irmin-pack" / "data" / "version_2_to_3_always" + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_2_to_3_always") in - let root = "_build" / "test_lower_migrate_v2" in + let root = Eio.Path.(fs / "_build" / "test_lower_migrate_v2") in setup_test_env ~root_archive ~root_local_build:root; - let lower_root = root / "lower" in + let lower_root = Eio.Path.(root / "lower") in (* Open store and trigger migration. This should succeed. *) - let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:false ~lower_root root) in let _ = read_everything repo in Store.Repo.close repo - let test_migrate_v3 () = + let test_migrate_v3 ~fs () = + Eio.Switch.run @@ fun sw -> (* minimal indexing *) - let ( / ) = Filename.concat in - let root_archive = "test" / "irmin-pack" / "data" / "version_3_minimal" in - let root = "_build" / "test_lower_migrate_v3_minimal" in + let root_archive = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_3_minimal") + in + let root = Eio.Path.(fs / "_build" / "test_lower_migrate_v3_minimal") in setup_test_env ~root_archive ~root_local_build:root; - let lower_root = root / "lower" in + let lower_root = Eio.Path.(root / "lower") in (* Open store and trigger migration. This should succeed. *) - let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:false ~lower_root root) in let _ = read_everything repo in let _ = Store.Repo.close repo in (* always indexing *) - let ( / ) = Filename.concat in - let root_archive = "test" / "irmin-pack" / "data" / "version_3_always" in - let root = "_build" / "test_lower_migrate_v3_always" in + let root_archive = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_3_always") + in + let root = Eio.Path.(fs / "_build" / "test_lower_migrate_v3_always") in setup_test_env ~root_archive ~root_local_build:root; - let lower_root = root / "lower" in + let lower_root = Eio.Path.(root / "lower") in (* Open store and trigger migration. This should succeed. *) - let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:false ~lower_root root) in let _ = read_everything repo in Store.Repo.close repo - let test_migrate_then_gc () = - let root, lower_root = fresh_roots () in + let test_migrate_then_gc ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let root, lower_root = fresh_roots ~fs () in (* Create without a lower *) - let repo = Store.Repo.v (config ~fresh:true root) in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true root) in Alcotest.(check int) "volume_num is 0" 0 (count_volumes repo); let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in let () = Store.set_exn ~info main [ "a" ] "a" in let () = Store.Repo.close repo in (* Reopen with a lower to trigger the migration *) - let repo = Store.Repo.v (config ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~lower_root root) in Alcotest.(check int) "volume_num is 1" 1 (count_volumes repo); (* Add two commits *) let main = Store.main repo in @@ -384,15 +403,18 @@ module Store_tc = struct let b_commit = Store.Head.get main in let () = Store.set_exn ~info main [ "c" ] "c" in (* GC at [b] requires reading [a] data from the lower volume *) - let _ = Store.Gc.start_exn repo (Store.Commit.key b_commit) in + let _ = + Store.Gc.start_exn ~fs ~domain_mgr repo (Store.Commit.key b_commit) + in let _ = Store.Gc.finalise_exn ~wait:true repo in let _ = read_everything repo in Store.Repo.close repo - let test_migrate_then_gc_in_lower () = - let root, lower_root = fresh_roots () in + let test_migrate_then_gc_in_lower ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let root, lower_root = fresh_roots ~fs () in (* Create without a lower *) - let repo = Store.Repo.v (config ~fresh:true root) in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true root) in Alcotest.(check int) "volume_num is 0" 0 (count_volumes repo); let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in @@ -401,27 +423,30 @@ module Store_tc = struct let () = Store.set_exn ~info main [ "b" ] "b" in let () = Store.Repo.close repo in (* Reopen with a lower to trigger the migration *) - let repo = Store.Repo.v (config ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~lower_root root) in Alcotest.(check int) "volume_num is 1" 1 (count_volumes repo); (* [a] is now in the lower but GC should still succeed Important: we call GC on a commit that is not the latest in the lower (ie [b]) to ensure its offset is not equal to the start offset of the upper. *) - let _ = Store.Gc.start_exn repo (Store.Commit.key a_commit) in + let _ = + Store.Gc.start_exn ~fs repo ~domain_mgr (Store.Commit.key a_commit) + in let _ = Store.Gc.finalise_exn ~wait:true repo in Store.Repo.close repo - let test_volume_data_locality () = - let root, lower_root = fresh_roots () in - let repo = Store.Repo.v (config ~fresh:true ~lower_root root) in + let test_volume_data_locality ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let root, lower_root = fresh_roots ~fs () in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true ~lower_root root) in let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in [%log.debug "add c1"]; let () = Store.set_exn ~info main [ "c1" ] "a" in let c1 = Store.Head.get main in [%log.debug "GC c1"]; - let _ = Store.Gc.start_exn repo (Store.Commit.key c1) in + let _ = Store.Gc.start_exn ~fs ~domain_mgr repo (Store.Commit.key c1) in let _ = Store.Gc.finalise_exn ~wait:true repo in let () = Store.add_volume repo in [%log.debug "add c2, c3, c4"]; @@ -432,7 +457,7 @@ module Store_tc = struct let () = Store.set_exn ~info main [ "c5" ] "e" in let c5 = Store.Head.get main in [%log.debug "GC c5"]; - let _ = Store.Gc.start_exn repo (Store.Commit.key c5) in + let _ = Store.Gc.start_exn ~fs ~domain_mgr repo (Store.Commit.key c5) in let _ = Store.Gc.finalise_exn ~wait:true repo in let get_direct_key key = match Irmin_pack_unix.Pack_key.inspect key with @@ -475,15 +500,16 @@ module Store_tc = struct in Store.Repo.close repo - let test_cleanup () = - let root, lower_root = fresh_roots () in + let test_cleanup ~fs ~domain_mgr () = + Eio.Switch.run @@ fun sw -> + let root, lower_root = fresh_roots ~fs () in [%log.debug "create store with data and run GC"]; - let repo = Store.Repo.v (config ~fresh:true ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true ~lower_root root) in let main = Store.main repo in let info () = Store.Info.v ~author:"test" Int64.zero in let () = Store.set_exn ~info main [ "a" ] "a" in let c1 = Store.Head.get main in - let _ = Store.Gc.start_exn repo (Store.Commit.key c1) in + let _ = Store.Gc.start_exn ~fs ~domain_mgr repo (Store.Commit.key c1) in let _ = Store.Gc.finalise_exn ~wait:true repo in let volume_root = volume_path repo Int63.zero in let generation = generation repo in @@ -496,7 +522,7 @@ module Store_tc = struct Irmin_pack.Layout.V5.Volume.control ~root:volume_root in let$ () = Io.move_file ~src:volume_cf_path ~dst:volume_cf_gen_path in - let repo = Store.Repo.v (config ~fresh:false ~lower_root root) in + let repo = Store.Repo.v (config ~sw ~fs ~fresh:false ~lower_root root) in let () = match Io.classify_path volume_cf_path with | `File -> [%log.debug "control file exists"] @@ -513,38 +539,43 @@ end module Store = struct include Store_tc - let tests = + let tests ~fs ~domain_mgr = Alcotest. [ - quick_tc "create store" test_create; - quick_tc "create nested" test_create_nested; - quick_tc "open rw with lower" test_open_rw_lower; - quick_tc "add volume with no lower" test_add_volume_wo_lower; - quick_tc "add volume during gc" test_add_volume_during_gc; - quick_tc "control file updated after add" test_add_volume_reopen; - quick_tc "add volume and reopen" test_add_volume_reopen; - quick_tc "create without lower then migrate" test_migrate; - quick_tc "migrate v2" test_migrate_v2; - quick_tc "migrate v3" test_migrate_v3; - quick_tc "migrate then gc" test_migrate_then_gc; - quick_tc "migrate then gc in lower" test_migrate_then_gc_in_lower; - quick_tc "test data locality" test_volume_data_locality; - quick_tc "test cleanup" test_cleanup; + quick_tc "create store" (test_create ~fs); + quick_tc "create nested" (test_create_nested ~fs); + quick_tc "open rw with lower" (test_open_rw_lower ~fs); + quick_tc "add volume with no lower" (test_add_volume_wo_lower ~fs); + quick_tc "add volume during gc" + (test_add_volume_during_gc ~fs ~domain_mgr); + quick_tc "control file updated after add" + (test_add_volume_reopen ~fs ~domain_mgr); + quick_tc "add volume and reopen" + (test_add_volume_reopen ~fs ~domain_mgr); + quick_tc "create without lower then migrate" (test_migrate ~fs); + quick_tc "migrate v2" (test_migrate_v2 ~fs); + quick_tc "migrate v3" (test_migrate_v3 ~fs); + quick_tc "migrate then gc" (test_migrate_then_gc ~fs ~domain_mgr); + quick_tc "migrate then gc in lower" + (test_migrate_then_gc_in_lower ~fs ~domain_mgr); + quick_tc "test data locality" + (test_volume_data_locality ~fs ~domain_mgr); + quick_tc "test cleanup" (test_cleanup ~fs ~domain_mgr); ] end module Direct = struct include Direct_tc - let tests = + let tests ~fs = Alcotest. [ - quick_tc "empty lower" test_empty; - quick_tc "volume_num too high" test_volume_num; - quick_tc "add volume" test_add_volume; - quick_tc "add volume ro" test_add_volume_ro; - quick_tc "add multiple empty" test_add_multiple_empty; - quick_tc "find volume" test_find_volume; - quick_tc "test read_exn" test_read_exn; + quick_tc "empty lower" (test_empty ~fs); + quick_tc "volume_num too high" (test_volume_num ~fs); + quick_tc "add volume" (test_add_volume ~fs); + quick_tc "add volume ro" (test_add_volume_ro ~fs); + quick_tc "add multiple empty" (test_add_multiple_empty ~fs); + quick_tc "find volume" (test_find_volume ~fs); + quick_tc "test read_exn" (test_read_exn ~fs); ] end diff --git a/test/irmin-pack/test_lower.mli b/test/irmin-pack/test_lower.mli index a2a5f61123..f120807326 100644 --- a/test/irmin-pack/test_lower.mli +++ b/test/irmin-pack/test_lower.mli @@ -15,9 +15,12 @@ *) module Store : sig - val tests : unit Alcotest.test_case list + val tests : + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + unit Alcotest.test_case list end module Direct : sig - val tests : unit Alcotest.test_case list + val tests : fs:Eio.Fs.dir_ty Eio.Path.t -> unit Alcotest.test_case list end diff --git a/test/irmin-pack/test_mapping.ml b/test/irmin-pack/test_mapping.ml index efeca51fc7..b10195de21 100644 --- a/test/irmin-pack/test_mapping.ml +++ b/test/irmin-pack/test_mapping.ml @@ -20,7 +20,7 @@ module Io = Irmin_pack_unix.Io.Unix module Errs = Irmin_pack_unix.Io_errors.Make (Io) module Sparse_file = Irmin_pack_unix.Sparse_file.Make (Io) -let test_dir = Filename.concat "_build" "test-pack-mapping" +let test_dir ~fs = Eio.Path.(fs / "_build" / "test-pack-mapping") let rec make_string_seq len () = if len <= 0 then Seq.Nil @@ -29,12 +29,17 @@ let rec make_string_seq len () = Seq.Cons (String.make quantity 'X', make_string_seq (len - quantity)) (** Call the [Mapping_file] routines to process [pairs] *) -let process_on_disk pairs = - let mapping = Irmin_pack.Layout.V5.mapping ~root:test_dir ~generation:1 in +let process_on_disk ~fs pairs = + Eio.Switch.run @@ fun sw -> + let mapping = + Irmin_pack.Layout.V5.mapping ~root:(test_dir ~fs) ~generation:1 + in Io.unlink mapping |> ignore; - let data = Irmin_pack.Layout.V5.prefix ~root:test_dir ~generation:1 in + let data = Irmin_pack.Layout.V5.prefix ~root:(test_dir ~fs) ~generation:1 in Io.unlink data |> ignore; - let sparse = Sparse_file.Ao.create ~mapping ~data |> Errs.raise_if_error in + let sparse = + Sparse_file.Ao.create ~sw ~mapping ~data |> Errs.raise_if_error + in List.iter (fun (off, len) -> Format.printf "%i (+%i) => %i@." off len (off + len); @@ -46,7 +51,7 @@ let process_on_disk pairs = Sparse_file.Ao.flush sparse |> Errs.raise_if_error; Sparse_file.Ao.close sparse |> Errs.raise_if_error; let sparse = - Sparse_file.open_ro ~mapping_size ~mapping ~data |> Errs.raise_if_error + Sparse_file.open_ro ~sw ~mapping_size ~mapping ~data |> Errs.raise_if_error in let l = ref [] in let f ~off ~len = l := (Int63.to_int off, len) :: !l in @@ -57,8 +62,8 @@ let process_on_disk pairs = (** Emulate the behaviour of the [Mapping_file] routines to process [pairs] *) let process_in_mem pairs = List.rev pairs -let test input_entries = - let output_entries = process_on_disk input_entries in +let test ~fs input_entries = + let output_entries = process_on_disk ~fs input_entries in let input_entries' = process_in_mem input_entries in Alcotest.(check (list (pair int int))) "Comparison between Mapping_file result and the in-memory equivalent" @@ -87,25 +92,25 @@ let produce_suffix_segmentation_subset full_seg ~seed = Some (off, len)) @@ Array.to_list full_seg -let test ~full_seg_length ~random_test_count = +let test ~fs ~full_seg_length ~random_test_count = (* [mkdir] may fail if the directory exists. The files in it will be overwritten at computation time. *) - Io.mkdir test_dir |> ignore; + Io.mkdir (test_dir ~fs) |> ignore; let seg = produce_suffix_segmentation full_seg_length 42 in let rec aux i = if i >= random_test_count then () else let subset = produce_suffix_segmentation_subset seg ~seed:i in - if subset <> [] then test subset; + if subset <> [] then test ~fs subset; aux (i + 1) in aux 0 -let tests = +let tests ~fs = [ Alcotest.test_case "test mapping on small inputs" `Quick (fun () -> - test ~full_seg_length:10 ~random_test_count:1000); + test ~fs ~full_seg_length:10 ~random_test_count:1000); Alcotest.test_case "test mapping on large inputs" `Quick (fun () -> - test ~full_seg_length:10000 ~random_test_count:100); + test ~fs ~full_seg_length:10000 ~random_test_count:100); ] diff --git a/test/irmin-pack/test_mapping.mli b/test/irmin-pack/test_mapping.mli index 2b40d2f891..9893a1a314 100644 --- a/test/irmin-pack/test_mapping.mli +++ b/test/irmin-pack/test_mapping.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest.test_case list +val tests : fs:Eio.Fs.dir_ty Eio.Path.t -> unit Alcotest.test_case list diff --git a/test/irmin-pack/test_multicore.ml b/test/irmin-pack/test_multicore.ml index a93518bd00..290093effc 100644 --- a/test/irmin-pack/test_multicore.ml +++ b/test/irmin-pack/test_multicore.ml @@ -17,7 +17,7 @@ open! Import open Common -let root = Filename.concat "_build" "test-multicore" +let root ~fs = Eio.Path.(fs / "_build" / "test-multicore") let src = Logs.Src.create "tests.multicore" ~doc:"Tests" module Log = (val Logs.src_log src : Logs.LOG) @@ -106,19 +106,21 @@ let rec list_shape acc path : shape -> _ = function let list_shape shape = list_shape [] [] shape -let make_store shape = - let repo = Store.Repo.v (Store.config ~fresh:true root) in +let make_store ~fs shape = + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = Store.Repo.v (Store.config ~sw ~fs ~fresh:true root) in let main = Store.main repo in let tree = make_tree shape in let () = Store.set_tree_exn ~info main [] tree in Store.Repo.close repo -let domains_run d_mgr fns = +let domains_run ~domain_mgr fns = let count = Atomic.make (List.length fns) in let fibers = List.map (fun fn () -> - Eio.Domain_manager.run d_mgr (fun () -> + Eio.Domain_manager.run domain_mgr (fun () -> Atomic.decr count; while Atomic.get count > 0 do Domain.cpu_relax () @@ -128,8 +130,8 @@ let domains_run d_mgr fns = in Eio.Fiber.all fibers -let domains_spawn d_mgr ?(nb = 2) fn = - domains_run d_mgr @@ List.init nb (fun _ -> fn) +let domains_spawn ~domain_mgr ?(nb = 2) fn = + domains_run ~domain_mgr @@ List.init nb (fun _ -> fn) let find_all tree paths = List.iter @@ -139,13 +141,17 @@ let find_all tree paths = | Some value -> assert (expected = value)) paths -let test_find d_mgr = +let test_find ~fs ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:true ~fresh:false root) + in let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in let paths = flatten_shape shape0 in - domains_spawn d_mgr (fun () -> find_all tree paths); + domains_spawn ~domain_mgr (fun () -> find_all tree paths); Store.Repo.close repo let rec expected_lengths acc path : shape -> _ = function @@ -158,10 +164,14 @@ let rec expected_lengths acc path : shape -> _ = function let expected_lengths shape = expected_lengths [] [] shape -let test_length d_mgr = +let test_length ~fs ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:true ~fresh:false root) + in let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in let lengths = expected_lengths shape0 in let all_length () = @@ -172,7 +182,7 @@ let test_length d_mgr = assert (expected = value)) lengths in - domains_spawn ~nb:2 d_mgr all_length; + domains_spawn ~nb:2 ~domain_mgr all_length; Store.Repo.close repo let rec remove_all acc path : shape -> _ = function @@ -210,10 +220,14 @@ let rec diff_shape acc path (old_shape : shape option) (new_shape : shape) = let diff_shape old_shape new_shape = List.rev @@ diff_shape [] [] (Some old_shape) new_shape -let test_add_remove d_mgr = +let test_add_remove ~fs ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:true ~fresh:false root) + in let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in let patch = diff_shape shape0 shape1 in let after_paths = flatten_shape shape1 in @@ -232,7 +246,7 @@ let test_add_remove d_mgr = | `Remove name -> assert (not (Tree.mem tree name))) patch in - domains_spawn ~nb:2 d_mgr add_all; + domains_spawn ~nb:2 ~domain_mgr add_all; Store.Repo.close repo let apply_op tree = function @@ -247,10 +261,14 @@ let check_patch_was_applied patch tree = | `Remove name -> assert (not (Store.Tree.mem tree name))) patch -let test_commit d_mgr = +let test_commit ~fs ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:false ~fresh:false root) + in let store = Store.main repo in let patch01 = diff_shape shape0 shape1 in let patch02 = diff_shape shape0 shape2 in @@ -264,13 +282,17 @@ let test_commit d_mgr = let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in check_patch_was_applied patch tree in - domains_run d_mgr [ do_commit patch01; do_commit patch02 ]; + domains_run ~domain_mgr [ do_commit patch01; do_commit patch02 ]; Store.Repo.close repo -let test_merkle d_mgr = +let test_merkle ~fs ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:false ~fresh:false root) + in let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in let hash = Store.Tree.key tree |> Option.get in let patch01 = diff_shape shape0 shape1 in @@ -285,13 +307,17 @@ let test_merkle d_mgr = | Ok (new_tree, ()) -> check_patch_was_applied patch new_tree | Error _ -> assert false in - domains_run d_mgr [ do_proof patch01; do_proof patch02 ]; + domains_run ~domain_mgr [ do_proof patch01; do_proof patch02 ]; Store.Repo.close repo -let test_hash d_mgr = +let test_hash ~fs ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:false ~fresh:false root) + in let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in let patch01 = diff_shape shape0 shape1 in let patch12 = diff_shape shape1 shape2 in @@ -309,7 +335,7 @@ let test_hash d_mgr = in let result1 = Atomic.make [] in let result2 = Atomic.make [] in - domains_run d_mgr [ do_hash result1; do_hash result2 ]; + domains_run ~domain_mgr [ do_hash result1; do_hash result2 ]; List.iter2 (fun h1 h2 -> assert (h1 = h2)) (Atomic.get result1) (Atomic.get result2); @@ -328,30 +354,42 @@ let list_all cache tree paths = expected) paths -let test_list_disk ~cache d_mgr = +let test_list_disk ~fs ~cache ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:true ~fresh:false root) + in let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in let paths = list_shape shape0 in - domains_spawn d_mgr (fun () -> list_all cache tree paths); + domains_spawn ~domain_mgr (fun () -> list_all cache tree paths); Store.Repo.close repo -let test_list_mem ~cache d_mgr = +let test_list_mem ~fs ~cache ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:true ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:true ~fresh:false root) + in let tree = Store.main repo |> Store.Head.get |> Store.Commit.tree in let patch = diff_shape shape0 shape1 in let paths = list_shape shape1 in let tree = List.fold_left apply_op tree patch in - domains_spawn d_mgr (fun _ -> list_all cache tree paths); + domains_spawn ~domain_mgr (fun _ -> list_all cache tree paths); Store.Repo.close repo -let test_commit_of_hash d_mgr = +let test_commit_of_hash ~fs ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:false ~fresh:false root) + in let store = Store.main repo in let patch01 = diff_shape shape0 shape1 in let patch02 = diff_shape shape0 shape2 in @@ -393,13 +431,17 @@ let test_commit_of_hash d_mgr = let diffs = Store.Tree.diff tree3 t3 in assert (diffs = []) in - domains_spawn d_mgr do_commit_of_hash; + domains_spawn ~domain_mgr do_commit_of_hash; Store.Repo.close repo -let test_commit_parents d_mgr = +let test_commit_parents ~fs ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:false ~fresh:false root) + in let store = Store.main repo in let patch01 = diff_shape shape0 shape1 in let commit = Store.Head.get store in @@ -422,13 +464,17 @@ let test_commit_parents d_mgr = commit) commit commits) in - domains_spawn d_mgr do_commit_parents; + domains_spawn ~domain_mgr do_commit_parents; Store.Repo.close repo -let test_commit_v d_mgr = +let test_commit_v ~fs ~domain_mgr = Logs.set_level None; - make_store shape0; - let repo = Store.Repo.v (Store.config ~readonly:false ~fresh:false root) in + make_store ~fs shape0; + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let repo = + Store.Repo.v (Store.config ~sw ~fs ~readonly:false ~fresh:false root) + in let store = Store.main repo in let patch01 = diff_shape shape0 shape1 in let commit = Store.Head.get store in @@ -441,23 +487,24 @@ let test_commit_v d_mgr = in () in - domains_spawn d_mgr do_commit_v; + domains_spawn ~domain_mgr do_commit_v; Store.Repo.close repo -let tests d_mgr = - let tc name fn = Alcotest.test_case name `Quick (fun () -> fn d_mgr) in +(* TODO: Eio has to be fixed first to allow a switch to be used from different domains *) +let tests ~fs ~domain_mgr = + let tc name fn = Alcotest.test_case name `Quick (fun () -> fn ~domain_mgr) in [ - tc "find." test_find; - tc "length." test_length; - tc "add / remove." test_add_remove; - tc "commit." test_commit; - tc "merkle." test_merkle; - tc "hash." test_hash; - tc "list-disk-no-cache." (test_list_disk ~cache:false); - tc "list-disk-with-cache." (test_list_disk ~cache:true); - tc "list-mem-no-cache." (test_list_mem ~cache:false); - tc "list-mem-with-cache." (test_list_mem ~cache:true); - tc "commit-of-hash." test_commit_of_hash; - tc "commit-parents." test_commit_parents; - tc "commit-v." test_commit_v; + tc "find." (test_find ~fs); + tc "length." (test_length ~fs); + tc "add / remove." (test_add_remove ~fs); + tc "commit." (test_commit ~fs); + tc "merkle." (test_merkle ~fs); + tc "hash." (test_hash ~fs); + tc "list-disk-no-cache." (test_list_disk ~fs ~cache:false); + tc "list-disk-with-cache." (test_list_disk ~fs ~cache:true); + tc "list-mem-no-cache." (test_list_mem ~fs ~cache:false); + tc "list-mem-with-cache." (test_list_mem ~fs ~cache:true); + tc "commit-of-hash." (test_commit_of_hash ~fs); + tc "commit-parents." (test_commit_parents ~fs); + tc "commit-v." (test_commit_v ~fs); ] diff --git a/test/irmin-pack/test_pack.ml b/test/irmin-pack/test_pack.ml index 0e26886e61..9cc19a4ca8 100644 --- a/test/irmin-pack/test_pack.ml +++ b/test/irmin-pack/test_pack.ml @@ -17,7 +17,7 @@ open! Import open Common -let test_dir = Filename.concat "_build" "test-db-pack" +let test_dir ~fs = Eio.Path.(fs / "_build" / "test-db-pack") module Irmin_pack_store (Config : Irmin_pack.Conf.S) : Irmin_test.Generic_key = struct @@ -31,15 +31,19 @@ struct end) end -let suite_pack name_suffix indexing_strategy (module Config : Irmin_pack.Conf.S) - = +let suite_pack name_suffix ~sw ~fs indexing_strategy + (module Config : Irmin_pack.Conf.S) = let store = (module Irmin_pack_store (Config) : Irmin_test.Generic_key) in + let test_dir = test_dir ~fs in let config = - Irmin_pack.config ~fresh:false ~lru_size:0 ~indexing_strategy test_dir + Irmin_pack.config ~sw ~fs ~fresh:false ~lru_size:0 ~indexing_strategy + test_dir in let init ~config = let test_dir = - Irmin.Backend.Conf.find_root config |> Option.value ~default:test_dir + Irmin.Backend.Conf.find_root config + |> Option.map (fun s -> Eio.Path.(fs / s)) + |> Option.value ~default:test_dir in rm_dir test_dir in @@ -65,13 +69,14 @@ module Irmin_pack_mem_maker : Irmin_test.Generic_key = struct end) end -let suite_mem = +let suite_mem ~sw ~fs = let store = (module Irmin_pack_mem_maker : Irmin_test.Generic_key) in - let config = Irmin_pack.config ~fresh:false ~lru_size:0 test_dir in + let test_dir = test_dir ~fs in + let config = Irmin_pack.config ~sw ~fs ~fresh:false ~lru_size:0 test_dir in Irmin_test.Suite.create_generic_key ~import_supported:false ~name:"PACK MEM" ~store ~config () -let suite = +let suite ~sw ~fs = let module Index = Irmin_pack.Indexing_strategy in let module Conf_small_nodes = struct (* Parameters chosen to be different from those in [Irmin_tezos.Conf]: *) @@ -82,9 +87,9 @@ let suite = let forbid_empty_dir_persistence = false end in [ - suite_pack " { Tezos }" Index.minimal (module Irmin_tezos_conf); - suite_pack " { Small_nodes }" Index.always (module Conf_small_nodes); - suite_mem; + suite_pack ~sw ~fs " { Tezos }" Index.minimal (module Irmin_tezos_conf); + suite_pack ~sw ~fs " { Small_nodes }" Index.always (module Conf_small_nodes); + suite_mem ~sw ~fs; ] module Context = Make_context (struct @@ -95,8 +100,11 @@ let flush fm = File_manager.flush fm |> Errs.raise_if_error let reload fm = File_manager.reload fm |> Errs.raise_if_error module Dict = struct - let test_dict () = - let (d : Context.d) = Context.get_dict ~readonly:false ~fresh:true () in + let test_dict ~fs () = + Eio.Switch.run @@ fun sw -> + let (d : Context.d) = + Context.get_dict ~sw ~fs ~readonly:false ~fresh:true () + in let x1 = Dict.index d.dict "foo" in Alcotest.(check (option int)) "foo" (Some 0) x1; let x1 = Dict.index d.dict "foo" in @@ -111,7 +119,7 @@ module Dict = struct Alcotest.(check (option int)) "foo" (Some 0) x1; flush d.fm; let (d2 : Context.d) = - Context.get_dict ~name:d.name ~readonly:false ~fresh:false () + Context.get_dict ~sw ~fs ~name:d.name ~readonly:false ~fresh:false () in let x4 = Dict.index d2.dict "titiabc" in Alcotest.(check (option int)) "titiabc" (Some 3) x4; @@ -123,7 +131,7 @@ module Dict = struct Alcotest.(check (option string)) "find x3" (Some "toto") v3; Context.close_dict d; let (d3 : Context.d) = - Context.get_dict ~name:d.name ~readonly:false ~fresh:false () + Context.get_dict ~sw ~fs ~name:d.name ~readonly:false ~fresh:false () in let v1 = Dict.find d3.dict (get x1) in Alcotest.(check (option string)) "find x1" (Some "foo") v1; @@ -132,10 +140,13 @@ module Dict = struct let ignore_int (_ : int option) = () - let test_readonly_dict () = - let (d : Context.d) = Context.get_dict ~readonly:false ~fresh:true () in + let test_readonly_dict ~fs () = + Eio.Switch.run @@ fun sw -> + let (d : Context.d) = + Context.get_dict ~sw ~fs ~readonly:false ~fresh:true () + in let (d2 : Context.d) = - Context.get_dict ~name:d.name ~readonly:true ~fresh:false () + Context.get_dict ~sw ~fs ~name:d.name ~readonly:true ~fresh:false () in let check_index k i = Alcotest.(check (option int)) k (Some i) (Dict.index d2.dict k) @@ -174,16 +185,17 @@ module Dict = struct Context.close_dict d; Context.close_dict d2 - let tests = + let tests ~fs = [ - Alcotest.test_case "dict" `Quick test_dict; - Alcotest.test_case "RO dict" `Quick test_readonly_dict; + Alcotest.test_case "dict" `Quick (test_dict ~fs); + Alcotest.test_case "RO dict" `Quick (test_readonly_dict ~fs); ] end module Pack = struct - let test_pack () = - let t = Context.get_rw_pack () in + let test_pack ~fs () = + Eio.Switch.run @@ fun sw -> + let t = Context.get_rw_pack ~sw ~fs in let x1 = "foo" in let x2 = "bar" in let x3 = "otoo" in @@ -213,14 +225,15 @@ module Pack = struct Alcotest.(check string) "x4" x4 y4 in test t.pack; - let t' = Context.get_ro_pack t.name in + let t' = Context.get_ro_pack ~sw ~fs t.name in test t'.pack; Context.close_pack t; Context.close_pack t' - let test_readonly_pack () = - let t = Context.get_rw_pack () in - let t' = Context.get_ro_pack t.name in + let test_readonly_pack ~fs () = + Eio.Switch.run @@ fun sw -> + let t = Context.get_rw_pack ~sw ~fs in + let t' = Context.get_ro_pack ~sw ~fs t.name in let () = let adds l = List.map @@ -254,9 +267,10 @@ module Pack = struct Context.close_pack t; Context.close_pack t' - let test_close_pack_more () = + let test_close_pack_more ~fs () = + Eio.Switch.run @@ fun sw -> (*open and close in rw*) - let t = Context.get_rw_pack () in + let t = Context.get_rw_pack ~sw ~fs in let x1 = "foo" in let h1 = sha1_contents x1 in let k1 = @@ -265,23 +279,24 @@ module Pack = struct flush t.fm; Context.close_pack t; (*open and close in ro*) - let t1 = Context.get_ro_pack t.name in + let t1 = Context.get_ro_pack ~sw ~fs t.name in let y1 = Pack.find t1.pack k1 |> get in Alcotest.(check string) "x1.1" x1 y1; Context.close_pack t1; (* reopen in rw *) - let t2 = Context.reopen_rw t.name in + let t2 = Context.reopen_rw ~sw ~fs t.name in let y1 = Pack.find t2.pack k1 |> get in Alcotest.(check string) "x1.2" x1 y1; (*reopen in ro *) - let t3 = Context.get_ro_pack t.name in + let t3 = Context.get_ro_pack ~sw ~fs t.name in let y1 = Pack.find t3.pack k1 |> get in Alcotest.(check string) "x1.3" x1 y1; Context.close_pack t2; Context.close_pack t3 - let test_close_pack () = - let t = Context.get_rw_pack () in + let test_close_pack ~fs () = + Eio.Switch.run @@ fun sw -> + let t = Context.get_rw_pack ~sw ~fs in let w = t.pack in let x1 = "foo" in let x2 = "bar" in @@ -296,7 +311,7 @@ module Pack = struct in Context.close_pack t; (*reopen in rw *) - let t' = Context.reopen_rw t.name in + let t' = Context.reopen_rw ~sw ~fs t.name in let y2 = Pack.find t'.pack k2 |> get in Alcotest.(check string) "x2.1" x2 y2; let y1 = Pack.find t'.pack k1 |> get in @@ -308,7 +323,7 @@ module Pack = struct in Context.close_pack t'; (*reopen in rw *) - let t2 = Context.reopen_rw t.name in + let t2 = Context.reopen_rw ~sw ~fs t.name in let y2 = Pack.find t2.pack k2 |> get in Alcotest.(check string) "x2.2" x2 y2; let y3 = Pack.find t2.pack k3 |> get in @@ -317,7 +332,7 @@ module Pack = struct Alcotest.(check string) "x1.2" x1 y1; Context.close_pack t2; (*reopen in ro *) - let t' = Context.get_ro_pack t.name in + let t' = Context.get_ro_pack ~sw ~fs t.name in let y1 = Pack.find t'.pack k1 |> get in Alcotest.(check string) "x1.3" x1 y1; let y2 = Pack.find t'.pack k2 |> get in @@ -327,9 +342,10 @@ module Pack = struct (** Index can be flushed to disk independently of pack, we simulate this in the tests using [Index.filter] and [Index.flush]. Regression test for PR 1008 in which values were indexed before being reachable in pack. *) - let readonly_reload_index_flush () = - let t = Context.get_rw_pack () in - let t' = Context.get_ro_pack t.name in + let readonly_reload_index_flush ~fs () = + Eio.Switch.run @@ fun sw -> + let t = Context.get_rw_pack ~sw ~fs in + let t' = Context.get_ro_pack ~sw ~fs t.name in let test w = let x1 = "foo" in let h1 = sha1_contents x1 in @@ -357,9 +373,10 @@ module Pack = struct Context.close_pack t; Context.close_pack t' - let readonly_find_index_flush () = - let t = Context.get_rw_pack () in - let t' = Context.get_ro_pack t.name in + let readonly_find_index_flush ~fs () = + Eio.Switch.run @@ fun sw -> + let t = Context.get_rw_pack ~sw ~fs in + let t' = Context.get_ro_pack ~sw ~fs t.name in let check h x msg = let y = Pack.find t'.pack h in Alcotest.(check (option string)) msg (Some x) y @@ -398,16 +415,16 @@ module Pack = struct Context.close_pack t; Context.close_pack t' - let tests = + let tests ~fs = [ - Alcotest.test_case "pack" `Quick test_pack; - Alcotest.test_case "RO pack" `Quick test_readonly_pack; - Alcotest.test_case "close" `Quick test_close_pack; - Alcotest.test_case "close readonly" `Quick test_close_pack_more; + Alcotest.test_case "pack" `Quick (test_pack ~fs); + Alcotest.test_case "RO pack" `Quick (test_readonly_pack ~fs); + Alcotest.test_case "close" `Quick (test_close_pack ~fs); + Alcotest.test_case "close readonly" `Quick (test_close_pack_more ~fs); Alcotest.test_case "readonly reload, index flush" `Quick - readonly_reload_index_flush; + (readonly_reload_index_flush ~fs); Alcotest.test_case "readonly find, index flush" `Quick - readonly_find_index_flush; + (readonly_find_index_flush ~fs); ] end @@ -420,7 +437,7 @@ module Branch = struct let pp_hash = Irmin.Type.pp Irmin.Hash.SHA1.t - let test_branch () = + let test_branch ~fs () = let branches = [ "foo"; "bar/toto"; "titi" ] in let test t = List.iter (fun k -> Branch.set t k (sha1 k)) branches; @@ -430,21 +447,22 @@ module Branch = struct in List.map check branches |> Eio.Fiber.all in - let name = Context.fresh_name "branch" in - Branch.v ~fresh:true name |> test; - Branch.v ~fresh:true name |> test; - Branch.v ~fresh:true name |> test; - let t = Branch.v ~fresh:false name in + let name = Context.fresh_name ~fs "branch" in + Eio.Switch.run @@ fun sw -> + Branch.v ~sw ~fresh:true name |> test; + Branch.v ~sw ~fresh:true name |> test; + Branch.v ~sw ~fresh:true name |> test; + let t = Branch.v ~sw ~fresh:false name in test t; let x = sha1 "XXX" in Branch.set t "foo" x; - let t = Branch.v ~fresh:false name in + let t = Branch.v ~sw ~fresh:false name in let v = Branch.find t "foo" in Alcotest.(check (option hash)) "foo" (Some x) v; let br = Branch.list t in Alcotest.(check (slist string compare)) "branches" branches br; Branch.remove t "foo"; - let t = Branch.v ~fresh:false name in + let t = Branch.v ~sw ~fresh:false name in let v = Branch.find t "foo" in Alcotest.(check (option hash)) "foo none" None v; let br = Branch.list t in @@ -453,7 +471,8 @@ module Branch = struct (List.filter (( <> ) "foo") branches) br - let test_close_branch () = + let test_close_branch ~fs () = + Eio.Switch.run @@ fun sw -> let branches = [ "foo"; "bar/toto"; "titi" ] in let add t = List.iter @@ -469,47 +488,50 @@ module Branch = struct in List.map check branches |> Eio.Fiber.all in - let name = Context.fresh_name "branch" in - let t = Branch.v ~fresh:true name in + let name = Context.fresh_name ~fs "branch" in + let t = Branch.v ~sw ~fresh:true name in add t; test t; Branch.close t; - let t = Branch.v ~fresh:false ~readonly:true name in + let t = Branch.v ~sw ~fresh:false ~readonly:true name in test t; Branch.close t; - let name = Context.fresh_name "branch" in - let t1 = Branch.v ~fresh:true ~readonly:false name in - let t2 = Branch.v ~fresh:false ~readonly:true name in + let name = Context.fresh_name ~fs "branch" in + let t1 = Branch.v ~sw ~fresh:true ~readonly:false name in + let t2 = Branch.v ~sw ~fresh:false ~readonly:true name in add t1; Branch.close t1; test t2 - let tests = + let tests ~fs = [ - Alcotest.test_case "branch" `Quick test_branch; - Alcotest.test_case "branch close" `Quick test_close_branch; + Alcotest.test_case "branch" `Quick (test_branch ~fs); + Alcotest.test_case "branch close" `Quick (test_close_branch ~fs); ] end module Layout = struct - let test_classify_upper_filename () = + let basename path = snd @@ Option.get @@ Eio.Path.split path + + let test_classify_upper_filename ~fs () = let module V1_and_v2 = Irmin_pack.Layout.V1_and_v2 in let module V4 = Irmin_pack.Layout.V4 in let module Classification = Irmin_pack.Layout.Classification.Upper in let c = Alcotest.(check (testable_repr Classification.t)) "" in let classif = Classification.v in - c `V1_or_v2_pack (V1_and_v2.pack ~root:"" |> classif); - c `Branch (V4.branch ~root:"" |> classif); - c `Control (V4.control ~root:"" |> classif); - c `Control_tmp (V4.control_tmp ~root:"" |> classif); - c `Dict (V4.dict ~root:"" |> classif); - c (`Gc_result 0) (V4.gc_result ~generation:0 ~root:"" |> classif); - c (`Reachable 1) (V4.reachable ~generation:1 ~root:"" |> classif); - c (`Sorted 10) (V4.sorted ~generation:10 ~root:"" |> classif); - c (`Mapping 100) (V4.mapping ~generation:100 ~root:"" |> classif); - c (`Prefix 1000) (V4.prefix ~generation:1000 ~root:"" |> classif); - c (`Suffix 42) (V4.suffix_chunk ~chunk_idx:42 ~root:"" |> classif); - c `Unknown (V4.prefix ~generation:(-1) ~root:"" |> classif); + c `V1_or_v2_pack (V1_and_v2.pack ~root:fs |> basename |> classif); + c `Branch (V4.branch ~root:fs |> basename |> classif); + c `Control (V4.control ~root:fs |> basename |> classif); + c `Control_tmp (V4.control_tmp ~root:fs |> basename |> classif); + c `Dict (V4.dict ~root:fs |> basename |> classif); + c (`Gc_result 0) (V4.gc_result ~generation:0 ~root:fs |> basename |> classif); + c (`Reachable 1) (V4.reachable ~generation:1 ~root:fs |> basename |> classif); + c (`Sorted 10) (V4.sorted ~generation:10 ~root:fs |> basename |> classif); + c (`Mapping 100) (V4.mapping ~generation:100 ~root:fs |> basename |> classif); + c (`Prefix 1000) (V4.prefix ~generation:1000 ~root:fs |> basename |> classif); + c (`Suffix 42) + (V4.suffix_chunk ~chunk_idx:42 ~root:fs |> basename |> classif); + c `Unknown (V4.prefix ~generation:(-1) ~root:fs |> basename |> classif); c `Unknown (classif "store.toto"); c `Unknown (classif "store."); c `Unknown (classif "store"); @@ -518,15 +540,15 @@ module Layout = struct c `Unknown (classif "./store.0.prefix"); () - let test_classify_volume_filename () = + let test_classify_volume_filename ~fs () = let module V1_and_v2 = Irmin_pack.Layout.V1_and_v2 in let module V5 = Irmin_pack.Layout.V5.Volume in let module Classification = Irmin_pack.Layout.Classification.Volume in let c = Alcotest.(check (testable_repr Classification.t)) "" in let classif = Classification.v in - c `Control (V5.control ~root:"" |> classif); - c `Mapping (V5.mapping ~root:"" |> classif); - c `Data (V5.data ~root:"" |> classif); + c `Control (V5.control ~root:fs |> basename |> classif); + c `Mapping (V5.mapping ~root:fs |> basename |> classif); + c `Data (V5.data ~root:fs |> basename |> classif); c `Unknown (classif "store.toto"); c `Unknown (classif "store."); c `Unknown (classif "store"); @@ -535,43 +557,43 @@ module Layout = struct c `Unknown (classif "./store.0.prefix"); () - let tests = + let tests ~fs = [ Alcotest.test_case "classify upper files" `Quick - test_classify_upper_filename; + (test_classify_upper_filename ~fs); Alcotest.test_case "classify volume files" `Quick - test_classify_volume_filename; + (test_classify_volume_filename ~fs); ] end -let misc d_mgr = +let misc ~sr ~fs ~domain_mgr = [ - ("hashes", Test_hashes.tests); - ("dict-files", Dict.tests); - ("pack-files", Pack.tests); - ("branch-files", Branch.tests); - ("read-only", Test_readonly.tests); - ("existing stores", Test_existing_stores.tests); - ("inodes", Test_inode.tests); - ("trees", Test_tree.tests); - ("version-bump", Test_pack_version_bump.tests); - ("snapshot", Test_snapshot.tests); - ("upgrade", Test_upgrade.tests); - ("gc", Test_gc.Gc.tests); - ("concurrent gc", Test_gc.Concurrent_gc.tests); - ("gc archival", Test_gc.Gc_archival.tests); - ("split", Test_gc.Split.tests); - ("flush", Test_flush_reload.tests); + ("hashes", Test_hashes.tests ~fs); + ("dict-files", Dict.tests ~fs); + ("pack-files", Pack.tests ~fs); + ("branch-files", Branch.tests ~fs); + ("read-only", Test_readonly.tests ~fs); + ("existing stores", Test_existing_stores.tests ~fs ~domain_mgr); + ("inodes", Test_inode.tests ~fs); + ("trees", Test_tree.tests ~fs); + ("version-bump", Test_pack_version_bump.tests ~sr ~fs); + ("snapshot", Test_snapshot.tests ~fs ~domain_mgr); + ("upgrade", Test_upgrade.tests ~fs ~domain_mgr); + ("gc", Test_gc.Gc.tests ~fs ~domain_mgr); + ("concurrent gc", Test_gc.Concurrent_gc.tests ~fs ~domain_mgr); + ("gc archival", Test_gc.Gc_archival.tests ~fs ~domain_mgr); + ("split", Test_gc.Split.tests ~fs ~domain_mgr); + ("flush", Test_flush_reload.tests ~fs); ("ranges", Test_ranges.tests); - ("mapping", Test_mapping.tests); + ("mapping", Test_mapping.tests ~fs); ("test_nearest_geq", Test_nearest_geq.tests); - ("layout", Layout.tests); - ("dispatcher", Test_dispatcher.tests); - ("corrupted", Test_corrupted.tests); - ("snapshot_gc", Test_gc.Snapshot.tests); - ("async tasks", Test_async.tests); - ("indexing strategy", Test_indexing_strategy.tests); - ("lower: direct", Test_lower.Direct.tests); - ("lower: store", Test_lower.Store.tests); - ("multicore", Test_multicore.tests d_mgr); + ("layout", Layout.tests ~fs); + ("dispatcher", Test_dispatcher.tests ~fs ~domain_mgr); + ("corrupted", Test_corrupted.tests ~fs); + ("snapshot_gc", Test_gc.Snapshot.tests ~fs ~domain_mgr); + ("async tasks", Test_async.tests ~domain_mgr); + ("indexing strategy", Test_indexing_strategy.tests ~fs); + ("lower: direct", Test_lower.Direct.tests ~fs); + ("lower: store", Test_lower.Store.tests ~fs ~domain_mgr); + ("multicore", Test_multicore.tests ~fs ~domain_mgr); ] diff --git a/test/irmin-pack/test_pack.mli b/test/irmin-pack/test_pack.mli index 03142f091b..d666b80e4a 100644 --- a/test/irmin-pack/test_pack.mli +++ b/test/irmin-pack/test_pack.mli @@ -14,7 +14,11 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val suite : Irmin_test.Suite.t list +val suite : + sw:Eio.Switch.t -> fs:Eio.Fs.dir_ty Eio.Path.t -> Irmin_test.Suite.t list val misc : - _ Eio.Domain_manager.t -> (string * unit Alcotest.test_case list) list + sr:Eio__Flow.source_ty Eio.Std.r -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + domain_mgr:_ Eio.Domain_manager.t -> + (string * unit Alcotest.test_case list) list diff --git a/test/irmin-pack/test_pack_version_bump.ml b/test/irmin-pack/test_pack_version_bump.ml index 13ee4019d2..ecdae7d64b 100644 --- a/test/irmin-pack/test_pack_version_bump.ml +++ b/test/irmin-pack/test_pack_version_bump.ml @@ -37,7 +37,23 @@ module Util = struct let exec_cmd = Common.exec_cmd let ( / ) = Filename.concat - let tmp_dir () = Filename.temp_file "test_pack_version_bump_" "" + + let tmp_dir ~sr ~fs prefix = + let cs = Cstruct.create 4 in + let rec f () = + (* TODO: remove [sr] *) + Eio.Flow.read_exact sr cs; + let i = Cstruct.LE.get_uint16 cs 0 in + let tmp = Eio.Path.(fs / "tmp") in + Eio.Path.mkdirs ~exists_ok:true ~perm:0o700 tmp; + let path = Eio.Path.(tmp / (prefix ^ Int.to_string i)) in + match Eio.Path.kind ~follow:false path with + | `Not_found -> + Eio.Path.mkdir ~perm:0o700 path; + path + | _ -> f () + in + f () (** Copy src to dst; dst is assumed to not exist *) let copy_dir src dst = @@ -92,7 +108,8 @@ module Util = struct (** Get the version of the underlying file; file is assumed to exist; file is assumed to be an Irmin_pack.IO.Unix file *) let io_get_version ~root : [ `V1 | `V2 | `V3 | `V4 | `V5 ] = - File_manager.version ~root |> Errs.raise_if_error + Eio.Switch.run @@ fun sw -> + File_manager.version ~sw ~root |> Errs.raise_if_error let alco_check_version ~pos ~expected ~actual = Alcotest.check_repr ~pos Irmin_pack.Version.t "" expected actual @@ -101,15 +118,16 @@ end open Util (** This sets up infrastructure to open the existing "version_1" store *) -module With_existing_store () = struct - let tmp_dir = tmp_dir () - let () = [%log.info "Using temporary directory %s" tmp_dir] - +module With_existing_store = struct (* Make a copy of the v1_store_archive_dir in tmp_dir *) - let () = + let init ~sr ~fs () = + let tmp_dir = tmp_dir ~sr ~fs "test_pack_version_bump_" in rm_dir tmp_dir; - copy_dir (project_root () / v1_store_archive_dir) tmp_dir; - () + [%log.info "Using temporary directory %s" (Eio.Path.native_exn tmp_dir)]; + copy_dir + (project_root () / v1_store_archive_dir) + (Eio.Path.native_exn tmp_dir); + tmp_dir (* [S] is the functionality we use from Private, together with an appropriate config *) @@ -117,42 +135,51 @@ module With_existing_store () = struct (* Code copied and modified from test_existing_stores.ml; this is the config for index and pack *) - let config ~readonly : Irmin.config = - Irmin_pack.config ~readonly ~index_log_size:1000 ~fresh:false tmp_dir + let config ~sw ~fs ~tmp_dir ~readonly : Irmin.config = + Irmin_pack.config ~sw ~fs ~readonly ~index_log_size:1000 ~fresh:false + tmp_dir end (** {2 The tests} *) (** Cannot open a V1 store in RO mode. *) -let test_RO_no_migration () : unit = +let test_RO_no_migration ~sr ~fs () : unit = [%log.info "Executing test_RO_no_migration"]; - let open With_existing_store () in + Eio.Switch.run @@ fun sw -> + let tmp_dir = With_existing_store.init ~sr ~fs () in assert (io_get_version ~root:tmp_dir = `V1); let () = Alcotest.check_raises "open V1 store in RO" (Irmin_pack_unix.Errors.Pack_error `Migration_needed) (fun () -> - let repo = S.Repo.v (config ~readonly:true) in - S.Repo.close repo) + let repo = + With_existing_store.S.Repo.v + (With_existing_store.config ~sw ~fs ~tmp_dir ~readonly:true) + in + With_existing_store.S.Repo.close repo) in (* maybe the version bump is only visible after, check again *) alco_check_version ~pos:__POS__ ~expected:`V1 ~actual:(io_get_version ~root:tmp_dir) (** Open a V1 store RW mode. Even if no writes, the store migrates to V3. *) -let test_open_RW () = +let test_open_RW ~sr ~fs () = [%log.info "Executing test_open_RW"]; - let open With_existing_store () in + Eio.Switch.run @@ fun sw -> + let tmp_dir = With_existing_store.init ~sr ~fs () in assert (io_get_version ~root:tmp_dir = `V1); - let repo = S.Repo.v (config ~readonly:false) in - let () = S.Repo.close repo in + let repo = + With_existing_store.S.Repo.v + (With_existing_store.config ~sw ~fs ~tmp_dir ~readonly:false) + in + let () = With_existing_store.S.Repo.close repo in alco_check_version ~pos:__POS__ ~expected:`V3 ~actual:(io_get_version ~root:tmp_dir) -let tests = +let tests ~sr ~fs = let f g () = g () in Alcotest. [ - test_case "test_RO_no_migration" `Quick (f test_RO_no_migration); - test_case "test_open_RW" `Quick (f test_open_RW); + test_case "test_RO_no_migration" `Quick (f (test_RO_no_migration ~sr ~fs)); + test_case "test_open_RW" `Quick (f (test_open_RW ~sr ~fs)); ] diff --git a/test/irmin-pack/test_pack_version_bump.mli b/test/irmin-pack/test_pack_version_bump.mli index d38ba9a90a..52fe5cb0fe 100644 --- a/test/irmin-pack/test_pack_version_bump.mli +++ b/test/irmin-pack/test_pack_version_bump.mli @@ -1 +1,4 @@ -val tests : unit Alcotest.test_case list +val tests : + sr:Eio__Flow.source_ty Eio.Std.r -> + fs:Eio.Fs.dir_ty Eio.Path.t -> + unit Alcotest.test_case list diff --git a/test/irmin-pack/test_readonly.ml b/test/irmin-pack/test_readonly.ml index 5f6e24c9d2..99d583b25d 100644 --- a/test/irmin-pack/test_readonly.ml +++ b/test/irmin-pack/test_readonly.ml @@ -17,7 +17,7 @@ open! Import open Common -let root = Filename.concat "_build" "test-readonly" +let root ~fs = Eio.Path.(fs / "_build" / "test-readonly") let src = Logs.Src.create "tests.readonly" ~doc:"Tests read-only stores" module Log = (val Logs.src_log src : Logs.LOG) @@ -34,13 +34,15 @@ let config ?(readonly = false) ?(fresh = true) root = let info () = S.Info.empty -let open_ro_after_rw_closed () = +let open_ro_after_rw_closed ~fs () = + let root = root ~fs in rm_dir root; - let rw = S.Repo.v (config ~readonly:false ~fresh:true root) in + Eio.Switch.run @@ fun sw -> + let rw = S.Repo.v (config ~sw ~fs ~readonly:false ~fresh:true root) in let t = S.main rw in let tree = S.Tree.singleton [ "a" ] "x" in S.set_tree_exn ~parents:[] ~info t [] tree; - let ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + let ro = S.Repo.v (config ~sw ~fs ~readonly:true ~fresh:false root) in S.Repo.close rw; let t = S.main ro in let c = S.Head.get t in @@ -66,7 +68,7 @@ let check_binding ?msg repo commit key value = let x = S.Tree.find tree key in Alcotest.(check (option string)) msg (Some value) x -let ro_reload_after_add () = +let ro_reload_after_add ~fs () = let check ro c k v = match S.Commit.of_hash ro (S.Commit.hash c) with | None -> Alcotest.failf "commit not found" @@ -75,9 +77,11 @@ let ro_reload_after_add () = let x = S.Tree.find tree [ k ] in Alcotest.(check (option string)) "RO find" (Some v) x in + let root = root ~fs in rm_dir root; - let rw = S.Repo.v (config ~readonly:false ~fresh:true root) in - let ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + Eio.Switch.run @@ fun sw -> + let rw = S.Repo.v (config ~sw ~fs ~readonly:false ~fresh:true root) in + let ro = S.Repo.v (config ~sw ~fs ~readonly:true ~fresh:false root) in let tree = S.Tree.singleton [ "a" ] "x" in let c1 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in S.reload ro; @@ -95,11 +99,13 @@ let ro_reload_after_add () = S.Repo.close ro; S.Repo.close rw -let ro_reload_after_close () = +let ro_reload_after_close ~fs () = + let root = root ~fs in let binding f = f [ "a" ] "x" in rm_dir root; - let rw = S.Repo.v (config ~readonly:false ~fresh:true root) in - let ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + Eio.Switch.run @@ fun sw -> + let rw = S.Repo.v (config ~sw ~fs ~readonly:false ~fresh:true root) in + let ro = S.Repo.v (config ~sw ~fs ~readonly:true ~fresh:false root) in let tree = binding (S.Tree.singleton ?metadata:None) in let c1 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in S.Repo.close rw; @@ -107,20 +113,22 @@ let ro_reload_after_close () = binding (check_binding ro c1); 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 +let ro_batch ~fs () = + Eio.Switch.run @@ fun sw -> + let root = root ~fs in + let rw = S.Repo.v (config ~sw ~fs ~readonly:false ~fresh:true root) in + let ro = S.Repo.v (config ~sw ~fs ~readonly:true ~fresh:false root) in Alcotest.check_raises "Read-only store throws RO_not_allowed exception" Irmin_pack_unix.Errors.RO_not_allowed (fun () -> S.Backend.Repo.batch ro (fun _ _ _ -> ())); S.Repo.close ro; S.Repo.close rw -let tests = +let tests ~fs = let tc name test = Alcotest.test_case name `Quick 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; + tc "Test open ro after rw closed" (open_ro_after_rw_closed ~fs); + tc "Test ro reload after add" (ro_reload_after_add ~fs); + tc "Test ro reload after close" (ro_reload_after_close ~fs); + tc "Test ro batch" (ro_batch ~fs); ] diff --git a/test/irmin-pack/test_readonly.mli b/test/irmin-pack/test_readonly.mli index 2b40d2f891..9893a1a314 100644 --- a/test/irmin-pack/test_readonly.mli +++ b/test/irmin-pack/test_readonly.mli @@ -14,4 +14,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val tests : unit Alcotest.test_case list +val tests : fs:Eio.Fs.dir_ty Eio.Path.t -> unit Alcotest.test_case list diff --git a/test/irmin-pack/test_snapshot.ml b/test/irmin-pack/test_snapshot.ml index 9941339a63..ae77261e2d 100644 --- a/test/irmin-pack/test_snapshot.ml +++ b/test/irmin-pack/test_snapshot.ml @@ -17,8 +17,8 @@ open! Import open Common -let root_export = Filename.concat "_build" "test-snapshot-export" -let root_import = Filename.concat "_build" "test-snapshot-import" +let root_export ~fs = Eio.Path.(fs / "_build" / "test-snapshot-export") +let root_import ~fs = Eio.Path.(fs / "_build" / "test-snapshot-import") let src = Logs.Src.create "tests.snapshot" ~doc:"Tests" module Log = (val Logs.src_log src : Logs.LOG) @@ -76,7 +76,9 @@ let decode_with_size rbuf = decode_bin_snapshot b (ref 0) let restore repo ?on_disk buf = - let on_disk = (on_disk :> [ `Path of string | `Reuse ] option) in + let on_disk = + (on_disk :> [ `Path of Eio.Fs.dir_ty Eio.Path.t | `Reuse ] option) + in let snapshot = S.Snapshot.Import.v ?on_disk repo in let total = String.length buf in let total_visited = ref 0 in @@ -123,14 +125,19 @@ let tree2 () = let t = S.Tree.add t [ "c" ] "y" in S.Tree.add t [ "d" ] "y" -let test_in_memory ~indexing_strategy () = +let test_in_memory ~fs ~indexing_strategy () = + let root_export = root_export ~fs in + let root_import = root_import ~fs in rm_dir root_export; rm_dir root_import; + Eio.Switch.run @@ fun sw -> let repo_export = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_export) in let repo_import = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_import) in let test = test ~repo_export ~repo_import in let tree1 = S.Tree.singleton [ "a" ] "x" in @@ -146,15 +153,20 @@ let test_in_memory_minimal = let test_in_memory_always = test_in_memory ~indexing_strategy:Irmin_pack.Indexing_strategy.always -let test_on_disk ~indexing_strategy () = +let test_on_disk ~fs ~indexing_strategy () = + let root_export = root_export ~fs in + let root_import = root_import ~fs in rm_dir root_export; rm_dir root_import; - let index_on_disk = Filename.concat root_import "index_on_disk" in + let index_on_disk = Eio.Path.(root_import / "index_on_disk") in + Eio.Switch.run @@ fun sw -> let repo_export = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_export) in let repo_import = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_import) in let test = test ~repo_export ~repo_import in let tree2 = tree2 () in @@ -168,9 +180,9 @@ let test_on_disk_minimal = let test_on_disk_always = test_on_disk ~indexing_strategy:Irmin_pack.Indexing_strategy.always -let start_gc repo commit = +let start_gc ~fs ~domain_mgr repo commit = let commit_key = S.Commit.key commit in - let launched = S.Gc.start_exn ~unlink:false repo commit_key in + let launched = S.Gc.start_exn ~fs ~domain_mgr ~unlink:false repo commit_key in assert launched let finalise_gc repo = @@ -179,7 +191,8 @@ let finalise_gc repo = | `Idle | `Running -> Alcotest.fail "expected finalised gc" | `Finalised _ -> () -let test_gc ~repo_export ~repo_import ?on_disk expected_visited = +let test_gc ~fs ~domain_mgr ~repo_export ~repo_import ?on_disk expected_visited + = (* create the store *) let tree1 = let t = S.Tree.singleton [ "b"; "a" ] "x0" in @@ -195,7 +208,7 @@ let test_gc ~repo_export ~repo_import ?on_disk expected_visited = in let c3 = S.Commit.v repo_export ~parents:[ k1 ] ~info tree3 in (* call gc on last commit *) - let () = start_gc repo_export c3 in + let () = start_gc ~fs ~domain_mgr repo_export c3 in let () = finalise_gc repo_export in let tree = S.Commit.tree c3 in let root_key = S.Tree.key tree |> Option.get in @@ -217,39 +230,56 @@ let test_gc ~repo_export ~repo_import ?on_disk expected_visited = let indexing_strategy = Irmin_pack.Indexing_strategy.minimal -let test_gced_store_in_memory () = +let test_gced_store_in_memory ~fs ~domain_mgr () = + let root_export = root_export ~fs in + let root_import = root_import ~fs in rm_dir root_export; rm_dir root_import; + Eio.Switch.run @@ fun sw -> let repo_export = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_export) in let repo_import = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_import) in - let () = test_gc ~repo_export ~repo_import 5 in + let () = test_gc ~fs ~domain_mgr ~repo_export ~repo_import 5 in let () = S.Repo.close repo_export in S.Repo.close repo_import -let test_gced_store_on_disk () = +let test_gced_store_on_disk ~fs ~domain_mgr () = + let root_export = root_export ~fs in + let root_import = root_import ~fs in rm_dir root_export; rm_dir root_import; - let index_on_disk = Filename.concat root_import "index_on_disk" in + let index_on_disk = Eio.Path.(root_import / "index_on_disk") in + Eio.Switch.run @@ fun sw -> let repo_export = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_export) in let repo_import = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_import) + in + let () = + test_gc ~fs ~domain_mgr ~repo_export ~repo_import + ~on_disk:(`Path index_on_disk) 5 in - let () = test_gc ~repo_export ~repo_import ~on_disk:(`Path index_on_disk) 5 in let () = S.Repo.close repo_export in S.Repo.close repo_import -let test_export_import_reexport () = +let test_export_import_reexport ~fs ~domain_mgr () = + let root_export = root_export ~fs in + let root_import = root_import ~fs in rm_dir root_export; rm_dir root_import; + Eio.Switch.run @@ fun sw -> (* export a snapshot. *) let repo_export = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_export) in let tree = S.Tree.singleton [ "a" ] "y" in let parent_commit = S.Commit.v repo_export ~parents:[] ~info tree in @@ -266,7 +296,8 @@ let test_export_import_reexport () = a new store, with the key parent of type Indexed. *) rm_dir root_export; let repo_import = - S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) + S.Repo.v + (config ~sw ~fs ~readonly:false ~fresh:true ~indexing_strategy root_import) in let _, key = Buffer.contents buf |> restore repo_import in let key = Option.get key in @@ -276,12 +307,15 @@ let test_export_import_reexport () = let commit_key = S.Commit.key commit in let commit_hash = S.Commit.hash commit in (* export the gc-based snapshot in a clean root_export. *) - let () = S.create_one_commit_store repo_import commit_key root_export in + let () = + S.create_one_commit_store ~fs ~domain_mgr repo_import commit_key root_export + in let () = S.Repo.close repo_import in (* open the new store and check that everything is readable. *) let repo_export = S.Repo.v - (config ~readonly:false ~fresh:false ~indexing_strategy root_export) + (config ~sw ~fs ~readonly:false ~fresh:false ~indexing_strategy + root_export) in let commit = S.Commit.of_hash repo_export commit_hash in let commit = Option.get commit in @@ -290,15 +324,15 @@ let test_export_import_reexport () = Alcotest.(check (option string)) "find blob" (Some "x") got; S.Repo.close repo_export -let tests = +let tests ~fs ~domain_mgr = let tc name f = Alcotest.test_case name `Quick f in [ - tc "in memory minimal" test_in_memory_minimal; - tc "in memory always" test_in_memory_always; - tc "on disk minimal" test_on_disk_minimal; - tc "on disk always" test_on_disk_always; - tc "gced store, in memory" test_gced_store_in_memory; - tc "gced store, on disk" test_gced_store_on_disk; + tc "in memory minimal" (test_in_memory_minimal ~fs); + tc "in memory always" (test_in_memory_always ~fs); + tc "on disk minimal" (test_on_disk_minimal ~fs); + tc "on disk always" (test_on_disk_always ~fs); + tc "gced store, in memory" (test_gced_store_in_memory ~fs ~domain_mgr); + tc "gced store, on disk" (test_gced_store_on_disk ~fs ~domain_mgr); tc "import old snapshot, export gc based snapshot" - test_export_import_reexport; + (test_export_import_reexport ~fs ~domain_mgr); ] diff --git a/test/irmin-pack/test_tree.ml b/test/irmin-pack/test_tree.ml index 1db4f9838d..57c4535707 100644 --- a/test/irmin-pack/test_tree.ml +++ b/test/irmin-pack/test_tree.ml @@ -17,7 +17,7 @@ open! Import open Common -let root = Filename.concat "_build" "test-tree" +let root ~fs = Eio.Path.(fs / "_build" / "test-tree") let src = Logs.Src.create "tests.tree" ~doc:"Tests" module Log = (val Logs.src_log src : Logs.LOG) @@ -45,8 +45,8 @@ module Make (Conf : Irmin_pack.Conf.S) = struct type context = { repo : Store.repo; tree : Store.tree } - let export_tree_to_store tree = - let repo = Store.Repo.v (config ~fresh:true root) in + let export_tree_to_store ~sw ~fs tree = + let repo = Store.Repo.v (config ~sw ~fs ~fresh:true (root ~fs)) in let store = Store.empty repo in let () = Store.set_tree_exn ~info store [] tree in let tree = Store.tree store in @@ -66,12 +66,12 @@ module Make (Conf : Irmin_pack.Conf.S) = struct let h = Irmin.Type.to_string Store.Hash.t h in ([ h ], zero)) - let init_tree bindings = + let init_tree ~sw ~fs bindings = let tree = Tree.empty () in let tree = List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree bindings in - export_tree_to_store tree + export_tree_to_store ~sw ~fs tree let find_tree tree k = let t = Tree.find_tree tree k in @@ -109,8 +109,9 @@ module Make (Conf : Irmin_pack.Conf.S) = struct let t, () = Store.Tree.produce_proof repo hash (run ops) in t - let bin_of_proof = Irmin.Type.(unstage (to_bin_string Tree.Proof.t)) - let proof_of_bin = Irmin.Type.(unstage (of_bin_string Tree.Proof.t)) + let tree_proof_t = Tree.Proof.t + let bin_of_proof = Irmin.Type.(unstage (to_bin_string tree_proof_t)) + let proof_of_bin = Irmin.Type.(unstage (of_bin_string tree_proof_t)) end module Default = Make (Conf) @@ -178,8 +179,9 @@ let another_random_steps = let zero = String.make 10 '0' let bindings steps = List.map (fun x -> ([ x ], zero)) steps -let test_fold ?export_tree_to_store:(export_tree_to_store' = true) ~order +let test_fold ~fs ?export_tree_to_store:(export_tree_to_store' = true) ~order bindings expected = + Eio.Switch.run @@ fun sw -> let tree = Tree.empty () in let tree = List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree bindings @@ -187,7 +189,7 @@ let test_fold ?export_tree_to_store:(export_tree_to_store' = true) ~order let close = match export_tree_to_store' with | true -> - let ctxt = export_tree_to_store tree in + let ctxt = export_tree_to_store ~sw ~fs tree in fun () -> close ctxt | false -> fun () -> () in @@ -208,32 +210,32 @@ let test_fold ?export_tree_to_store:(export_tree_to_store' = true) ~order equal_lists ~msg:(Fmt.str "Visit elements in %s order" msg) expected keys; close () -let test_fold_sorted () = +let test_fold_sorted ~fs () = let bindings = bindings steps in let expected = List.map fst bindings in - test_fold ~order:`Sorted bindings expected + test_fold ~fs ~order:`Sorted bindings expected -let test_fold_random () = +let test_fold_random ~fs () = let bindings = bindings some_steps in let state = Random.State.make [| 0 |] in - let () = test_fold ~order:(`Random state) bindings some_random_steps in + let () = test_fold ~fs ~order:(`Random state) bindings some_random_steps in let state = Random.State.make [| 1 |] in - let () = test_fold ~order:(`Random state) bindings another_random_steps in + let () = test_fold ~fs ~order:(`Random state) bindings another_random_steps in (* Random fold order should still be respected if [~force:`False]. This is a regression test for a bug in which the fold order of in-memory nodes during a non-forcing traversal was always sorted. *) let state = Random.State.make [| 1 |] in let () = - test_fold ~order:(`Random state) ~export_tree_to_store:false bindings + test_fold ~fs ~order:(`Random state) ~export_tree_to_store:false bindings another_random_steps in () -let test_fold_undefined () = +let test_fold_undefined ~fs () = let bindings = bindings steps in let expected = List.map fst bindings in - test_fold ~order:`Undefined bindings expected + test_fold ~fs ~order:`Undefined bindings expected let proof_of_bin s = match proof_of_bin s with Ok s -> s | Error (`Msg e) -> Alcotest.fail e @@ -292,7 +294,7 @@ let test_proofs ctxt ops = (* test encoding *) let enc = bin_of_proof proof in let dec = proof_of_bin enc in - Alcotest.(check_repr Tree.Proof.t) "same proof" proof dec; + Alcotest.(check_repr tree_proof_t) "same proof" proof dec; (* test equivalence *) let tree_proof = Tree.Proof.to_tree proof in @@ -319,9 +321,10 @@ let test_proofs ctxt ops = in () -let test_large_inode () = +let test_large_inode ~fs () = + Eio.Switch.run @@ fun sw -> let bindings = bindings steps in - let ctxt = init_tree bindings in + let ctxt = init_tree ~sw ~fs bindings in let ops = [ Add ([ "00" ], "3"); Del [ "01" ] ] in test_proofs ctxt ops @@ -331,16 +334,18 @@ let fewer_steps = "1a"; "1b"; "1c"; "1d"; "1e"; "1f"; "20"; "22"; "23"; "25"; "26"; "27"; "28"; "2a"; ][@@ocamlformat "disable"] -let test_small_inode () = +let test_small_inode ~fs () = + Eio.Switch.run @@ fun sw -> let bindings = bindings fewer_steps in - let ctxt = init_tree bindings in + let ctxt = init_tree ~sw ~fs bindings in let ops = [ Add ([ "00" ], ""); Del [ "01" ] ] in test_proofs ctxt ops -let test_length_proof () = +let test_length_proof ~fs () = + Eio.Switch.run @@ fun sw -> let bindings = bindings fewer_steps in let size = List.length fewer_steps in - let ctxt = init_tree bindings in + let ctxt = init_tree ~sw ~fs bindings in let ops = [ Length ([], size) (* initial size *); @@ -371,7 +376,8 @@ let test_length_proof () = in test_proofs ctxt ops -let test_deeper_proof () = +let test_deeper_proof ~fs () = + Eio.Switch.run @@ fun sw -> let ctxt = let tree = Tree.empty () in let level_one = @@ -388,7 +394,7 @@ let test_deeper_proof () = let bindings = bindings fewer_steps in List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree bindings in - export_tree_to_store level_three + export_tree_to_store ~sw ~fs level_three in let ops = [ @@ -409,7 +415,7 @@ module Binary = Make (struct end) (* test large compressed proofs *) -let test_large_proofs () = +let test_large_proofs ~fs () = (* Build a proof on a large store (branching factor = 32) *) let bindings = init_bindings 100_000 in let ops n = @@ -421,8 +427,9 @@ let test_large_proofs () = in let compare_proofs n = + Eio.Switch.run @@ fun sw -> let ops = ops n in - let ctxt = init_tree bindings in + let ctxt = init_tree ~sw ~fs bindings in let key = match Tree.key ctxt.tree with Some (`Node k) -> k | _ -> assert false in @@ -431,7 +438,7 @@ let test_large_proofs () = let () = close ctxt in (* Build a proof on a large store (branching factor = 2) *) - let ctxt = Binary.init_tree bindings in + let ctxt = Binary.init_tree ~sw ~fs bindings in let key = match Binary.Store.Tree.key ctxt.tree with | Some (`Node k) -> k @@ -482,7 +489,7 @@ let check_contents_hash h s = let s' = Irmin.Type.(to_string Hash.t) h in Alcotest.(check string) "check hash" s s' -let test_extenders () = +let test_extenders ~fs () = let bindings = [ ([ "00000" ], "x"); ([ "00001" ], "y"); ([ "00010" ], "z") ] in @@ -496,7 +503,8 @@ let test_extenders () = in let check_proof bindings = - let ctxt = Custom.init_tree bindings in + Eio.Switch.run @@ fun sw -> + let ctxt = Custom.init_tree ~sw ~fs bindings in let key = Custom.Tree.key ctxt.tree |> Option.get in let p, () = Custom.Tree.produce_proof ctxt.repo key f in [%log.debug "Verifying proof %a" pp_proof p]; @@ -510,7 +518,7 @@ let test_extenders () = in List.iter check_proof [ bindings; bindings2; bindings3 ] -let test_hardcoded_proof () = +let test_hardcoded_proof ~fs () = let bindings = [ ([ "00000" ], "x"); ([ "00001" ], "y"); ([ "00010" ], "z") ] in @@ -522,7 +530,8 @@ let test_hardcoded_proof () = (Irmin.Type.pp P.inode_tree_t) elt in - let ctxt = Custom.init_tree bindings in + Eio.Switch.run @@ fun sw -> + let ctxt = Custom.init_tree ~sw ~fs bindings in let key = Custom.Tree.key ctxt.tree |> Option.get in let f t = let v = Custom.Tree.get t [ "00000" ] in @@ -558,15 +567,17 @@ let tree_of_list ls = let tree = Tree.empty () in List.fold_left (fun tree (k, v) -> Tree.add tree k v) tree ls -let test_reexport_node () = +let test_reexport_node ~fs () = + Eio.Switch.run @@ fun sw -> let tree = Store.Tree.add (Store.Tree.empty ()) [ "foo"; "a" ] "a" in - let repo1 = Store.Repo.v (config ~fresh:true root) in + let root = root ~fs in + let repo1 = Store.Repo.v (config ~sw ~fs ~fresh:true root) in let _ = Store.Backend.Repo.batch repo1 (fun c n _ -> Store.save_tree repo1 c n tree) in let () = Store.Repo.close repo1 in (* Re-export the same tree using a different repo. *) - let repo2 = Store.Repo.v (config ~fresh:false root) in + let repo2 = Store.Repo.v (config ~sw ~fs ~fresh:false root) in let _ = Alcotest.check_raises "re-export tree from another repo" (Failure "Can't export the node key from another repo") (fun () -> @@ -575,7 +586,7 @@ let test_reexport_node () = in let () = Store.Repo.close repo2 in (* Re-export a fresh tree using a different repo. *) - let repo2 = Store.Repo.v (config ~fresh:false root) in + let repo2 = Store.Repo.v (config ~sw ~fs ~fresh:false root) in let tree = Store.Tree.add (Store.Tree.empty ()) [ "foo"; "a" ] "a" in let _ = Store.Tree.hash tree in let c1 = Store.Tree.get_tree tree [ "foo" ] in @@ -591,20 +602,24 @@ let test_reexport_node () = in Store.Repo.close repo2 -let tests = +let tests ~fs = [ - Alcotest.test_case "fold over keys in sorted order" `Quick test_fold_sorted; - Alcotest.test_case "fold over keys in random order" `Quick test_fold_random; + Alcotest.test_case "fold over keys in sorted order" `Quick + (test_fold_sorted ~fs); + Alcotest.test_case "fold over keys in random order" `Quick + (test_fold_random ~fs); Alcotest.test_case "fold over keys in undefined order" `Quick - test_fold_undefined; + (test_fold_undefined ~fs); Alcotest.test_case "test Merkle proof for large inodes" `Quick - test_large_inode; + (test_large_inode ~fs); Alcotest.test_case "test Merkle proof for small inodes" `Quick - test_small_inode; + (test_small_inode ~fs); Alcotest.test_case "test Merkle proof for Tree.length" `Quick - test_length_proof; - Alcotest.test_case "test deeper Merkle proof" `Quick test_deeper_proof; - Alcotest.test_case "test large Merkle proof" `Slow test_large_proofs; - Alcotest.test_case "test hardcoded proof" `Quick test_hardcoded_proof; - Alcotest.test_case "test reexport node" `Quick test_reexport_node; + (test_length_proof ~fs); + Alcotest.test_case "test deeper Merkle proof" `Quick (test_deeper_proof ~fs); + Alcotest.test_case "test large Merkle proof" `Slow (test_large_proofs ~fs); + Alcotest.test_case "test extenders in stream proof" `Quick + (test_extenders ~fs); + Alcotest.test_case "test hardcoded proof" `Quick (test_hardcoded_proof ~fs); + Alcotest.test_case "test reexport node" `Quick (test_reexport_node ~fs); ] diff --git a/test/irmin-pack/test_upgrade.ml b/test/irmin-pack/test_upgrade.ml index c6b049b196..2cc446f516 100644 --- a/test/irmin-pack/test_upgrade.ml +++ b/test/irmin-pack/test_upgrade.ml @@ -17,16 +17,22 @@ open! Import open Common -let ( / ) = Filename.concat -let archive_v2_minimal = "test" / "irmin-pack" / "data" / "version_2_minimal" -let archive_v2_always = "test" / "irmin-pack" / "data" / "version_2_always" -let archive_v3_minimal = "test" / "irmin-pack" / "data" / "version_3_minimal" -let archive_v3_always = "test" / "irmin-pack" / "data" / "version_3_always" +let archive_v2_minimal ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_2_minimal") -let archive_v3_minimal_gced = - "test" / "irmin-pack" / "data" / "version_3_minimal_gced" +let archive_v2_always ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_2_always") -let root_local_build = "_build" / "test-upgrade" +let archive_v3_minimal ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_3_minimal") + +let archive_v3_always ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_3_always") + +let archive_v3_minimal_gced ~fs = + Eio.Path.(fs / "test" / "irmin-pack" / "data" / "version_3_minimal_gced") + +let root_local_build ~fs = Eio.Path.(fs / "_build" / "test-upgrade") type pack_entry = { h : Schema.Hash.t; @@ -239,15 +245,15 @@ module Store = struct let lru_size = setup.lru_size in Irmin_pack.config ~readonly ~indexing_strategy ~lru_size ~fresh root - let v setup ~readonly ~fresh root = - S.Repo.v (config setup ~readonly ~fresh root) + let v ~sw ~fs setup ~readonly ~fresh root = + S.Repo.v (config ~sw ~fs setup ~readonly ~fresh root) let close = S.Repo.close let reload = S.reload - let gc repo = + let gc ~fs ~domain_mgr repo = let k = key_of_entry c1 in - let launched = S.Gc.start_exn ~unlink:true repo k in + let launched = S.Gc.start_exn ~fs ~domain_mgr ~unlink:true repo k in assert launched; let result = S.Gc.finalise_exn ~wait:true repo in match result with @@ -452,26 +458,27 @@ let check t = check_suffix repo model) (Option.to_list t.ro @ Option.to_list t.rw) -let create_test_env setup = +let create_test_env ~fs setup = + let root_local_build = root_local_build ~fs in rm_dir root_local_build; let () = match setup.start_mode with | From_scratch -> () | From_v2 -> let root_archive = - if setup.indexing_strategy = `always then archive_v2_always - else archive_v2_minimal + if setup.indexing_strategy = `always then archive_v2_always ~fs + else archive_v2_minimal ~fs in setup_test_env ~root_archive ~root_local_build | From_v3 -> let root_archive = - if setup.indexing_strategy = `always then archive_v3_always - else archive_v3_minimal + if setup.indexing_strategy = `always then archive_v3_always ~fs + else archive_v3_minimal ~fs in setup_test_env ~root_archive ~root_local_build | From_v3_c0_gced -> let root_archive = - if setup.indexing_strategy = `minimal then archive_v3_minimal_gced + if setup.indexing_strategy = `minimal then archive_v3_minimal_gced ~fs else assert false in setup_test_env ~root_archive ~root_local_build @@ -480,7 +487,7 @@ let create_test_env setup = { setup; rw = None; ro = None } (** One of the 4 rw mutations *) -let start_rw t = +let start_rw ~sw ~fs t = [%logs.app "*** start_rw %a" pp_setup t.setup]; let rw = match t.rw with @@ -496,7 +503,8 @@ let start_rw t = | From_scratch -> Model.v t.setup in let repo = - Store.v t.setup ~readonly:false ~fresh:false root_local_build + Store.v ~sw ~fs t.setup ~readonly:false ~fresh:false + (root_local_build ~fs) in (model, repo) in @@ -522,7 +530,7 @@ let write1_rw t = () (** One of the 4 rw mutations *) -let gc_rw t = +let gc_rw ~fs ~domain_mgr t = [%logs.app "*** gc_rw %a" pp_setup t.setup]; match t.rw with | None -> assert false @@ -535,10 +543,11 @@ let gc_rw t = Alcotest.check_raises "GC on V2/always" (Irmin_pack_unix.Errors.Pack_error (`Gc_disallowed "Store does not support GC")) - (fun () -> Store.gc repo) + (fun () -> Store.gc ~fs ~domain_mgr repo) in raise Skip_the_rest_of_that_test - | (From_v3 | From_scratch | From_v3_c0_gced), `minimal -> Store.gc repo + | (From_v3 | From_scratch | From_v3_c0_gced), `minimal -> + Store.gc ~fs ~domain_mgr repo in () @@ -553,7 +562,7 @@ let write2_rw t = () (** One of the 2 ro mutations *) -let open_ro t current_phase = +let open_ro ~sw ~fs t current_phase = [%logs.app "*** open_ro %a, %a" pp_setup t.setup pp_phase current_phase]; let ro = match t.ro with @@ -581,7 +590,8 @@ let open_ro t current_phase = Alcotest.check_raises "open empty/V2 store in RO" (Irmin_pack_unix.Errors.Pack_error error) (fun () -> let repo = - Store.v t.setup ~readonly:true ~fresh:false root_local_build + Store.v ~sw ~fs t.setup ~readonly:true ~fresh:false + (root_local_build ~fs) in Store.close repo) in @@ -591,12 +601,14 @@ let open_ro t current_phase = match (t.setup.start_mode, current_phase) with | From_scratch, S1_before_start -> let missing_path = - Irmin_pack.Layout.V1_and_v2.pack ~root:root_local_build + Irmin_pack.Layout.V1_and_v2.pack ~root:(root_local_build ~fs) in - fail_and_skip (`No_such_file_or_directory missing_path) + fail_and_skip + (`No_such_file_or_directory (Eio.Path.native_exn missing_path)) | From_v2, S1_before_start -> fail_and_skip `Migration_needed | (From_v2 | From_v3 | From_v3_c0_gced | From_scratch), _ -> - Store.v t.setup ~readonly:true ~fresh:false root_local_build + Store.v ~sw ~fs t.setup ~readonly:true ~fresh:false + (root_local_build ~fs) in (model, repo) in @@ -623,29 +635,30 @@ let close_everything t = (fun (_, repo) -> Store.close repo) (Option.to_list t.ro @ Option.to_list t.rw) -let test_one t ~ro_open_at ~ro_sync_at = +let test_one ~domain_mgr ~fs t ~ro_open_at ~ro_sync_at = + Eio.Switch.run @@ fun sw -> let aux phase = let () = check t in - let () = if ro_open_at = phase then open_ro t phase else () in + let () = if ro_open_at = phase then open_ro ~sw ~fs t phase else () in let () = check t in if ro_sync_at = phase then sync_ro t phase; check t in let () = aux S1_before_start in - let () = start_rw t in + let () = start_rw ~sw ~fs t in let () = aux S2_before_write in let () = write1_rw t in let () = aux S3_before_gc in - let () = gc_rw t in + let () = gc_rw ~domain_mgr ~fs t in let () = aux S4_before_write in let () = write2_rw t in aux S5_before_close -let test_one_guarded setup ~ro_open_at ~ro_sync_at = - let t = create_test_env setup in +let test_one_guarded ~domain_mgr ~fs setup ~ro_open_at ~ro_sync_at = + let t = create_test_env ~fs setup in try - let () = test_one t ~ro_open_at ~ro_sync_at in + let () = test_one ~domain_mgr ~fs t ~ro_open_at ~ro_sync_at in close_everything t with | Skip_the_rest_of_that_test -> @@ -655,9 +668,9 @@ let test_one_guarded setup ~ro_open_at ~ro_sync_at = (** All possible interleaving of the ro calls (open and sync) with the rw calls (open, write1, gc and write2). *) -let test start_mode indexing_strategy lru_size = +let test ~domain_mgr ~fs start_mode indexing_strategy lru_size = let setup = { start_mode; indexing_strategy; lru_size } in - let t = test_one_guarded setup in + let t = test_one_guarded ~domain_mgr ~fs setup in let () = t ~ro_open_at:S1_before_start ~ro_sync_at:S1_before_start in let () = t ~ro_open_at:S1_before_start ~ro_sync_at:S2_before_write in @@ -681,22 +694,24 @@ let test start_mode indexing_strategy lru_size = () (** Product on lru_size *) -let test start_mode indexing_strategy = - test start_mode indexing_strategy 0; - test start_mode indexing_strategy 100 +let test ~domain_mgr ~fs start_mode indexing_strategy = + test ~domain_mgr ~fs start_mode indexing_strategy 0; + test ~domain_mgr ~fs start_mode indexing_strategy 100 -let test_gced_store () = test From_v3_c0_gced `minimal +let test_gced_store ~domain_mgr () = test ~domain_mgr From_v3_c0_gced `minimal (** Product on indexing_strategy *) -let test start_mode () = - test start_mode `minimal; - test start_mode `always +let test ~fs ~domain_mgr start_mode () = + test ~fs ~domain_mgr start_mode `minimal; + test ~fs ~domain_mgr start_mode `always (** Product on start_mode *) -let tests = +let tests ~fs ~domain_mgr = [ - Alcotest.test_case "upgrade From_v3" `Quick (test From_v3); - Alcotest.test_case "upgrade From_v2" `Quick (test From_v2); - Alcotest.test_case "upgrade From_scratch" `Quick (test From_scratch); - Alcotest.test_case "upgrade From_v3 after Gc" `Quick test_gced_store; + Alcotest.test_case "upgrade From_v3" `Quick (test ~fs ~domain_mgr From_v3); + Alcotest.test_case "upgrade From_v2" `Quick (test ~fs ~domain_mgr From_v2); + Alcotest.test_case "upgrade From_scratch" `Quick + (test ~fs ~domain_mgr From_scratch); + Alcotest.test_case "upgrade From_v3 after Gc" `Quick + (test_gced_store ~fs ~domain_mgr); ] diff --git a/test/irmin-tezos/generate.ml b/test/irmin-tezos/generate.ml index 151b0d8f4c..ab620ede09 100644 --- a/test/irmin-tezos/generate.ml +++ b/test/irmin-tezos/generate.ml @@ -40,11 +40,13 @@ module Generator = struct let info = Store.Info.empty - let create_store ?(before_closing = fun _repo _head -> ()) indexing_strategy - path = + let create_store ~sw ~fs ?(before_closing = fun _repo _head -> ()) + indexing_strategy path = rm_dir path; let large_contents = String.make 4096 'Z' in - let rw = Store.Repo.v (config ~indexing_strategy path) in + let rw = + Store.Repo.v (config ~sw ~fs ~indexing_strategy Eio.Path.(fs / path)) + in let tree = Store.Tree.singleton [ "a"; "b1"; "c1"; "d1"; "e1" ] "x1" in let tree = Store.Tree.add tree [ "a"; "b1"; "c1"; "d2"; "e2" ] "x2" in let tree = Store.Tree.add tree [ "a"; "b1"; "c1"; "d3"; "e3" ] "x2" in @@ -63,38 +65,48 @@ module Generator = struct c3 - let create_gced_store path = + let create_gced_store ~sw ~fs ~domain_mgr path = let before_closing repo head = - let _ = Store.Gc.start_exn repo head in + let _ = Store.Gc.start_exn ~fs ~domain_mgr repo head in let _ = Store.Gc.wait repo in () in - create_store ~before_closing Irmin_pack.Indexing_strategy.minimal path + create_store ~sw ~fs ~before_closing Irmin_pack.Indexing_strategy.minimal + path - let create_snapshot_store ~src ~dest = + let create_snapshot_store ~sw ~fs ~domain_mgr ~src ~dest = let before_closing repo head = rm_dir dest; - Store.create_one_commit_store repo head dest + Store.create_one_commit_store ~fs ~domain_mgr repo head + Eio.Path.(fs / dest) in - create_store ~before_closing Irmin_pack.Indexing_strategy.minimal src + create_store ~sw ~fs ~before_closing Irmin_pack.Indexing_strategy.minimal + src end let ensure_data_dir () = if not (Sys.file_exists "data") then Unix.mkdir "data" 0o755 -let generate () = +let generate ~sw ~fs ~domain_mgr = ensure_data_dir (); let _ = - Generator.create_store Irmin_pack.Indexing_strategy.minimal "data/minimal" + Generator.create_store ~sw ~fs Irmin_pack.Indexing_strategy.minimal + "data/minimal" in let _ = - Generator.create_store Irmin_pack.Indexing_strategy.always "data/always" + Generator.create_store ~sw ~fs Irmin_pack.Indexing_strategy.always + "data/always" in - let _ = Generator.create_gced_store "data/gced" in + let _ = Generator.create_gced_store ~sw ~fs ~domain_mgr "data/gced" in let _ = - Generator.create_snapshot_store ~src:"data/snapshot_src" + Generator.create_snapshot_store ~sw ~fs ~domain_mgr ~src:"data/snapshot_src" ~dest:"data/snapshot" in () -let () = Eio_main.run @@ fun _env -> generate () +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let fs = Eio.Stdenv.cwd env in + let domain_mgr = Eio.Stdenv.domain_mgr env in + generate ~sw ~fs ~domain_mgr diff --git a/test/irmin-tezos/irmin_fsck.ml b/test/irmin-tezos/irmin_fsck.ml index a3dd4841d9..33b2dc1da3 100644 --- a/test/irmin-tezos/irmin_fsck.ml +++ b/test/irmin-tezos/irmin_fsck.ml @@ -31,9 +31,10 @@ end module Store_tz = Irmin_pack_unix.Checks.Make (Maker_tz) let () = - Eio_main.run @@ fun _ -> + Eio_main.run @@ fun env -> + let fs = Eio.Stdenv.fs env in try let store_type = Sys.getenv "STORE" in - if store_type = "PACK" then match Store.cli () with _ -> . + if store_type = "PACK" then match Store.cli ~fs () with _ -> . else raise Not_found - with Not_found -> ( match Store_tz.cli () with _ -> .) + with Not_found -> ( match Store_tz.cli ~fs () with _ -> .)