From cdd06d143f1b43c9b41688216e747cf750814e51 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Tue, 10 Jan 2023 19:51:03 +0000 Subject: [PATCH] Update to eio.0.7 and catch IO errors --- src/irmin-chunk/irmin_chunk.ml | 21 ++-- src/irmin-containers/linked_log.ml | 2 +- src/irmin-containers/linked_log.mli | 2 +- src/irmin-containers/lww_register.ml | 4 +- src/irmin-containers/lww_register.mli | 3 +- src/irmin-fs/irmin_fs.ml | 22 ++-- src/irmin-fs/irmin_fs.mli | 2 +- src/irmin-fs/unix/eio_pool.ml | 118 +++++++++++---------- src/irmin-fs/unix/irmin_fs_unix.ml | 135 +++++++++++++----------- src/irmin-pack/unix/async.ml | 2 +- src/irmin-pack/unix/ext.ml | 11 +- src/irmin-pack/unix/gc.ml | 4 +- src/irmin-pack/unix/gc.mli | 2 +- src/irmin-pack/unix/gc_args.ml | 2 +- src/irmin-pack/unix/pack_store.ml | 4 +- src/irmin-pack/unix/s.ml | 3 +- src/irmin-test/common.ml | 76 ++++++------- src/irmin-test/irmin_bench.ml | 2 +- src/irmin-test/store_watch.ml | 6 +- src/irmin/conf.ml | 5 +- src/irmin/conf.mli | 5 +- src/irmin/store.ml | 16 +-- src/irmin/tree.ml | 3 +- src/irmin/tree_intf.ml | 7 +- src/irmin/watch.ml | 4 +- test/irmin-chunk/test.ml | 4 +- test/irmin-containers/blob_log.ml | 14 +-- test/irmin-containers/common.mli | 3 +- test/irmin-containers/linked_log.ml | 14 +-- test/irmin-containers/lww_register.ml | 4 +- test/irmin-containers/test.ml | 8 +- test/irmin-fs/test.ml | 2 +- test/irmin-fs/test_unix.ml | 4 +- test/irmin-mem/test.ml | 2 +- test/irmin-pack/common.ml | 2 +- test/irmin-pack/common.mli | 8 +- test/irmin-pack/test.ml | 5 +- test/irmin-pack/test_corrupted.ml | 6 +- test/irmin-pack/test_existing_stores.ml | 12 ++- test/irmin-pack/test_gc.ml | 4 +- test/irmin-pack/test_gc.mli | 6 +- test/irmin-pack/test_inode.ml | 5 +- test/irmin-pack/test_mapping.ml | 6 +- test/irmin-pack/test_nearest_leq.ml | 3 +- test/irmin-pack/test_pack.ml | 19 ++-- test/irmin-pack/test_snapshot.ml | 4 +- test/irmin-pack/test_tree.ml | 12 ++- test/irmin-pack/test_upgrade.ml | 14 +-- test/irmin/generic-key/dune | 8 +- test/irmin/generic-key/test.ml | 4 +- 50 files changed, 319 insertions(+), 315 deletions(-) diff --git a/src/irmin-chunk/irmin_chunk.ml b/src/irmin-chunk/irmin_chunk.ml index 2e8fcbd5174..aab10195244 100644 --- a/src/irmin-chunk/irmin_chunk.ml +++ b/src/irmin-chunk/irmin_chunk.ml @@ -151,9 +151,7 @@ struct | Chunk.Index i -> List.fold_left (fun acc key -> - match CA.find t.db key with - | None -> acc - | Some v -> aux acc v) + match CA.find t.db key with None -> acc | Some v -> aux acc v) acc i in aux [] root |> List.rev @@ -178,7 +176,9 @@ struct else List.length l in match list_partition n l with - | [ i ] -> AO.add t.db key (index t i); key + | [ i ] -> + AO.add t.db key (index t i); + key | l -> Fiber.List.map (fun i -> CA.add t.db (index t i)) l |> aux) in aux l @@ -212,8 +212,8 @@ struct let k' = H.hash (pre_hash_value v) in if equal_key k k' then () else - Fmt.kstr failwith "corrupted value: got %a, expecting %a" - pp_key k' pp_key k + Fmt.kstr failwith "corrupted value: got %a, expecting %a" pp_key k' pp_key + k let find t key = match find_leaves t key with @@ -221,7 +221,9 @@ struct | Some bufs -> ( let buf = String.concat "" bufs in match value_of_bin_string buf with - | Ok va -> check_hash key va; Some va + | Ok va -> + check_hash key va; + Some va | Error _ -> None) let list_range ~init ~stop ~step = @@ -232,10 +234,9 @@ struct let unsafe_add_buffer t key buf = let len = String.length buf in - if len <= t.max_data then begin + if len <= t.max_data then ( AO.add t.db key (data t buf); - [%log.debug "add -> %a (no split)" pp_key key] - end + [%log.debug "add -> %a (no split)" pp_key key]) else let offs = list_range ~init:0 ~stop:len ~step:t.max_data in let aux off = diff --git a/src/irmin-containers/linked_log.ml b/src/irmin-containers/linked_log.ml index a5c2a77dc1b..1bcb7d31430 100644 --- a/src/irmin-containers/linked_log.ml +++ b/src/irmin-containers/linked_log.ml @@ -89,7 +89,7 @@ module type S = sig type cursor val get_cursor : path:Store.path -> Store.t -> cursor - val read : num_items:int -> cursor -> (value list * cursor) + val read : num_items:int -> cursor -> value list * cursor end module Make diff --git a/src/irmin-containers/linked_log.mli b/src/irmin-containers/linked_log.mli index 5b6005bd2f9..16f20d270f6 100644 --- a/src/irmin-containers/linked_log.mli +++ b/src/irmin-containers/linked_log.mli @@ -33,7 +33,7 @@ module type S = sig val get_cursor : path:Store.path -> Store.t -> cursor (** Create a new cursor over the log entires at the given path *) - val read : num_items:int -> cursor -> (value list * cursor) + val read : num_items:int -> cursor -> value list * cursor (** Read at most [num_items] entries from the cursor. If the number specified is greater than the number of log entries from the cursor, the log is read till the end. If the input cursor has already reached the end, then an diff --git a/src/irmin-containers/lww_register.ml b/src/irmin-containers/lww_register.ml index 6a7fb625bec..b8144fd9fef 100644 --- a/src/irmin-containers/lww_register.ml +++ b/src/irmin-containers/lww_register.ml @@ -41,9 +41,7 @@ module type S = sig type value val read : path:Store.path -> Store.t -> value option - - val write : - ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit + val write : ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit end module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) = struct diff --git a/src/irmin-containers/lww_register.mli b/src/irmin-containers/lww_register.mli index 3b748cecd55..472a66dd6e2 100644 --- a/src/irmin-containers/lww_register.mli +++ b/src/irmin-containers/lww_register.mli @@ -34,8 +34,7 @@ module type S = sig val read : path:Store.path -> Store.t -> value option (** Reads the value from the register. Returns [None] if no value is written *) - val write : - ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit + val write : ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit (** Writes the provided value to the register *) end diff --git a/src/irmin-fs/irmin_fs.ml b/src/irmin-fs/irmin_fs.ml index 44e6b8af7fb..4aceb32ca7c 100644 --- a/src/irmin-fs/irmin_fs.ml +++ b/src/irmin-fs/irmin_fs.ml @@ -307,11 +307,11 @@ module Obj = struct let file_of_key k = let pre = String.with_range k ~len:2 in let suf = String.with_range k ~first:2 in - let ( / ) = Filename.concat in + let ( / ) = Filename.concat in "objects" / pre / suf let key_of_file path = - let ( / ) = Filename.concat in + let ( / ) = Filename.concat in let path = string_chop_prefix ~prefix:("objects" / "") path in let path = String.cuts ~sep:Filename.dir_sep path in let path = String.concat ~sep:"" path in @@ -372,7 +372,8 @@ module IO_mem = struct let rec_files (_, dir) = Hashtbl.fold - (fun ((_, k) as v) _ acc -> if String.is_prefix ~affix:dir k then v :: acc else acc) + (fun ((_, k) as v) _ acc -> + if String.is_prefix ~affix:dir k then v :: acc else acc) t.files [] let file_exists file = Hashtbl.mem t.files file @@ -427,9 +428,12 @@ let run (fs : Fs.dir 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 - } \ No newline at end of file + 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 f990ebe9076..229f9db7e8e 100644 --- a/src/irmin-fs/irmin_fs.mli +++ b/src/irmin-fs/irmin_fs.mli @@ -109,4 +109,4 @@ module IO_mem : sig val set_listen_hook : unit -> unit end -val run : Eio.Fs.dir Eio.Path.t -> (unit -> 'a) -> 'a \ No newline at end of file +val run : Eio.Fs.dir Eio.Path.t -> (unit -> 'a) -> 'a diff --git a/src/irmin-fs/unix/eio_pool.ml b/src/irmin-fs/unix/eio_pool.ml index a74bbf7348b..e32c122638b 100644 --- a/src/irmin-fs/unix/eio_pool.ml +++ b/src/irmin-fs/unix/eio_pool.ml @@ -18,39 +18,45 @@ type 'a t = { list : 'a Queue.t; (* Available pool members. *) waiters : ('a, exn) result Promise.u Stream.t; - (* Promise resolvers waiting for a free member. *) + (* Promise resolvers waiting for a free member. *) } -let create m ?(validate = fun _ -> true) ?(check = fun _ f -> f true) ?(dispose = fun _ -> ()) create = - { max = m; - create = create; - validate = validate; - check = check; - dispose = dispose; +let create m ?(validate = fun _ -> true) ?(check = fun _ f -> f true) + ?(dispose = fun _ -> ()) create = + { + max = m; + create; + validate; + check; + dispose; cleared = ref (ref false); count = 0; list = Queue.create (); - waiters = Stream.create m } + waiters = Stream.create m; + } + (* Create a pool member. *) let create_member p = try - (* Must be done before p.create to prevent other resolvers from - creating new members if the limit is reached. *) - p.count <- p.count + 1; - p.create () + (* Must be done before p.create to prevent other resolvers from + creating new members if the limit is reached. *) + p.count <- p.count + 1; + p.create () with exn -> - (* Creation failed, so don't increment count. *) - p.count <- p.count - 1; - raise exn + (* Creation failed, so don't increment count. *) + p.count <- p.count - 1; + raise exn + (* Release a pool member. *) let release p c = match Stream.take_nonblocking p.waiters with | Some wakener -> - (* A promise resolver is waiting, give it the pool member. *) - Promise.resolve_ok wakener c + (* A promise resolver is waiting, give it the pool member. *) + Promise.resolve_ok wakener c | None -> - (* No one is waiting, queue it. *) - Queue.push c p.list + (* No one is waiting, queue it. *) + Queue.push c p.list + (* Dispose of a pool member. *) let dispose p c = p.dispose c; @@ -61,68 +67,68 @@ let dispose p c = let replace_disposed p = match Stream.take_nonblocking p.waiters with | None -> - (* No one is waiting, do not create a new member to avoid - losing an error if creation fails. *) - () - | Some wakener -> - match p.create () with - | c -> Promise.resolve_ok wakener c - | exception exn -> - (* Creation failed, notify the waiter of the failure. *) - Promise.resolve_error wakener exn + (* No one is waiting, do not create a new member to avoid + losing an error if creation fails. *) + () + | Some wakener -> ( + match p.create () with + | c -> Promise.resolve_ok wakener c + | exception exn -> + (* Creation failed, notify the waiter of the failure. *) + Promise.resolve_error wakener exn) + (* Verify a member is still valid before using it. *) let validate_and_return p c = match p.validate c with - | true -> c - | false -> - (* Remove this member and create a new one. *) - dispose p c; - create_member p - | exception e -> - (* Validation failed: create a new member if at least one - resolver is waiting. *) - dispose p c; - replace_disposed p; - raise e + | true -> c + | false -> + (* Remove this member and create a new one. *) + dispose p c; + create_member p + | exception e -> + (* Validation failed: create a new member if at least one + resolver is waiting. *) + dispose p c; + replace_disposed p; + raise e (* Acquire a pool member. *) let acquire p = - if Queue.is_empty p.list then - (* No more available member. *) - if p.count < p.max then + if Queue.is_empty p.list then ( + if (* No more available member. *) + p.count < p.max then (* Limit not reached: create a new one. *) create_member p else (* Limit reached: wait for a free one. *) - let promise, resolver = Promise.create () in + 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 *) + (* (Lwt.add_task_r [@ocaml.warning "-3"]) p.waiters >>= validate_and_return p *)) else (* Take the first free member and validate it. *) let c = Queue.take p.list in validate_and_return p c + (* Release a member when use resulted in failed promise if the member is still valid. *) let check_and_release p c cleared = let ok = ref false in p.check c (fun result -> ok := result); - if cleared || not !ok then ( + if cleared || not !ok then (* Element is not ok or the pool was cleared - dispose of it *) dispose p c - ) - else ( - (* Element is ok - release it back to the pool *) + else (* Element is ok - release it back to the pool *) release p c - ) + let use p f = let c = acquire p in (* Capture the current cleared state so we can see if it changes while this element is in use *) let cleared = !(p.cleared) in let promise () = - try f c with - | e -> + try f c + with e -> check_and_release p c !cleared; raise e in @@ -130,12 +136,11 @@ let use p f = if !cleared then ( (* p was cleared while promise was resolving - dispose of this element *) dispose p c; - r - ) + r) else ( release p c; - r - ) + r) + let clear p = let elements = Queue.fold (fun l element -> element :: l) [] p.list in Queue.clear p.list; @@ -144,4 +149,5 @@ let clear p = old_cleared := true; p.cleared := ref false; List.iter (dispose p) elements -let wait_queue_length p = Stream.length p.waiters \ No newline at end of file + +let wait_queue_length p = Stream.length p.waiters diff --git a/src/irmin-fs/unix/irmin_fs_unix.ml b/src/irmin-fs/unix/irmin_fs_unix.ml index 1da663cdf93..99d1309c097 100644 --- a/src/irmin-fs/unix/irmin_fs_unix.ml +++ b/src/irmin-fs/unix/irmin_fs_unix.ml @@ -51,43 +51,45 @@ module IO = struct let mkdir dirname = let rec aux ((_, path) as dir) = if Sys.file_exists path && Sys.is_directory path then () - else begin + 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 - end + protect (Path.mkdir ~perm:0o755) dir) in (* TODO: Pool *) Eio_pool.use mkdir_pool (fun () -> aux 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 + try Sys.file_exists f with + (* See https://github.com/ocsigen/lwt/issues/316 *) + | Unix.Unix_error (Unix.ENOTDIR, _, _) -> false + | e -> raise e module Lock = struct let is_stale 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 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 unlock file = Path.unlink file - let lock ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) ((_, file) as fcap) = + let lock ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) + ((_, file) as fcap) = let rec aux i = [%log.debug "lock %s %d" file i]; + Eio.traceln "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]; + Eio.traceln "%s is stale, removing it." file; unlock fcap; aux 1) else @@ -96,29 +98,29 @@ module IO = struct let parent = (fst fcap, Filename.dirname file) in mkdir parent; Switch.run @@ fun sw -> - let flow = - Path.open_out ~sw fcap - ~create:(`Exclusive 0o600) - in + let flow = Path.open_out ~sw fcap ~create:(`Exclusive 0o600) in Flow.copy_string (string_of_int pid) flow in try create () with - | Unix.Unix_error (Unix.EEXIST, _, _) -> - let backoff = - 1. - +. Random.float - (let i = float i in - i *. i) - in - Eio_unix.sleep (sleep *. backoff); aux (i + 1) - | e -> raise e + | Eio.Io (Fs.E (Fs.Already_exists _), _) -> + let backoff = + 1. + +. Random.float + (let i = float i in + i *. i) + in + Eio_unix.sleep (sleep *. backoff); + aux (i + 1) + | e -> raise e in aux 1 let with_lock file fn = match file with | None -> fn () - | Some f -> lock f; Fun.protect fn ~finally:(fun () -> unlock f) + | Some f -> + lock f; + Fun.protect fn ~finally:(fun () -> unlock f) end type path = Eio.Fs.dir Eio.Path.t @@ -133,13 +135,15 @@ module IO = struct 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 d = List.map (Path.( / ) v) 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 + list_files + (fun (_, f) -> try Sys.is_directory f with Sys_error _ -> false) + dir let files dir = list_files @@ -165,39 +169,47 @@ module IO = struct let remove_file ?lock ((_, file) as f) = Lock.with_lock lock (fun () -> + Eio.traceln "unlinking!"; 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, _, _) -> - remove_dir file - | Unix.Unix_error (Unix.ENOENT, _, _) | Fs.Not_found _ -> () - | e -> raise e) + (* 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 () = 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" in + let tmp_f = + Filename.temp_file ~temp_dir (Filename.basename file_f) "write" + in let tmp_name = Filename.basename tmp_f 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); + [%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) 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 perm = 0o0 in *) (* let* fd = Lwt_unix.openfile file flags perm in *) Path.with_open_in file @@ fun flow -> try @@ -208,29 +220,30 @@ module IO = struct let read_file_with_mmap file = let open Bigarray in let fd = Unix.(openfile file [ O_RDONLY; O_NONBLOCK ] 0o644) in - let ba = + let ba = Unix.map_file fd char c_layout false [| -1 |] |> Bigarray.array1_of_genarray in Unix.close fd; (* XXX(samoht): ideally we should not do a copy here. *) - (Bigstringaf.to_string ba) + Bigstringaf.to_string ba let read_file file = let file_f = snd file in try - 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 - Some buf) - with - | Unix.Unix_error _ | Sys_error _ -> None | e -> raise e + 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 + Some buf) + with + | Unix.Unix_error _ | Sys_error _ -> None + | e -> raise e let write_file ?temp_dir ?lock file b = let write () = @@ -238,8 +251,10 @@ module IO = struct in Lock.with_lock lock (fun () -> try write () with - | Unix.Unix_error (Unix.EISDIR, _, _) -> remove_dir (snd file); write () - | e -> raise e) + | 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 () -> diff --git a/src/irmin-pack/unix/async.ml b/src/irmin-pack/unix/async.ml index b40417378a6..09b8455917d 100644 --- a/src/irmin-pack/unix/async.ml +++ b/src/irmin-pack/unix/async.ml @@ -56,7 +56,7 @@ module Unix = struct match Unix.fork () with | 0 -> (* Lwt_main.Exit_hooks.remove_all (); - Lwt_main.abandon_yielded_and_paused (); *) + Lwt_main.abandon_yielded_and_paused (); *) (try f () with e -> [%log.err diff --git a/src/irmin-pack/unix/ext.ml b/src/irmin-pack/unix/ext.ml index 9811a2a14db..e1ac5f7cf11 100644 --- a/src/irmin-pack/unix/ext.ml +++ b/src/irmin-pack/unix/ext.ml @@ -15,7 +15,9 @@ *) open! Import -let (let*) = Result.bind + +let ( let* ) = Result.bind + module Maker (Config : Conf.S) = struct type endpoint = unit @@ -289,17 +291,14 @@ module Maker (Config : Conf.S) = struct start ~unlink ~use_auto_finalisation ~new_files_path t commit_key in - match result with - | Ok _ -> true - | Error e -> Errs.raise_error e) + match result with Ok _ -> true | Error e -> Errs.raise_error e) let finalise_exn ?(wait = false) t = let result = match t.running_gc with | None -> Ok `Idle | Some { gc; _ } -> - if t.during_batch then - Error `Gc_forbidden_during_batch + if t.during_batch then Error `Gc_forbidden_during_batch else Gc.finalise ~wait gc in match result with diff --git a/src/irmin-pack/unix/gc.ml b/src/irmin-pack/unix/gc.ml index 959ccc566f0..61e406e8bac 100644 --- a/src/irmin-pack/unix/gc.ml +++ b/src/irmin-pack/unix/gc.ml @@ -232,7 +232,7 @@ module Make (Args : Gc_args.S) = struct in let result = - let (let*) = Result.bind in + let ( let* ) = Result.bind in match (status, gc_output) with | ( `Success, Ok { suffix_params; removable_chunk_idxs; stats = worker_stats } @@ -285,7 +285,7 @@ module Make (Args : Gc_args.S) = struct let finalise_without_swap t = let status = Async.await t.task in match status with - | `Success -> t.latest_gc_target_offset, t.new_suffix_start_offset + | `Success -> (t.latest_gc_target_offset, t.new_suffix_start_offset) | _ -> let gc_output = read_gc_output ~root:t.root ~generation:t.generation in gc_errors status gc_output |> Errs.raise_if_error diff --git a/src/irmin-pack/unix/gc.mli b/src/irmin-pack/unix/gc.mli index 10cc58023f6..082ec3ef6c1 100644 --- a/src/irmin-pack/unix/gc.mli +++ b/src/irmin-pack/unix/gc.mli @@ -52,7 +52,7 @@ module Make (Args : Gc_args.S) : sig val cancel : t -> bool - val finalise_without_swap : t -> (int63 * int63) + val finalise_without_swap : t -> int63 * int63 (** Waits for the current gc to finish and returns immediately without swapping the files and doing the other finalisation steps from [finalise]. diff --git a/src/irmin-pack/unix/gc_args.ml b/src/irmin-pack/unix/gc_args.ml index bfd6508e895..4356a43f128 100644 --- a/src/irmin-pack/unix/gc_args.ml +++ b/src/irmin-pack/unix/gc_args.ml @@ -76,4 +76,4 @@ module type S = sig and type dict = Dict.t and type dispatcher = Dispatcher.t and type hash = hash -end \ No newline at end of file +end diff --git a/src/irmin-pack/unix/pack_store.ml b/src/irmin-pack/unix/pack_store.ml index e9db233812e..0f4375b48cf 100644 --- a/src/irmin-pack/unix/pack_store.ml +++ b/src/irmin-pack/unix/pack_store.ml @@ -403,9 +403,7 @@ struct in raise exn in - match f (cast t) with - | v -> on_success v - | exception exn -> on_fail exn + match f (cast t) with v -> on_success v | exception exn -> on_fail exn let unsafe_append ~ensure_unique ~overcommit t hash v = let kind = Val.kind v in diff --git a/src/irmin-pack/unix/s.ml b/src/irmin-pack/unix/s.ml index dff2315cde2..ce0899cd750 100644 --- a/src/irmin-pack/unix/s.ml +++ b/src/irmin-pack/unix/s.ml @@ -174,8 +174,7 @@ module type S = sig Irmin.config -> unit - val stats : - dump_blob_paths_to:string option -> commit:commit -> repo -> unit + val stats : dump_blob_paths_to:string option -> commit:commit -> repo -> unit module Snapshot : sig type kinded_hash = Contents of hash * metadata | Node of hash diff --git a/src/irmin-test/common.ml b/src/irmin-test/common.ml index 6465908d3da..62146306042 100644 --- a/src/irmin-test/common.ml +++ b/src/irmin-test/common.ml @@ -218,45 +218,45 @@ module Make_helpers (S : Generic_key) = struct let repo_ptr = ref None in let config_ptr = ref None in try - let module Conf = Irmin.Backend.Conf in - let generate_random_root config = - let id = Random.int 100 |> string_of_int in - let root_value = - match Conf.find_root config with - | None -> "test_" ^ id - | Some v -> v ^ "_" ^ id - in - let root_key = Conf.(root (spec config)) in - Conf.add config root_key root_value + let module Conf = Irmin.Backend.Conf in + let generate_random_root config = + let id = Random.int 100 |> string_of_int in + let root_value = + match Conf.find_root config with + | None -> "test_" ^ id + | Some v -> v ^ "_" ^ id in - let config = generate_random_root x.config in - config_ptr := Some config; - let () = x.init ~config in - let repo = S.Repo.v config in - repo_ptr := Some repo; - let () = test repo in - let () = - (* [test] might have already closed the repo. That - [ignore_thunk_errors] shall be removed as soon as all stores - support double closes. *) - ignore_thunk_errors (fun () -> S.Repo.close repo) - in - x.clean ~config - with exn -> - (* [test] failed, attempt an errorless cleanup and forward the right - backtrace to the user. *) - let bt = Printexc.get_raw_backtrace () in - let () = - match !repo_ptr with - | Some repo -> ignore_thunk_errors (fun () -> S.Repo.close repo) - | None -> () - in - let () = - match !config_ptr with - | Some config -> ignore_thunk_errors (fun () -> x.clean ~config) - | None ->() - in - Printexc.raise_with_backtrace exn bt + let root_key = Conf.(root (spec config)) in + Conf.add config root_key root_value + in + let config = generate_random_root x.config in + config_ptr := Some config; + let () = x.init ~config in + let repo = S.Repo.v config in + repo_ptr := Some repo; + let () = test repo in + let () = + (* [test] might have already closed the repo. That + [ignore_thunk_errors] shall be removed as soon as all stores + support double closes. *) + ignore_thunk_errors (fun () -> S.Repo.close repo) + in + x.clean ~config + with exn -> + (* [test] failed, attempt an errorless cleanup and forward the right + backtrace to the user. *) + let bt = Printexc.get_raw_backtrace () in + let () = + match !repo_ptr with + | Some repo -> ignore_thunk_errors (fun () -> S.Repo.close repo) + | None -> () + in + let () = + match !config_ptr with + | Some config -> ignore_thunk_errors (fun () -> x.clean ~config) + | None -> () + in + Printexc.raise_with_backtrace exn bt end let filter_src src = diff --git a/src/irmin-test/irmin_bench.ml b/src/irmin-test/irmin_bench.ml index bbd7494c978..55668da67d4 100644 --- a/src/irmin-test/irmin_bench.ml +++ b/src/irmin-test/irmin_bench.ml @@ -174,7 +174,7 @@ struct let config = config ~root in let size () = size ~root in let t = { t with root } in - Eio_main.run @@ fun _ -> + Eio_main.run @@ fun _ -> init t config; run t config size diff --git a/src/irmin-test/store_watch.ml b/src/irmin-test/store_watch.ml index f391a45d022..6190915c590 100644 --- a/src/irmin-test/store_watch.ml +++ b/src/irmin-test/store_watch.ml @@ -195,9 +195,7 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct else Alcotest.failf "%s: %a / %a" msg pp a pp b) let process ?sleep_t t head = - let () = - match sleep_t with None -> () | Some s -> Zzz.sleep s - in + let () = match sleep_t with None -> () | Some s -> Zzz.sleep s in let () = match head with | `Added _ -> add t @@ -372,6 +370,6 @@ module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct TODO: work out why, fix it, and re-enable it. See https://github.com/mirage/irmin/issues/1447. *) let _ = ("Basic operations", test_watches) in - let _ = [ ("Callbacks and exceptions", test_watch_exn) ] in + let _ = [ ("Callbacks and exceptions", test_watch_exn) ] in [] end diff --git a/src/irmin/conf.ml b/src/irmin/conf.ml index 69b7f24f95d..9b9802a45e3 100644 --- a/src/irmin/conf.ml +++ b/src/irmin/conf.ml @@ -156,11 +156,10 @@ let find_root (spec, d) : string option = match v with None -> None | Some v -> Some (Type.to_string k.ty v)) module Env = struct - - type _ Effect.t += + type _ Effect.t += | Fs : Eio.Fs.dir Eio.Path.t Effect.t | Net : Eio.Net.t Effect.t let fs () = Effect.perform Fs let net () = Effect.perform Net -end \ No newline at end of file +end diff --git a/src/irmin/conf.mli b/src/irmin/conf.mli index 451d59fd3d6..1773ec294de 100644 --- a/src/irmin/conf.mli +++ b/src/irmin/conf.mli @@ -160,11 +160,10 @@ val find_root : t -> string option (** [find_root c] is [root]'s mapping in [c], if any. *) module Env : sig - - type _ Effect.t += + type _ Effect.t += | Fs : Eio.Fs.dir Eio.Path.t Effect.t | Net : Eio.Net.t Effect.t val fs : unit -> Eio.Fs.dir Eio.Path.t val net : unit -> Eio.Net.t -end \ No newline at end of file +end diff --git a/src/irmin/store.ml b/src/irmin/store.ml index de66e7472f6..a8faa009c63 100644 --- a/src/irmin/store.ml +++ b/src/irmin/store.ml @@ -620,7 +620,8 @@ module Make (B : Backend.S) = struct ~set:(h set) let test_and_set t ~test ~set = - Eio.Mutex.use_rw ~protect:true t.lock (fun () -> test_and_set_unsafe t ~test ~set) + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> + test_and_set_unsafe t ~test ~set) let fast_forward t ?max_depth ?n new_head = let return x = if x then Ok () else Error (`Rejected :> ff_error) in @@ -665,7 +666,8 @@ module Make (B : Backend.S) = struct let c3 = Commit.of_key t.repo c3 in test_and_set_unsafe t ~test:head ~set:c3 |> Merge.ok in - Eio.Mutex.use_rw ~protect:true t.lock (fun () -> retry_merge "merge_head" aux) + Eio.Mutex.use_rw ~protect:true t.lock (fun () -> + retry_merge "merge_head" aux) end (* Retry an operation until the optimistic lock is happy. Ensure @@ -775,8 +777,8 @@ module Make (B : Backend.S) = struct | None -> Tree.remove root key |> ok | Some tree -> Tree.add_tree root key tree |> ok - let ignore_commit - (c : (commit option, [> `Too_many_retries of int ]) result) = + let ignore_commit (c : (commit option, [> `Too_many_retries of int ]) result) + = Result.map (fun _ -> ()) c let set_tree ?(retries = 13) ?allow_empty ?parents ~info t k v = @@ -784,8 +786,7 @@ module Make (B : Backend.S) = struct ignore_commit @@ retry ~retries @@ fun () -> - update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> - Some v + update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> Some v let set_tree_exn ?retries ?allow_empty ?parents ~info t k v = set_tree ?retries ?allow_empty ?parents ~info t k v |> fail "set_exn" @@ -795,8 +796,7 @@ module Make (B : Backend.S) = struct ignore_commit @@ retry ~retries @@ fun () -> - update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> - None + update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> None let remove_exn ?retries ?allow_empty ?parents ~info t k = remove ?retries ?allow_empty ?parents ~info t k |> fail "remove_exn" diff --git a/src/irmin/tree.ml b/src/irmin/tree.ml index 8d798b2820d..d31f160a734 100644 --- a/src/irmin/tree.ml +++ b/src/irmin/tree.ml @@ -1401,8 +1401,7 @@ module Make (P : Backend.S) = struct | Some (`Lt depth) -> if d < depth - 1 then apply acc |> next else apply acc |> k | Some (`Ge depth) -> if d < depth then next acc else apply acc |> next - | Some (`Gt depth) -> - if d <= depth then next acc else apply acc |> next + | Some (`Gt depth) -> if d <= depth then next acc else apply acc |> next and aux_uniq : type r. (t, acc, r) cps_folder = fun ~path acc d t k -> if uniq = `False then (aux [@tailcall]) ~path acc d t k diff --git a/src/irmin/tree_intf.ml b/src/irmin/tree_intf.ml index 8744f69290f..aa58b245632 100644 --- a/src/irmin/tree_intf.ml +++ b/src/irmin/tree_intf.ml @@ -177,12 +177,7 @@ module type S = sig the parameter. *) val seq : - t -> - ?offset:int -> - ?length:int -> - ?cache:bool -> - path -> - (step * t) Seq.t + t -> ?offset:int -> ?length:int -> ?cache:bool -> path -> (step * t) Seq.t (** [seq t key] follows the same behavior as {!list} but returns a sequence. *) val get : t -> path -> contents diff --git a/src/irmin/watch.ml b/src/irmin/watch.ml index 39b97581de4..91496c88142 100644 --- a/src/irmin/watch.ml +++ b/src/irmin/watch.ml @@ -61,7 +61,9 @@ let scheduler () = (s, Eio.Stream.add s) in incr workers_r; - let sw = try Option.get !watch_switch with _ -> failwith "Big Yikes" in + let sw = + try Option.get !watch_switch with _ -> failwith "Big Yikes" + in (Eio.Fiber.fork ~sw @@ fun () -> stream_iter (fun f -> f ()) stream); (* Lwt.async (fun () -> (* FIXME: we would like to skip some updates if more recent ones diff --git a/test/irmin-chunk/test.ml b/test/irmin-chunk/test.ml index 010d7172498..f5b211186a9 100644 --- a/test/irmin-chunk/test.ml +++ b/test/irmin-chunk/test.ml @@ -79,5 +79,5 @@ let stable = let () = Eio_main.run @@ fun _env -> Irmin_test.Store.run "irmin-chunk" ~slow:true ~misc:[ simple; stable ] - ~sleep:Eio_unix.sleep - [ (`Quick, Test_chunk.suite) ] + ~sleep:Eio_unix.sleep + [ (`Quick, Test_chunk.suite) ] diff --git a/test/irmin-containers/blob_log.ml b/test/irmin-containers/blob_log.ml index eafaa0f1b98..23e9e714351 100644 --- a/test/irmin-containers/blob_log.ml +++ b/test/irmin-containers/blob_log.ml @@ -35,7 +35,7 @@ let test_append () = B.append ~path t "main.2"; B.read_all ~path t |> Alcotest.(check (list string)) - "checked - log after appending" [ "main.2"; "main.1" ] + "checked - log after appending" [ "main.2"; "main.1" ] let test_clone_merge () = let t = config () |> B.Store.main in @@ -45,8 +45,8 @@ let test_clone_merge () = merge_into_exn b ~into:t; B.read_all ~path t |> Alcotest.(check (list string)) - "checked - log after appending" - [ "main.3"; "clone.1"; "main.2"; "main.1" ] + "checked - log after appending" + [ "main.3"; "clone.1"; "main.2"; "main.1" ] let test_branch_merge () = let r = config () in @@ -67,13 +67,13 @@ let test_branch_merge () = let () = B.read_all ~path b3 |> Alcotest.(check (list string)) - "checked - value of b3" - [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + "checked - value of b3" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] in B.read_all ~path b4 |> Alcotest.(check (list string)) - "checked - value of b4" - [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + "checked - value of b4" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] let test_cases = [ diff --git a/test/irmin-containers/common.mli b/test/irmin-containers/common.mli index db11c2d2846..1ace834a092 100644 --- a/test/irmin-containers/common.mli +++ b/test/irmin-containers/common.mli @@ -15,5 +15,4 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val merge_into_exn : - (module Irmin.S with type t = 's) -> 's -> into:'s -> unit +val merge_into_exn : (module Irmin.S with type t = 's) -> 's -> into:'s -> unit diff --git a/test/irmin-containers/linked_log.ml b/test/irmin-containers/linked_log.ml index 0609c0dcc83..0f40c62044b 100644 --- a/test/irmin-containers/linked_log.ml +++ b/test/irmin-containers/linked_log.ml @@ -42,7 +42,7 @@ let test_append_read_all () = L.append ~path t "main.2"; L.read_all ~path t |> Alcotest.(check (list string)) - "checked - log after appending" [ "main.2"; "main.1" ] + "checked - log after appending" [ "main.2"; "main.1" ] let test_read_incr () = let cur = config () |> L.Store.main |> L.get_cursor ~path in @@ -67,8 +67,8 @@ let test_clone_merge () = merge_into_exn b ~into:t; L.read_all ~path t |> Alcotest.(check (list string)) - "checked - log after appending" - [ "main.3"; "clone.1"; "main.2"; "main.1" ] + "checked - log after appending" + [ "main.3"; "clone.1"; "main.2"; "main.1" ] let test_branch_merge () = let r = config () in @@ -89,13 +89,13 @@ let test_branch_merge () = let () = L.read_all ~path b3 |> Alcotest.(check (list string)) - "checked - value of b3" - [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + "checked - value of b3" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] in L.read_all ~path b4 |> Alcotest.(check (list string)) - "checked - value of b4" - [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + "checked - value of b4" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] let test_cases = [ diff --git a/test/irmin-containers/lww_register.ml b/test/irmin-containers/lww_register.ml index 3010fcb8c17..22afc0e7cbb 100644 --- a/test/irmin-containers/lww_register.ml +++ b/test/irmin-containers/lww_register.ml @@ -35,7 +35,7 @@ let test_empty_read () = |> L.Store.main |> L.read ~path |> Alcotest.(check (option int)) - "checked - reading register without writing" None + "checked - reading register without writing" None let test_write () = let t = config () |> L.Store.main in @@ -60,7 +60,7 @@ let test_clone_merge () = merge_into_exn b ~into:t; L.read ~path t |> Alcotest.(check (option int)) - "checked - value of main after merging" (Some 10) + "checked - value of main after merging" (Some 10) let test_branch_merge () = let r = config () in diff --git a/test/irmin-containers/test.ml b/test/irmin-containers/test.ml index 387715bd0e8..4a15ee2bd34 100644 --- a/test/irmin-containers/test.ml +++ b/test/irmin-containers/test.ml @@ -18,7 +18,7 @@ let () = Eio_main.run @@ fun _env -> Alcotest.run "irmin-containers" - (Counter.test_cases - @ Lww_register.test_cases - @ Blob_log.test_cases - @ Linked_log.test_cases) + (Counter.test_cases + @ Lww_register.test_cases + @ Blob_log.test_cases + @ Linked_log.test_cases) diff --git a/test/irmin-fs/test.ml b/test/irmin-fs/test.ml index db06561af23..17fb69d99dd 100644 --- a/test/irmin-fs/test.ml +++ b/test/irmin-fs/test.ml @@ -18,4 +18,4 @@ let () = Eio_main.run @@ fun env -> Irmin_fs.run env#fs @@ fun () -> Irmin_test.Store.run "irmin-fs" ~slow:true ~misc:[] ~sleep:Eio_unix.sleep - [ (`Quick, Test_fs.suite) ] + [ (`Quick, Test_fs.suite) ] diff --git a/test/irmin-fs/test_unix.ml b/test/irmin-fs/test_unix.ml index d73e7ee8b24..f312b9f3f46 100644 --- a/test/irmin-fs/test_unix.ml +++ b/test/irmin-fs/test_unix.ml @@ -19,5 +19,5 @@ let () = Irmin_fs.run env#fs @@ fun () -> Irmin_watcher.run @@ fun () -> Irmin_test.Store.run "irmin-fs.unix" ~slow:false ~sleep:Eio_unix.sleep - ~misc:[] - [ (`Quick, Test_fs_unix.suite) ] + ~misc:[] + [ (`Quick, Test_fs_unix.suite) ] diff --git a/test/irmin-mem/test.ml b/test/irmin-mem/test.ml index 03841d23ab0..66298768f6b 100644 --- a/test/irmin-mem/test.ml +++ b/test/irmin-mem/test.ml @@ -17,4 +17,4 @@ let () = Eio_main.run @@ fun _ -> Irmin_test.Store.run "irmin-mem" ~slow:true ~misc:[] ~sleep:Eio_unix.sleep - [ (`Quick, Test_mem.suite) ] + [ (`Quick, Test_mem.suite) ] diff --git a/test/irmin-pack/common.ml b/test/irmin-pack/common.ml index 7c385797ab3..4e8f871a77f 100644 --- a/test/irmin-pack/common.ml +++ b/test/irmin-pack/common.ml @@ -170,7 +170,7 @@ struct let close_pack t = Index.close_exn t.index; File_manager.close t.fm |> Errs.raise_if_error - (* closes pack and dict *) + (* closes pack and dict *) end module Alcotest = struct diff --git a/test/irmin-pack/common.mli b/test/irmin-pack/common.mli index d36449d7948..0a903090b3e 100644 --- a/test/irmin-pack/common.mli +++ b/test/irmin-pack/common.mli @@ -95,10 +95,10 @@ end) : sig dict : Dict.t; } - val get_rw_pack : unit -> t - val get_ro_pack : string -> t - val reopen_rw : string -> t - val close_pack : t -> unit + val get_rw_pack : unit -> t + val get_ro_pack : string -> t + val reopen_rw : string -> t + val close_pack : t -> unit end val get : 'a option -> 'a diff --git a/test/irmin-pack/test.ml b/test/irmin-pack/test.ml index dc08b5092b7..32e5823b860 100644 --- a/test/irmin-pack/test.ml +++ b/test/irmin-pack/test.ml @@ -16,6 +16,5 @@ let () = Eio_main.run @@ fun _env -> - Irmin_test.Store.run "irmin-pack" ~misc:Test_pack.misc - ~sleep:Eio_unix.sleep - (List.map (fun s -> (`Quick, s)) Test_pack.suite) + Irmin_test.Store.run "irmin-pack" ~misc:Test_pack.misc ~sleep:Eio_unix.sleep + (List.map (fun s -> (`Quick, s)) Test_pack.suite) diff --git a/test/irmin-pack/test_corrupted.ml b/test/irmin-pack/test_corrupted.ml index 10b0030ef69..00ca1c9cedb 100644 --- a/test/irmin-pack/test_corrupted.ml +++ b/test/irmin-pack/test_corrupted.ml @@ -69,8 +69,7 @@ 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 ~fresh:false root)) with exn -> Error exn in Alcotest.(check bool) "is corrupted" true @@ -78,5 +77,6 @@ let test_corrupted_control_file () = let tests = [ - Alcotest.test_case "Corrupted control file" `Quick test_corrupted_control_file; + Alcotest.test_case "Corrupted control file" `Quick + test_corrupted_control_file; ] diff --git a/test/irmin-pack/test_existing_stores.ml b/test/irmin-pack/test_existing_stores.ml index 793ae8a1c1c..369700eecc1 100644 --- a/test/irmin-pack/test_existing_stores.ml +++ b/test/irmin-pack/test_existing_stores.ml @@ -261,9 +261,13 @@ end let tests = [ - Alcotest.test_case "Test index reconstruction" `Quick Test_reconstruct.test_reconstruct; - Alcotest.test_case "Test gc not allowed" `Quick Test_reconstruct.test_gc_allowed; + Alcotest.test_case "Test index reconstruction" `Quick + Test_reconstruct.test_reconstruct; + Alcotest.test_case "Test gc not allowed" `Quick + Test_reconstruct.test_gc_allowed; Alcotest.test_case "Test integrity check" `Quick Test_corrupted_stores.test; - Alcotest.test_case "Test integrity check for inodes" `Quick Test_corrupted_inode.test; - Alcotest.test_case "Test traverse pack on gced store" `Quick Test_traverse_gced.test_traverse_pack; + Alcotest.test_case "Test integrity check for inodes" `Quick + Test_corrupted_inode.test; + Alcotest.test_case "Test traverse pack on gced store" `Quick + Test_traverse_gced.test_traverse_pack; ] diff --git a/test/irmin-pack/test_gc.ml b/test/irmin-pack/test_gc.ml index d693a9a39a7..6e2910ea1b2 100644 --- a/test/irmin-pack/test_gc.ml +++ b/test/irmin-pack/test_gc.ml @@ -241,9 +241,7 @@ let check_del_1 t c = let check_not_found t key msg = let c = S.Commit.of_hash t.repo (S.Commit.hash key) in - match c with - | None -> () - | Some _ -> Alcotest.failf "should not find %s" msg + match c with None -> () | Some _ -> Alcotest.failf "should not find %s" msg module Gc = struct (** Check that gc preserves and deletes commits accordingly. *) diff --git a/test/irmin-pack/test_gc.mli b/test/irmin-pack/test_gc.mli index 177c5e4ab18..ca472e8079d 100644 --- a/test/irmin-pack/test_gc.mli +++ b/test/irmin-pack/test_gc.mli @@ -40,8 +40,8 @@ module Store : sig val close : t -> unit val start_gc : ?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) - val commit_3 : t -> (t * S.commit) + val commit_1 : t -> t * S.commit + val commit_2 : t -> t * S.commit + val commit_3 : t -> t * S.commit val checkout_exn : t -> S.commit -> t end diff --git a/test/irmin-pack/test_inode.ml b/test/irmin-pack/test_inode.ml index cffd5267ad4..415d1a75200 100644 --- a/test/irmin-pack/test_inode.ml +++ b/test/irmin-pack/test_inode.ml @@ -131,9 +131,8 @@ struct [%log.app "Test context constructed"]; { store; store_contents; fm; foo; bar } - let close t = - File_manager.close t.fm |> Errs.raise_if_error - (* closes dict, inodes and contents store. *) + let close t = File_manager.close t.fm |> Errs.raise_if_error + (* closes dict, inodes and contents store. *) end end diff --git a/test/irmin-pack/test_mapping.ml b/test/irmin-pack/test_mapping.ml index eaf22e88ceb..fb9136f457a 100644 --- a/test/irmin-pack/test_mapping.ml +++ b/test/irmin-pack/test_mapping.ml @@ -118,12 +118,10 @@ let test ~full_seg_length ~seg_subset_max_length ~random_test_count = let tests = [ - Alcotest.test_case "test mapping on small inputs" `Quick - (fun () -> + Alcotest.test_case "test mapping on small inputs" `Quick (fun () -> test ~full_seg_length:10 ~seg_subset_max_length:30 ~random_test_count:1000); - Alcotest.test_case "test mapping on large inputs" `Quick - (fun () -> + Alcotest.test_case "test mapping on large inputs" `Quick (fun () -> test ~full_seg_length:10000 ~seg_subset_max_length:30000 ~random_test_count:100); ] diff --git a/test/irmin-pack/test_nearest_leq.ml b/test/irmin-pack/test_nearest_leq.ml index 4d1cfe35b6c..f69f6d1f4ef 100644 --- a/test/irmin-pack/test_nearest_leq.ml +++ b/test/irmin-pack/test_nearest_leq.ml @@ -22,6 +22,5 @@ let test_nearest_leq () = let tests = [ - Alcotest.test_case "test_nearest_leq" `Quick (fun () -> - test_nearest_leq ()); + Alcotest.test_case "test_nearest_leq" `Quick (fun () -> test_nearest_leq ()); ] diff --git a/test/irmin-pack/test_pack.ml b/test/irmin-pack/test_pack.ml index c933125cd23..446475c9b3f 100644 --- a/test/irmin-pack/test_pack.ml +++ b/test/irmin-pack/test_pack.ml @@ -215,7 +215,8 @@ module Pack = struct test t.pack; let t' = Context.get_ro_pack t.name in test t'.pack; - Context.close_pack t; Context.close_pack t' + Context.close_pack t; + Context.close_pack t' let test_readonly_pack () = let t = Context.get_rw_pack () in @@ -250,7 +251,8 @@ module Pack = struct let y3 = Pack.find t'.pack k3 in Alcotest.(check (option string)) "y3" (Some x3) y3 in - Context.close_pack t; Context.close_pack t' + Context.close_pack t; + Context.close_pack t' let test_close_pack_more () = (*open and close in rw*) @@ -275,7 +277,8 @@ module Pack = struct let t3 = Context.get_ro_pack 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 + Context.close_pack t2; + Context.close_pack t3 let test_close_pack () = let t = Context.get_rw_pack () in @@ -400,8 +403,10 @@ module Pack = struct 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 "readonly reload, index flush" `Quick readonly_reload_index_flush; - Alcotest.test_case "readonly find, index flush" `Quick readonly_find_index_flush; + Alcotest.test_case "readonly reload, index flush" `Quick + readonly_reload_index_flush; + Alcotest.test_case "readonly find, index flush" `Quick + readonly_find_index_flush; ] end @@ -513,9 +518,7 @@ module Layout = struct c None (classif "./store.0.prefix") let tests = - [ - Alcotest.test_case "classify_filename" `Quick test_classify_filename; - ] + [ Alcotest.test_case "classify_filename" `Quick test_classify_filename ] end let misc = diff --git a/test/irmin-pack/test_snapshot.ml b/test/irmin-pack/test_snapshot.ml index 002c9e7ae1d..4d391de14eb 100644 --- a/test/irmin-pack/test_snapshot.ml +++ b/test/irmin-pack/test_snapshot.ml @@ -240,9 +240,7 @@ let test_gced_store_on_disk () = let repo_import = S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) in - let () = - test_gc ~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 diff --git a/test/irmin-pack/test_tree.ml b/test/irmin-pack/test_tree.ml index 7da580bd58b..d2c8ee6cddb 100644 --- a/test/irmin-pack/test_tree.ml +++ b/test/irmin-pack/test_tree.ml @@ -693,13 +693,17 @@ let tests = [ 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 undefined order" `Quick test_fold_undefined; - Alcotest.test_case "test Merkle proof for large inodes" `Quick test_large_inode; - Alcotest.test_case "test Merkle proof for small inodes" `Quick test_small_inode; + Alcotest.test_case "fold over keys in undefined order" `Quick + test_fold_undefined; + Alcotest.test_case "test Merkle proof for large inodes" `Quick + test_large_inode; + Alcotest.test_case "test Merkle proof for small inodes" `Quick + test_small_inode; 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 extenders in stream proof" `Quick test_extenders; - Alcotest.test_case "test hardcoded stream proof" `Quick test_hardcoded_stream; + Alcotest.test_case "test hardcoded stream proof" `Quick + test_hardcoded_stream; Alcotest.test_case "test hardcoded proof" `Quick test_hardcoded_proof; Alcotest.test_case "test stream proof exn" `Quick test_proof_exn; Alcotest.test_case "test reexport node" `Quick test_reexport_node; diff --git a/test/irmin-pack/test_upgrade.ml b/test/irmin-pack/test_upgrade.ml index 73911aa98f7..0c25463340f 100644 --- a/test/irmin-pack/test_upgrade.ml +++ b/test/irmin-pack/test_upgrade.ml @@ -269,7 +269,7 @@ module Store = struct with Irmin_pack_unix.Pack_store.Invalid_read _ -> (* In RW mode, [mem] will raise an exception if the offset of the key is out of the bounds of the pack file *) - false + false let put_borphan bstore = let k = S.Backend.Contents.add bstore "borphan" in @@ -640,13 +640,13 @@ let test_one t ~ro_open_at ~ro_sync_at = let test_one_guarded setup ~ro_open_at ~ro_sync_at = let t = create_test_env setup in try - let () = test_one t ~ro_open_at ~ro_sync_at in - close_everything t + let () = test_one t ~ro_open_at ~ro_sync_at in + close_everything t with - | Skip_the_rest_of_that_test -> - [%logs.app "*** skip rest of %a" pp_setup setup]; - close_everything t - | exn -> raise exn + | Skip_the_rest_of_that_test -> + [%logs.app "*** skip rest of %a" pp_setup setup]; + close_everything t + | exn -> raise exn (** All possible interleaving of the ro calls (open and sync) with the rw calls (open, write1, gc and write2). *) diff --git a/test/irmin/generic-key/dune b/test/irmin/generic-key/dune index 9ddd2f5348e..604c1d56fc9 100644 --- a/test/irmin/generic-key/dune +++ b/test/irmin/generic-key/dune @@ -4,10 +4,4 @@ (package irmin-test) (preprocess (pps ppx_irmin.internal)) - (libraries - irmin - eio_main - irmin.mem - irmin-test - alcotest - vector)) + (libraries irmin eio_main irmin.mem irmin-test alcotest vector)) diff --git a/test/irmin/generic-key/test.ml b/test/irmin/generic-key/test.ml index 5f6c18447cb..8bd7a49a173 100644 --- a/test/irmin/generic-key/test.ml +++ b/test/irmin/generic-key/test.ml @@ -17,6 +17,4 @@ let () = Eio_main.run @@ fun _env -> Irmin_test.Store.run __FILE__ ~slow:true ~misc:[] ~sleep:Eio_unix.sleep - [ - (`Quick, Test_store_offset.suite); (`Quick, Test_inlined_contents.suite); - ] + [ (`Quick, Test_store_offset.suite); (`Quick, Test_inlined_contents.suite) ]