From 57e0c2d667c202b18b584306f24c3707cc3abf7f Mon Sep 17 00:00:00 2001 From: Zolisa Bleki Date: Sat, 14 Sep 2024 07:25:46 +0200 Subject: [PATCH 1/3] Add `rename` functionality for store nodes. This adds the ability to rename either a group or array node in a Zarr hierarchy. --- README.md | 2 ++ examples/inmemory_zipstore.ml | 16 ++++++++++++++-- examples/readonly_zipstore.ml | 2 ++ zarr-eio/src/storage.ml | 3 +++ zarr-eio/test/test_eio.ml | 19 +++++++++++++++++-- zarr-lwt/src/storage.ml | 3 +++ zarr-lwt/test/test_lwt.ml | 19 +++++++++++++++++-- zarr-sync/src/storage.ml | 3 +++ zarr-sync/test/test_sync.ml | 20 ++++++++++++++++++++ zarr/src/node.ml | 13 +++++++++++++ zarr/src/node.mli | 18 ++++++++++++++++++ zarr/src/storage/memory.ml | 9 +++++++++ zarr/src/storage/storage.ml | 12 ++++++++++++ zarr/src/storage/storage_intf.ml | 14 ++++++++++++++ zarr/src/types.ml | 1 + zarr/test/test_node.ml | 20 ++++++++++++++++++++ 16 files changed, 168 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 0f0cb4c..e3e219b 100644 --- a/README.md +++ b/README.md @@ -131,6 +131,8 @@ List.map GroupNode.to_path g;; FilesystemStore.erase_group_node store group_node;; FilesystemStore.erase_all_nodes store;; (* clears the store *) +FilesystemStore.rename_group store group_node;; +FilesystemStore.rename_array store anode;; ``` [1]: https://codecov.io/gh/zoj613/zarr-ml/graph/badge.svg?token=KOOG2Y1SH5 diff --git a/examples/inmemory_zipstore.ml b/examples/inmemory_zipstore.ml index 246c866..04792f2 100644 --- a/examples/inmemory_zipstore.ml +++ b/examples/inmemory_zipstore.ml @@ -135,6 +135,15 @@ end = struct (fun () -> t.ic <- Zipc.of_string_map m'; Deferred.return_unit) + + let rename t ok nk = + Lwt_mutex.with_lock t.mutex @@ fun () -> + let m = Zipc.to_string_map t.ic in + let m1, m2 = M.partition (fun k _ -> String.starts_with ~prefix:ok k) m in + let l = String.length ok in + let s = Seq.map + (fun (k, v) -> nk ^ String.(length k - l |> sub k l), v) @@ M.to_seq m1 in + t.ic <- Zipc.of_string_map @@ M.add_seq s m2; Lwt.return_unit end (* this functor generates the public signature of our Zip file store. *) @@ -182,7 +191,10 @@ let _ = let* x = MemoryZipStore.read_array store anode slice Zarr.Ndarray.Char in let x' = x |> Zarr.Ndarray.map @@ fun _ -> Random.int 256 |> Char.chr in let* () = MemoryZipStore.write_array store anode slice x' in - let+ y = MemoryZipStore.read_array store anode slice Zarr.Ndarray.Char in - assert (Zarr.Ndarray.equal x' y) + let* y = MemoryZipStore.read_array store anode slice Zarr.Ndarray.Char in + assert (Zarr.Ndarray.equal x' y); + let* () = MemoryZipStore.rename_array store anode "name2" in + let+ exists = MemoryZipStore.array_exists store @@ ArrayNode.of_path "/some/group/name2" in + assert exists end; print_endline "Zip store has been update." diff --git a/examples/readonly_zipstore.ml b/examples/readonly_zipstore.ml index 6045136..c9dc5a8 100644 --- a/examples/readonly_zipstore.ml +++ b/examples/readonly_zipstore.ml @@ -83,6 +83,8 @@ end = struct let erase _ = raise Not_implemented let erase_prefix _ = raise Not_implemented + + let rename _ = raise Not_implemented end (* this functor generates the public signature of our Zip file store. *) diff --git a/zarr-eio/src/storage.ml b/zarr-eio/src/storage.ml index 406dc8f..aed67b3 100644 --- a/zarr-eio/src/storage.ml +++ b/zarr-eio/src/storage.ml @@ -89,6 +89,9 @@ module FilesystemStore = struct | p when Eio.Path.is_directory p -> Either.right @@ (fspath_to_key t p) ^ "/" | p -> Either.left @@ fspath_to_key t p) (Eio.Path.read_dir dir) + + let rename t k k' = + Eio.Path.rename (key_to_fspath t k) (key_to_fspath t k') end module U = Zarr.Util diff --git a/zarr-eio/test/test_eio.ml b/zarr-eio/test/test_eio.ml index b1c2854..27e9595 100644 --- a/zarr-eio/test/test_eio.ml +++ b/zarr-eio/test/test_eio.ml @@ -70,7 +70,7 @@ let test_storage assert_equal exp got) [[`ShardingIndexed cfg]; [`Bytes BE]]; - let child = GroupNode.of_path "/some/child" in + let child = GroupNode.of_path "/some/child/group" in create_group store child; let arrays, groups = find_child_nodes store gnode in assert_equal @@ -86,7 +86,22 @@ let test_storage List.fast_sort String.compare @@ List.map ArrayNode.show ac @ List.map GroupNode.show gc in assert_equal - ~printer:string_of_list ["/"; "/arrnode"; "/some"; "/some/child"] got; + ~printer:string_of_list + ["/"; "/arrnode"; "/some"; "/some/child"; "/some/child/group"] got; + + (* tests for renaming nodes *) + let some = GroupNode.of_path "/some/child" in + rename_array store anode "ARRAYNODE"; + rename_group store some "CHILD"; + let ac, gc = find_all_nodes store in + let got = + List.fast_sort String.compare @@ + List.map ArrayNode.show ac @ List.map GroupNode.show gc in + assert_equal + ~printer:string_of_list + ["/"; "/ARRAYNODE"; "/some"; "/some/CHILD"; "/some/CHILD/group"] got; + (* restore old array node name. *) + rename_array store (ArrayNode.of_path "/ARRAYNODE") "arrnode"; let nshape = [|25; 32; 10|] in reshape store anode nshape; diff --git a/zarr-lwt/src/storage.ml b/zarr-lwt/src/storage.ml index c5a12e4..ce05901 100644 --- a/zarr-lwt/src/storage.ml +++ b/zarr-lwt/src/storage.ml @@ -124,6 +124,9 @@ module FilesystemStore = struct | p when Sys.is_directory p -> Either.right @@ (fspath_to_key t p) ^ "/" | p -> Either.left @@ fspath_to_key t p) files + + let rename t k k' = + Lwt_unix.rename (key_to_fspath t k) (key_to_fspath t k') end module U = Zarr.Util diff --git a/zarr-lwt/test/test_lwt.ml b/zarr-lwt/test/test_lwt.ml index 7e01cb9..b87bf5b 100644 --- a/zarr-lwt/test/test_lwt.ml +++ b/zarr-lwt/test/test_lwt.ml @@ -71,7 +71,7 @@ let test_storage assert_equal exp got) [[`ShardingIndexed cfg]; [`Bytes BE]] >>= fun () -> - let child = GroupNode.of_path "/some/child" in + let child = GroupNode.of_path "/some/child/group" in create_group store child >>= fun () -> find_child_nodes store gnode >>= fun (arrays, groups) -> assert_equal @@ -87,7 +87,22 @@ let test_storage List.fast_sort String.compare @@ List.map ArrayNode.show ac @ List.map GroupNode.show gc in assert_equal - ~printer:string_of_list ["/"; "/arrnode"; "/some"; "/some/child"] got; + ~printer:string_of_list + ["/"; "/arrnode"; "/some"; "/some/child"; "/some/child/group"] got; + + (* tests for renaming nodes *) + let some = GroupNode.of_path "/some/child" in + rename_array store anode "ARRAYNODE" >>= fun () -> + rename_group store some "CHILD" >>= fun () -> + find_all_nodes store >>= fun (ac, gc) -> + let got = + List.fast_sort String.compare @@ + List.map ArrayNode.show ac @ List.map GroupNode.show gc in + assert_equal + ~printer:string_of_list + ["/"; "/ARRAYNODE"; "/some"; "/some/CHILD"; "/some/CHILD/group"] got; + (* restore old array node name. *) + rename_array store (ArrayNode.of_path "/ARRAYNODE") "arrnode" >>= fun () -> let nshape = [|25; 32; 10|] in reshape store anode nshape >>= fun () -> diff --git a/zarr-sync/src/storage.ml b/zarr-sync/src/storage.ml index a48d324..6454aab 100644 --- a/zarr-sync/src/storage.ml +++ b/zarr-sync/src/storage.ml @@ -93,6 +93,9 @@ module FilesystemStore = struct | p when Sys.is_directory p -> Either.right @@ (fspath_to_key t p) ^ "/" | p -> Either.left @@ fspath_to_key t p) (Array.to_list @@ Sys.readdir dir) + + let rename t k k' = + Sys.rename (key_to_fspath t k) (key_to_fspath t k') end module U = Zarr.Util diff --git a/zarr-sync/test/test_sync.ml b/zarr-sync/test/test_sync.ml index 259f9e9..e11b561 100644 --- a/zarr-sync/test/test_sync.ml +++ b/zarr-sync/test/test_sync.ml @@ -127,6 +127,26 @@ let test_storage ~printer:string_of_list ["/"; "/arrnode"; "/some"; "/some/child"; "/some/child/group"] got; + (* tests for renaming nodes *) + let some = GroupNode.of_path "/some/child" in + rename_group store some "CHILD"; + rename_array store anode "ARRAYNODE"; + let ac, gc = find_all_nodes store in + let got = + List.fast_sort String.compare @@ + List.map ArrayNode.show ac @ List.map GroupNode.show gc in + assert_equal + ~printer:string_of_list + ["/"; "/ARRAYNODE"; "/some"; "/some/CHILD"; "/some/CHILD/group"] got; + assert_raises + (Zarr.Storage.Key_not_found "fakegroup") + (fun () -> rename_group store GroupNode.(gnode / "fakegroup") "somename"); + assert_raises + (Zarr.Storage.Key_not_found "fakearray") + (fun () -> rename_array store ArrayNode.(gnode / "fakearray") "somename"); + + (* restore old array node name. *) + rename_array store (ArrayNode.of_path "/ARRAYNODE") "arrnode"; let nshape = [|25; 32; 10|] in reshape store anode nshape; let meta = array_metadata store anode in diff --git a/zarr/src/node.ml b/zarr/src/node.ml index ef26c45..ef42635 100644 --- a/zarr/src/node.ml +++ b/zarr/src/node.ml @@ -1,4 +1,5 @@ exception Node_invariant +exception Cannot_rename_root (* Check if the path's name satisfies path invariants *) let rep_ok name = @@ -78,6 +79,12 @@ module GroupNode = struct let pp fmt t = Format.fprintf fmt "%s" @@ show t + + let rename t str = + match t with + | Cons (parent, _) when rep_ok str -> Cons (parent, str) + | Cons _ -> raise Node_invariant + | Root -> raise Cannot_rename_root end module ArrayNode = struct @@ -129,4 +136,10 @@ module ArrayNode = struct let show = to_path let pp fmt t = Format.fprintf fmt "%s" @@ show t + + let rename t name = + match t.parent with + | Some _ when rep_ok name -> {t with name} + | Some _ -> raise Node_invariant + | None -> raise Cannot_rename_root end diff --git a/zarr/src/node.mli b/zarr/src/node.mli index 0884bf7..387b435 100644 --- a/zarr/src/node.mli +++ b/zarr/src/node.mli @@ -13,6 +13,9 @@ exception Node_invariant (** raised when a node's invariants are violated. *) +exception Cannot_rename_root +(** raised when attempting to rename a root node. *) + module GroupNode : sig type t (** The type of a Group node. *) @@ -72,6 +75,14 @@ module GroupNode : sig val pp : Format.formatter -> t -> unit (** [pp fmt t] pretty prints a node type value. *) + + val rename : t -> string -> t + (** [rename t s] returns a new group node with all properties of [t] + but with its name changed to [s]. + + @raise Node_invariant if [s] is invalid name. + @raise Renaming_root if [t] is a root node.*) + end module ArrayNode : sig @@ -126,4 +137,11 @@ module ArrayNode : sig val pp : Format.formatter -> t -> unit (** [pp fmt t] pretty prints a node type value. *) + + val rename : t -> string -> t + (** [rename t s] returns a new node with all properties of [t] + but with its name changed to [s]. + + @raise Node_invariant if [s] is invalid name. + @raise Renaming_root if [t] is a root node.*) end diff --git a/zarr/src/storage/memory.ml b/zarr/src/storage/memory.ml index d315687..f3f4081 100644 --- a/zarr/src/storage/memory.ml +++ b/zarr/src/storage/memory.ml @@ -81,4 +81,13 @@ module Make (Deferred : Types.Deferred) = struct | k when pred -> l, k :: r | _ -> a) m (S.empty, []) in Deferred.return (keys, S.elements prefs) + + let rec rename t ok nk = + let m = Atomic.get t in + let m1, m2 = StrMap.partition (fun k _ -> String.starts_with ~prefix:ok k) m in + let l = String.length ok in + let s = Seq.map + (fun (k, v) -> nk ^ String.(length k - l |> sub k l), v) @@ StrMap.to_seq m1 in + let m' = StrMap.add_seq s m2 in + if Atomic.compare_and_set t m m' then Deferred.return_unit else rename t ok nk end diff --git a/zarr/src/storage/storage.ml b/zarr/src/storage/storage.ml index ea45f00..8dd5ca1 100644 --- a/zarr/src/storage/storage.ml +++ b/zarr/src/storage/storage.ml @@ -202,4 +202,16 @@ module Make (Io : Types.IO) = struct | true -> erase t key | false -> Deferred.return_unit) ArraySet.(elements @@ diff s s') in set t mkey @@ ArrayMetadata.(encode @@ update_shape meta nshape) + + let rename_array t node str = + let key = ArrayNode.to_key node in + array_exists t node >>= function + | false -> raise @@ Key_not_found key + | true -> rename t key ArrayNode.(rename node str |> to_key) + + let rename_group t node str = + let key = GroupNode.to_key node in + group_exists t node >>= function + | false -> raise @@ Key_not_found key + | true -> rename t key GroupNode.(rename node str |> to_key) end diff --git a/zarr/src/storage/storage_intf.ml b/zarr/src/storage/storage_intf.ml index 36eea26..a9d33ef 100644 --- a/zarr/src/storage/storage_intf.ml +++ b/zarr/src/storage/storage_intf.ml @@ -133,6 +133,20 @@ module type STORE = sig if [shape] does not have the same dimensions as [n]'s shape. @raise Key_not_found if node [n] is not a member of store [t]. *) + + val rename_group : t -> GroupNode.t -> string -> unit Deferred.t + (** [rename t g name] changes the name of group node [g] in store [t] to [name]. + + @raise Key_not_found if [g] is not a member of store [t]. + @raise Renaming_root if [g] is the store's root node. + @raise Node_invariant if [name] is an invalid node name.*) + + val rename_array : t -> ArrayNode.t -> string -> unit Deferred.t + (** [rename t n name] changes the name of array node [n] in store [t] to [name]. + + @raise Key_not_found if [g] is not a member of store [t]. + @raise Renaming_root if [g] is the store's root node. + @raise Node_invariant if [name] is an invalid node name.*) end module type Interface = sig diff --git a/zarr/src/types.ml b/zarr/src/types.ml index 7974435..ee1902e 100644 --- a/zarr/src/types.ml +++ b/zarr/src/types.ml @@ -52,4 +52,5 @@ module type IO = sig val list : t -> key list Deferred.t val list_dir : t -> key -> (key list * prefix list) Deferred.t val is_member : t -> key -> bool Deferred.t + val rename : t -> key -> key -> unit Deferred.t end diff --git a/zarr/test/test_node.ml b/zarr/test/test_node.ml index edb4312..effb2a1 100644 --- a/zarr/test/test_node.ml +++ b/zarr/test/test_node.ml @@ -78,6 +78,16 @@ let group_node = [ false @@ GroupNode.is_child_group GroupNode.root GroupNode.root; + (* rename tests *) + assert_raises + (Zarr.Node.Cannot_rename_root) + (fun () -> GroupNode.rename GroupNode.root "somename"); + assert_raises + (Zarr.Node.Node_invariant) + (fun () -> GroupNode.rename n "?illegal/"); + let n' = GroupNode.rename n "newname" in + assert_bool "" GroupNode.(name n' <> name n); + (* stringify tests *) assert_equal ~printer:Fun.id "" @@ GroupNode.to_key GroupNode.root; @@ -150,6 +160,16 @@ let array_node = [ assert_equal false ArrayNode.(is_parent root GroupNode.root); assert_equal true @@ ArrayNode.is_parent m GroupNode.root; + (* rename tests *) + assert_raises + (Zarr.Node.Cannot_rename_root) + (fun () -> ArrayNode.rename ArrayNode.root "somename"); + assert_raises + (Zarr.Node.Node_invariant) + (fun () -> ArrayNode.rename n "?illegal/"); + let n' = ArrayNode.rename n "newname" in + assert_bool "" ArrayNode.(name n' <> name n); + (* stringify tests *) assert_equal ~printer:Fun.id From 726d76c5fd7a8e0c118d57ab5328eba4eb9255f7 Mon Sep 17 00:00:00 2001 From: Zolisa Bleki Date: Sun, 15 Sep 2024 05:49:51 +0200 Subject: [PATCH 2/3] Update zipfile store examples. --- examples/inmemory_zipstore.ml | 72 +++++++++++------------------------ examples/readonly_zipstore.ml | 28 ++++++-------- 2 files changed, 35 insertions(+), 65 deletions(-) diff --git a/examples/inmemory_zipstore.ml b/examples/inmemory_zipstore.ml index 04792f2..193c182 100644 --- a/examples/inmemory_zipstore.ml +++ b/examples/inmemory_zipstore.ml @@ -2,10 +2,12 @@ It supports both read and write operations. This is because the underlying Zip library used reads all Zip file bytes into memory. All store updates are done in-memory and thus to update the actual zip file - we must persist the data using `MemoryZipStore.write_to_file`. + we must write the update bytes to disk. The `with_open` convenience + function serves this purpose; it ensures that any updates to the store + are written to the zip file upon exit. The main requirement is to implement the signature of Zarr.Types.IO. - We use Zarr_lwt Deferred module for `Deferred` so that the store can be + We use Zarr_lwt's Deferred module for `Deferred` so that the store can be Lwt-aware. To compile & run this example execute the command @@ -14,7 +16,6 @@ module MemoryZipStore : sig include Zarr.Storage.STORE with type 'a Deferred.t = 'a Lwt.t - (*val create : ?level:Zipc_deflate.level -> string -> t *) val with_open : ?level:Zipc_deflate.level -> string -> (t -> 'a Deferred.t) -> 'a Deferred.t end = struct module M = Map.Make(String) @@ -48,11 +49,9 @@ end = struct | None -> raise (Zarr.Storage.Key_not_found key) | Some m -> match Zipc.Member.kind m with - | Zipc.Member.Dir -> failwith "cannot get size of directory." + | Zipc.Member.Dir -> failwith "A chunk key cannot be a directory." | Zipc.Member.File f -> - match Zipc.File.to_binary_string f with - | Error e -> failwith e - | Ok s -> s + Result.fold ~error:failwith ~ok:Fun.id @@ Zipc.File.to_binary_string f let get_partial_values t key ranges = let+ data = get t key in @@ -93,11 +92,8 @@ end = struct match Zipc.Member.(make ~path:key @@ File f) with | Error e -> failwith e | Ok m -> - Lwt_mutex.with_lock - t.mutex - (fun () -> - t.ic <- Zipc.add m t.ic; - Deferred.return_unit) + Lwt_mutex.with_lock t.mutex @@ fun () -> + Deferred.return (t.ic <- Zipc.add m t.ic) let set_partial_values t key ?(append=false) rv = let f = @@ -106,9 +102,9 @@ end = struct Deferred.return @@ acc ^ v else fun acc (rs, v) -> - let s = Bytes.of_string acc in + let s = Bytes.unsafe_of_string acc in String.(length v |> Bytes.blit_string v 0 s rs); - Deferred.return @@ Bytes.to_string s + Deferred.return @@ Bytes.unsafe_to_string s in match Zipc.Member.kind (Option.get @@ Zipc.find key t.ic) with | Zipc.Member.Dir -> Deferred.return_unit @@ -118,23 +114,15 @@ end = struct | Ok s -> Deferred.fold_left f s rv >>= set t key let erase t key = - Lwt_mutex.with_lock - t.mutex - (fun () -> - t.ic <- Zipc.remove key t.ic; - Deferred.return_unit) + Lwt_mutex.with_lock t.mutex @@ fun () -> + Deferred.return (t.ic <- Zipc.remove key t.ic) let erase_prefix t prefix = let m = Zipc.to_string_map t.ic in - let m' = - M.filter_map - (fun k v -> - if String.starts_with ~prefix k then None else Some v) m in - Lwt_mutex.with_lock - t.mutex - (fun () -> - t.ic <- Zipc.of_string_map m'; - Deferred.return_unit) + let m' = M.filter_map + (fun k v -> if String.starts_with ~prefix k then None else Some v) m in + Lwt_mutex.with_lock t.mutex @@ fun () -> + Deferred.return (t.ic <- Zipc.of_string_map m') let rename t ok nk = Lwt_mutex.with_lock t.mutex @@ fun () -> @@ -145,34 +133,22 @@ end = struct (fun (k, v) -> nk ^ String.(length k - l |> sub k l), v) @@ M.to_seq m1 in t.ic <- Zipc.of_string_map @@ M.add_seq s m2; Lwt.return_unit end - (* this functor generates the public signature of our Zip file store. *) include Zarr.Storage.Make(Z) - (* now we create functions to open and close the store. *) - - (*let create ?(level=`Default) path = Z.{ic = Zipc.empty; level; path} *) - let with_open ?(level=`Default) path f = let s = In_channel.(with_open_bin path input_all) in let t = match Zipc.of_binary_string s with | Ok ic -> Z.{ic; level; path; mutex = Lwt_mutex.create ()} | Error e -> failwith e in - Lwt.finalize - (fun () -> f t) - (fun () -> - Lwt_io.with_file - ~flags:Unix.[O_WRONLY; O_TRUNC; O_CREAT; O_NONBLOCK] - ~mode:Lwt_io.Output - t.path - (fun oc -> - let open Lwt.Syntax in - match Zipc.to_binary_string t.ic with - | Error e -> failwith e - | Ok s' -> - if String.equal s s' then Lwt.return_unit else - let* () = Lwt_io.write oc s' in Lwt_io.flush oc)) + Lwt.finalize (fun () -> f t) @@ fun () -> + Lwt_io.with_file + ~flags:Unix.[O_WRONLY; O_TRUNC; O_CREAT; O_NONBLOCK] + ~mode:Lwt_io.Output + t.path + (fun oc -> + Result.fold ~error:failwith ~ok:(Lwt_io.write oc) @@ Zipc.to_binary_string t.ic) end let _ = @@ -181,10 +157,8 @@ let _ = let open Zarr.Indexing in let open MemoryZipStore.Deferred.Syntax in - let printlist = [%show: string list] in MemoryZipStore.with_open "examples/data/testdata.zip" @@ fun store -> let* xs, _ = MemoryZipStore.find_all_nodes store in - print_endline @@ "All array nodes: " ^ printlist (List.map ArrayNode.to_path xs); let anode = List.hd @@ List.filter (fun node -> ArrayNode.to_path node = "/some/group/name") xs in let slice = [|R [|0; 20|]; I 10; R [||]|] in diff --git a/examples/readonly_zipstore.ml b/examples/readonly_zipstore.ml index c9dc5a8..45867a3 100644 --- a/examples/readonly_zipstore.ml +++ b/examples/readonly_zipstore.ml @@ -1,11 +1,10 @@ (* This module implements a Read-only Zip file zarr store that is Eio-aware. The main requirement is to implement the signature of Zarr.Types.IO. We use Zarr_eio's Deferred module for `Deferred` so that the store can be - Eio-aware. Since Zip stores cannot have files updated or removed, we only - implement the get_* and list_* family of functions and raise an - Not_implemented exception for the set_* and erase_* family of functions. - This effectively allows us to create a read-only store since calling any - of the following functions would result in an `Not_implemented` exception: + Eio-aware. We only implement the get_* and list_* family of functions and + raise a Not_implemented exception for the set_* and erase_* family of + functions. This effectively allows us to create a read-only store since + calling any of the following functions would result in error: - ReadOnlyZipStore.create_group - ReadOnlyZipStore.create_array - ReadOnlyZipStore.erase_group_node @@ -13,6 +12,8 @@ - ReadOnlyZipStore.erase_all_nodes - ReadOnlyZipStore.write_array - ReadOnlyZipStore.reshape + - ReadOnlyZipStore.rename_array + - ReadOnlyZipStore.rename_group Below we show how to implement this custom Zarr Store. To compile & run this example execute the command @@ -21,11 +22,8 @@ module ReadOnlyZipStore : sig exception Not_implemented - include Zarr.Storage.STORE with type 'a Deferred.t = 'a - val open_store : string -> t - val close : t -> unit - + val with_open : string -> (t -> 'a) -> 'a end = struct exception Not_implemented @@ -87,23 +85,21 @@ end = struct let rename _ = raise Not_implemented end - (* this functor generates the public signature of our Zip file store. *) include Zarr.Storage.Make(Z) - (* now we create functions to open and close the store. *) - let open_store path = Zip.open_in path - let close = Zip.close_in + let with_open path f = + let x = Zip.open_in path in + Fun.protect ~finally:(fun () -> Zip.close_in x) @@ fun () -> f x end let _ = Eio_main.run @@ fun _ -> let open Zarr.Node in - let store = ReadOnlyZipStore.open_store "examples/data/testdata.zip" in + ReadOnlyZipStore.with_open "examples/data/testdata.zip" @@ fun store -> let xs, _ = ReadOnlyZipStore.find_all_nodes store in let anode = List.hd @@ Eio.Fiber.List.filter (fun node -> ArrayNode.to_path node = "/some/group/name") xs in let arr = ReadOnlyZipStore.read_array store anode [||] Zarr.Ndarray.Char in try ReadOnlyZipStore.write_array store anode [||] arr with - | ReadOnlyZipStore.Not_implemented -> print_endline "Store is read-only"; - ReadOnlyZipStore.close store + | ReadOnlyZipStore.Not_implemented -> print_endline "Store is read-only" From 53de8d5cc29f40553113f169c79adceb96d01e65 Mon Sep 17 00:00:00 2001 From: Zolisa Bleki Date: Sun, 15 Sep 2024 06:52:58 +0200 Subject: [PATCH 3/3] Cleanup `FilesystemStore` of `zarr-sync`. --- zarr-sync/src/storage.ml | 89 +++++++++++++++------------------------- 1 file changed, 34 insertions(+), 55 deletions(-) diff --git a/zarr-sync/src/storage.ml b/zarr-sync/src/storage.ml index 6454aab..0a85f3f 100644 --- a/zarr-sync/src/storage.ml +++ b/zarr-sync/src/storage.ml @@ -4,7 +4,7 @@ module MemoryStore = struct end module FilesystemStore = struct - module FS = struct + module F = struct module Deferred = Deferred type t = {dirname : string; perm : Unix.file_perm} @@ -16,59 +16,41 @@ module FilesystemStore = struct let key_to_fspath t key = Filename.concat t.dirname key let get t key = - try - In_channel.with_open_gen - In_channel.[Open_rdonly; Open_nonblock] - t.perm - (key_to_fspath t key) - In_channel.input_all - with - | Sys_error _ -> raise @@ Zarr.Storage.Key_not_found key + let p = key_to_fspath t key in + try In_channel.(with_open_gen [Open_rdonly; Open_nonblock] t.perm p input_all) + with Sys_error _ -> raise @@ Zarr.Storage.Key_not_found key let get_partial_values t key ranges = - In_channel.with_open_gen - In_channel.[Open_rdonly; Open_nonblock] - t.perm - (key_to_fspath t key) - (fun ic -> - let size = In_channel.length ic |> Int64.to_int in - List.map - (fun (ofs, len) -> - In_channel.seek ic @@ Int64.of_int ofs; - let l = Option.fold ~none:(size - ofs) ~some:Fun.id len in - Option.get @@ In_channel.really_input_string ic l) ranges) - - let set t key value = - let filename = key_to_fspath t key in - Zarr.Util.create_parent_dir filename t.perm; - Out_channel.with_open_gen - Out_channel.[Open_wronly; Open_trunc; Open_creat; Open_nonblock] - t.perm - filename - (fun oc -> Out_channel.output_string oc value; Out_channel.flush oc) + let f = [Open_rdonly; Open_nonblock] in + In_channel.with_open_gen f t.perm (key_to_fspath t key) @@ fun ic -> + let s = In_channel.length ic |> Int64.to_int in + ranges |> List.map @@ fun (ofs, len) -> + In_channel.seek ic @@ Int64.of_int ofs; + let l = Option.fold ~none:(s - ofs) ~some:Fun.id len in + Option.get @@ In_channel.really_input_string ic l + + let set t key v = + let p = key_to_fspath t key in + Zarr.Util.create_parent_dir p t.perm; + let f = [Open_wronly; Open_trunc; Open_creat; Open_nonblock] in + Out_channel.(with_open_gen f t.perm p @@ fun oc -> output_string oc v; flush oc) let set_partial_values t key ?(append=false) rvs = - let open Out_channel in - Out_channel.with_open_gen - [Open_nonblock; if append then Open_append else Open_wronly] - t.perm - (key_to_fspath t key) - (fun oc -> - List.iter - (fun (rs, value) -> - Out_channel.seek oc @@ Int64.of_int rs; - Out_channel.output_string oc value) rvs; Out_channel.flush oc) + let f = [Open_nonblock; if append then Open_append else Open_wronly] in + let p = key_to_fspath t key in + Out_channel.with_open_gen f t.perm p @@ fun oc -> + rvs |> List.iter (fun (rs, value) -> + Out_channel.seek oc @@ Int64.of_int rs; + Out_channel.output_string oc value); + Out_channel.flush oc let is_member t key = Sys.file_exists @@ key_to_fspath t key let erase t key = Sys.remove @@ key_to_fspath t key let size t key = - In_channel.with_open_gen - In_channel.[Open_rdonly; Open_nonblock] - t.perm - (key_to_fspath t key) - (fun ic -> In_channel.length ic |> Int64.to_int) + let f = [Open_rdonly; Open_nonblock] in + In_channel.(with_open_gen f t.perm (key_to_fspath t key) length) |> Int64.to_int let rec walk t acc dir = List.fold_left @@ -87,15 +69,12 @@ module FilesystemStore = struct let list_dir t prefix = let dir = key_to_fspath t prefix in - List.partition_map - (fun x -> - match Filename.concat dir x with - | p when Sys.is_directory p -> - Either.right @@ (fspath_to_key t p) ^ "/" - | p -> Either.left @@ fspath_to_key t p) (Array.to_list @@ Sys.readdir dir) + (Array.to_list @@ Sys.readdir dir) |> List.partition_map @@ fun x -> + match Filename.concat dir x with + | p when Sys.is_directory p -> Either.right @@ (fspath_to_key t p) ^ "/" + | p -> Either.left @@ fspath_to_key t p - let rename t k k' = - Sys.rename (key_to_fspath t k) (key_to_fspath t k') + let rename t k k' = Sys.rename (key_to_fspath t k) (key_to_fspath t k') end module U = Zarr.Util @@ -103,12 +82,12 @@ module FilesystemStore = struct let create ?(perm=0o700) dirname = U.create_parent_dir dirname perm; Sys.mkdir dirname perm; - FS.{dirname = U.sanitize_dir dirname; perm} + F.{dirname = U.sanitize_dir dirname; perm} let open_store ?(perm=0o700) dirname = if Sys.is_directory dirname - then FS.{dirname = U.sanitize_dir dirname; perm} + then F.{dirname = U.sanitize_dir dirname; perm} else raise @@ Zarr.Storage.Not_a_filesystem_store dirname - include Zarr.Storage.Make(FS) + include Zarr.Storage.Make(F) end