irmin-fs: Eio backend

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. *)

src/irmin-cli/dune

@@ -19,6 +19,7 @@
   cohttp-lwt-unix
   unix
   yaml
+  eio
   eio_main
   lwt_eio)
  (preprocess

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 >

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.(

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. *)

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

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
        [