diff --git a/lib/extensions.ml b/lib/extensions.ml index 1606e44d..2a586a62 100644 --- a/lib/extensions.ml +++ b/lib/extensions.ml @@ -187,3 +187,88 @@ module Datatype = struct | `String "nativeint" -> Ok Nativeint | _ -> Error ("Unsupported metadata data_type") end + +type tf_error = + [ `Store_read of string + | `Store_write of string ] + +module type STF = sig + type t + val get : t -> string -> (string, [> tf_error]) result + val set : t -> string -> string -> unit + val erase : t -> string -> unit +end + +module StorageTransformers = struct + type transformer = + | Identity + type t = transformer list + + let default = [Identity] + + let deserialize x = + match + Util.get_name x, + Yojson.Safe.Util.(member "configuration" x) + with + | "identity", `Null -> Ok Identity + | _ -> + Error "Unsupported storage transformer name or configuration." + + let of_yojson x = + let open Util.Result_syntax in + List.fold_right + (fun x acc -> + acc >>= fun l -> + deserialize x >>| fun s -> + s :: l) (Yojson.Safe.Util.to_list x) (Ok []) + + let to_yojson x = + `List + (List.fold_right + (fun x acc -> + match x with + | Identity -> acc) x []) + + let get + (type a) + (module M : STF with type t = a) + (store : a) + (transformers : t) + (key : string) + = + let open Util.Result_syntax in + M.get store key >>| fun raw -> + snd @@ + List.fold_right + (fun x (k, v) -> + match x with + | Identity -> (k, v)) transformers (key, raw) + + let set + (type a) + (module M : STF with type t = a) + (store : a) + (transformers : t) + (key : string) + (value : string) + = + let k', v' = + List.fold_left + (fun (k, v) -> function + | Identity -> (k, v)) (key, value) transformers + in + M.set store k' v' + + let erase + (type a) + (module M : STF with type t = a) + (store : a) + (transformers : t) + (key : string) + = + M.erase store @@ + List.fold_left + (fun k -> function + | Identity -> k) key transformers +end diff --git a/lib/extensions.mli b/lib/extensions.mli index 78a62efe..dfe8abcd 100644 --- a/lib/extensions.mli +++ b/lib/extensions.mli @@ -46,3 +46,30 @@ module Datatype : sig val of_yojson : Yojson.Safe.t -> (t, string) result val to_yojson : t -> Yojson.Safe.t end + +type tf_error = + [ `Store_read of string + | `Store_write of string ] + +module type STF = sig + type t + val get : t -> string -> (string, [> tf_error]) result + val set : t -> string -> string -> unit + val erase : t -> string -> unit +end + +module StorageTransformers : sig + type transformer = + | Identity + type t = transformer list + + val default : t + val get : + (module STF with type t = 'a) -> 'a -> t -> string -> (string, [> tf_error ]) result + val set : + (module STF with type t = 'a) -> 'a -> t -> string -> string -> unit + val erase : + (module STF with type t = 'a) -> 'a -> t -> string -> unit + val to_yojson : t -> Yojson.Safe.t + val of_yojson : Yojson.Safe.t -> (t, string) result +end diff --git a/lib/metadata.ml b/lib/metadata.ml index c3638bfd..b25c9dc9 100644 --- a/lib/metadata.ml +++ b/lib/metadata.ml @@ -112,13 +112,14 @@ module ArrayMetadata = struct ;chunk_key_encoding : ChunkKeyEncoding.t ;attributes : Yojson.Safe.t ;dimension_names : string option list - ;storage_transformers : Yojson.Safe.t Util.ExtPoint.t list} + ;storage_transformers : StorageTransformers.t} let create ?(sep=`Slash) ?(codecs=Codecs.Chain.default) ?(dimension_names=[]) ?(attributes=`Null) + ?(storage_transformers=[]) ~shape kind fv @@ -134,7 +135,7 @@ module ArrayMetadata = struct ;dimension_names ;zarr_format = 3 ;node_type = "array" - ;storage_transformers = [] + ;storage_transformers ;fill_value = FillValue.of_kind kind fv ;data_type = Datatype.of_kind kind ;chunk_key_encoding = ChunkKeyEncoding.create sep} @@ -168,6 +169,12 @@ module ArrayMetadata = struct | None -> `Null) xs in l @ [("dimension_names", `List xs')] + in + let l = + match t.storage_transformers with + | [] | [StorageTransformers.Identity] -> l + | xs -> + l @ [("storage_transformers", StorageTransformers.to_yojson xs)] in `Assoc l let of_yojson x = @@ -256,8 +263,9 @@ module ArrayMetadata = struct >>= fun dimension_names -> (match member "storage_transformers" x with - | `Null -> Ok [] - | _ -> Error "storage_transformers field is not yet supported.") + | `Null | `List [] -> Ok [] + | _ -> + Error "storage_transformers field is not yet supported.") >>| fun storage_transformers -> {zarr_format; shape; node_type; data_type; codecs; fill_value; chunk_grid @@ -286,6 +294,8 @@ module ArrayMetadata = struct let attributes t = t.attributes + let storage_transformers t = t.storage_transformers + let chunk_shape t = RegularGrid.chunk_shape t.chunk_grid diff --git a/lib/metadata.mli b/lib/metadata.mli index 203854dd..2d56fa0a 100644 --- a/lib/metadata.mli +++ b/lib/metadata.mli @@ -38,6 +38,7 @@ module ArrayMetadata : sig ?codecs:Codecs.Chain.t -> ?dimension_names:string option list -> ?attributes:Yojson.Safe.t -> + ?storage_transformers:Extensions.StorageTransformers.t -> shape:int array -> ('a, 'b) Bigarray.kind -> 'a -> @@ -76,6 +77,10 @@ module ArrayMetadata : sig (** [attributes t] Returns a Yojson type containing user attributes assigned to the zarr array represented by [t]. *) + val storage_transformers : t -> Extensions.StorageTransformers.t + (** [storage_transformers t] Returns the storage transformers to be applied + to the keys and values of this store. *) + val dimension_names : t -> string option list (** [dimension_name t] returns a list of dimension names. If none are defined then an empty list is returned. *) diff --git a/lib/storage/storage.ml b/lib/storage/storage.ml index e6274e0f..4786d04b 100644 --- a/lib/storage/storage.ml +++ b/lib/storage/storage.ml @@ -8,6 +8,7 @@ module ArraySet = Util.ArraySet module Arraytbl = Util.Arraytbl module AM = Metadata.ArrayMetadata module GM = Metadata.GroupMetadata +module ST = Extensions.StorageTransformers module Make (M : STORE) : S with type t = M.t = struct include M @@ -35,6 +36,7 @@ module Make (M : STORE) : S with type t = M.t = struct ?(sep=`Slash) ?(dimension_names=[]) ?(attributes=`Null) + ?(storage_transformers=[]) ?codecs ~shape ~chunks @@ -54,6 +56,7 @@ module Make (M : STORE) : S with type t = M.t = struct ~codecs ~dimension_names ~attributes + ~storage_transformers ~shape kind fill_value @@ -154,11 +157,12 @@ module Make (M : STORE) : S with type t = M.t = struct in let codecs = AM.codecs meta in let prefix = ArrayNode.to_key node ^ "/" in + let tf = AM.storage_transformers meta in let cindices = ArraySet.of_seq @@ Arraytbl.to_seq_keys tbl in ArraySet.fold (fun idx acc -> acc >>= fun () -> let chunkkey = prefix ^ AM.chunk_key meta idx in - (match get t chunkkey with + (match ST.get (module M) t tf chunkkey with | Ok b -> Codecs.Chain.decode codecs repr b | Error _ -> @@ -173,7 +177,7 @@ module Make (M : STORE) : S with type t = M.t = struct List.iter (fun (c, v) -> Ndarray.set arr c v) @@ Arraytbl.find_all tbl idx; Codecs.Chain.encode codecs arr >>| fun encoded -> - set t chunkkey encoded) cindices (Ok ()) + ST.set (module M) t tf chunkkey encoded) cindices (Ok ()) let get_array : type a b. @@ -206,6 +210,7 @@ module Make (M : STORE) : S with type t = M.t = struct let tbl = Arraytbl.create @@ Array.length pair in let prefix = ArrayNode.to_key node ^ "/" in let chain = AM.codecs meta in + let tf = AM.storage_transformers meta in let repr = {kind ;shape = AM.chunk_shape meta @@ -217,7 +222,7 @@ module Make (M : STORE) : S with type t = M.t = struct | Some arr -> Ok (Ndarray.get arr coord :: l) | None -> - (match get t @@ prefix ^ AM.chunk_key meta idx with + (match ST.get (module M) t tf @@ prefix ^ AM.chunk_key meta idx with | Ok b -> Codecs.Chain.decode chain repr b | Error _ -> @@ -243,8 +248,9 @@ module Make (M : STORE) : S with type t = M.t = struct ArraySet.of_list @@ AM.chunk_indices meta @@ AM.shape meta in let s' = ArraySet.of_list @@ AM.chunk_indices meta shape in + let tf = AM.storage_transformers meta in ArraySet.iter - (fun v -> erase t @@ pre ^ AM.chunk_key meta v) + (fun v -> ST.erase (module M) t tf @@ pre ^ AM.chunk_key meta v) ArraySet.(diff s s'); Ok (set t mkey @@ AM.encode @@ AM.update_shape meta shape) end diff --git a/lib/storage/storage_intf.ml b/lib/storage/storage_intf.ml index 0017f1df..360dd76f 100644 --- a/lib/storage/storage_intf.ml +++ b/lib/storage/storage_intf.ml @@ -56,6 +56,7 @@ module type S = sig : ?sep:[< `Dot | `Slash > `Slash ] -> ?dimension_names:string option list -> ?attributes:Yojson.Safe.t -> + ?storage_transformers:Extensions.StorageTransformers.t -> ?codecs:Codecs.chain -> shape:int array -> chunks:int array -> diff --git a/lib/util.ml b/lib/util.ml index 616cd07f..b12ab9f7 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -1,13 +1,3 @@ -module ExtPoint = struct - type 'a t = - {name : string - ;configuration : 'a} - - let ( = ) cmp x y = - (x.name = y.name) && - cmp x.configuration y.configuration -end - type ('a, 'b) array_repr = {kind : ('a, 'b) Bigarray.kind ;shape : int array diff --git a/lib/util.mli b/lib/util.mli index 3deea057..58221734 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -5,13 +5,6 @@ type ('a, 'b) array_repr = (** The type summarizing the decoded/encoded representation of a Zarr array or chunk. *) -module ExtPoint : sig - (** The type representing a JSON extension point metadata configuration. *) - - type 'a t = {name : string ; configuration : 'a} - val ( = ) : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool -end - module StrMap : sig include Hashtbl.S with type key = string end (** A hashtable with string keys. *)