From c3666897cafde27a272ed4fdfba7f5ad80ee7346 Mon Sep 17 00:00:00 2001 From: Zolisa Bleki Date: Wed, 25 Dec 2024 21:27:43 +0200 Subject: [PATCH] more updates for IO --- zarr-eio/src/storage.ml | 9 ++++---- zarr-eio/src/storage.mli | 2 +- zarr-eio/test/test_eio.ml | 2 +- zarr-lwt/src/storage.mli | 2 +- zarr-lwt/test/test_lwt.ml | 12 +++++----- zarr-sync/src/storage.mli | 2 +- zarr-sync/test/test_sync.ml | 2 +- zarr/src/storage/http.ml | 45 +++++++++++++++++-------------------- 8 files changed, 36 insertions(+), 40 deletions(-) diff --git a/zarr-eio/src/storage.ml b/zarr-eio/src/storage.ml index 1b59861..0922d61 100644 --- a/zarr-eio/src/storage.ml +++ b/zarr-eio/src/storage.ml @@ -146,10 +146,9 @@ module HttpStore = struct raise (Zarr.Storage.Key_not_found key) | e -> raise_status_error e - module IO = struct - module Deferred = Deferred - + module S = struct type t = {base_url : Uri.t; client : Client.t} + type 'a io = 'a IO.t let get t key = Eio.Switch.run @@ fun sw -> @@ -220,7 +219,7 @@ module HttpStore = struct let with_open ?https ~net uri f = let client = Client.make ~https net in - f IO.{client; base_url = uri} + f S.{client; base_url = uri} - include Zarr.Storage.Make(IO) + include Zarr.Storage.Make(IO)(S) end diff --git a/zarr-eio/src/storage.mli b/zarr-eio/src/storage.mli index 5369904..d36a8af 100644 --- a/zarr-eio/src/storage.mli +++ b/zarr-eio/src/storage.mli @@ -24,7 +24,7 @@ end module HttpStore : sig exception Not_implemented exception Request_failed of int * string - include Zarr.Storage.STORE with module Deferred = Deferred + include Zarr.Storage.S with type 'a io := 'a val with_open : ?https:(Uri.t -> [ `Generic ] Eio.Net.stream_socket_ty Eio.Std.r -> _ Eio.Flow.two_way) -> net:_ Eio.Net.t -> diff --git a/zarr-eio/test/test_eio.ml b/zarr-eio/test/test_eio.ml index f907d7c..3d2a849 100644 --- a/zarr-eio/test/test_eio.ml +++ b/zarr-eio/test/test_eio.ml @@ -117,7 +117,7 @@ let test_storage module type SYNC_PARTIAL_STORE = sig exception Not_implemented - include Zarr.Storage.STORE with type 'a Deferred.t = 'a + include Zarr.Storage.S with type 'a io := 'a end let test_readable_writable_only diff --git a/zarr-lwt/src/storage.mli b/zarr-lwt/src/storage.mli index 6c0189f..34a7ced 100644 --- a/zarr-lwt/src/storage.mli +++ b/zarr-lwt/src/storage.mli @@ -7,7 +7,7 @@ module MemoryStore : Zarr.Memory.S with type 'a io := 'a Lwt.t module ZipStore : Zarr.Zip.S with type 'a io := 'a Lwt.t (** An Lwt-aware Http storage backend for a Zarr v3 hierarchy. *) -module HttpStore : Zarr.Http.S with module Deferred = Deferred +module HttpStore : Zarr.Http.S with type 'a io := 'a Lwt.t (** An Lwt-aware local filesystem storage backend for a Zarr V3 hierarchy. *) module FilesystemStore : sig diff --git a/zarr-lwt/test/test_lwt.ml b/zarr-lwt/test/test_lwt.ml index 8f3f61a..8cc6d4d 100644 --- a/zarr-lwt/test/test_lwt.ml +++ b/zarr-lwt/test/test_lwt.ml @@ -116,18 +116,18 @@ let test_storage module type SYNC_PARTIAL_STORE = sig exception Not_implemented - include Zarr.Storage.STORE with type 'a Deferred.t = 'a Lwt.t + include Zarr.Storage.S with type 'a io := 'a Lwt.t end let test_readable_writable_only (type a) (module M : SYNC_PARTIAL_STORE with type t = a) (store : a) = let open M in - let open Deferred.Syntax in + let open IO.Syntax in let assert_not_implemented f = Lwt.catch - (fun () -> let* _ = f () in Deferred.return_unit) + (fun () -> let* _ = f () in IO.return_unit) (function - | Not_implemented -> Deferred.return_unit + | Not_implemented -> IO.return_unit | _ -> failwith "Supposed to raise Not_implemented") in let gnode = Node.Group.root in @@ -172,7 +172,7 @@ let test_readable_writable_only let* () = assert_not_implemented (fun () -> hierarchy store) in let* () = assert_not_implemented (fun () -> Group.delete store gnode) in let* () = assert_not_implemented (fun () -> clear store) in - Deferred.return_unit + IO.return_unit module Dir_http_server = struct module S = Tiny_httpd @@ -244,7 +244,7 @@ module Dir_http_server = struct let perform () = let _ = Thread.create S.run_exn t in Lwt.dont_wait after_init raise; - Deferred.return_unit + IO.return_unit in Fun.protect ~finally:(fun () -> S.stop t) perform end diff --git a/zarr-sync/src/storage.mli b/zarr-sync/src/storage.mli index 9b18efd..e74eaa2 100644 --- a/zarr-sync/src/storage.mli +++ b/zarr-sync/src/storage.mli @@ -7,7 +7,7 @@ module MemoryStore : Zarr.Memory.S with type 'a io := 'a module ZipStore : Zarr.Zip.S with type 'a io := 'a (** A blocking I/O Http storage backend for a Zarr v3 hierarchy. *) -module HttpStore : Zarr.Http.S with module Deferred = Deferred +module HttpStore : Zarr.Http.S with type 'a io := 'a (** A blocking I/O local filesystem storage backend for a Zarr v3 hierarchy. *) module FilesystemStore : sig diff --git a/zarr-sync/test/test_sync.ml b/zarr-sync/test/test_sync.ml index 989fd57..e467f01 100644 --- a/zarr-sync/test/test_sync.ml +++ b/zarr-sync/test/test_sync.ml @@ -165,7 +165,7 @@ let test_storage module type SYNC_PARTIAL_STORE = sig exception Not_implemented - include Zarr.Storage.STORE with type 'a Deferred.t = 'a + include Zarr.Storage.S with type 'a io := 'a end let test_readable_writable_only diff --git a/zarr/src/storage/http.ml b/zarr/src/storage/http.ml index 94ebe90..bc374fc 100644 --- a/zarr/src/storage/http.ml +++ b/zarr/src/storage/http.ml @@ -1,7 +1,7 @@ module type S = sig exception Not_implemented exception Request_failed of int * string - include Storage.STORE + include Storage.S type auth = {user : string; pwd : string} @@ -11,8 +11,8 @@ module type S = sig ?tries:int -> ?timeout:int -> string -> - (t -> 'a Deferred.t) -> - 'a Deferred.t + (t -> 'a io) -> + 'a io (** [with_open url f] connects to the Zarr store described by the url [url] and applies function [f] to the store's open handle. @@ -37,20 +37,17 @@ module type C = sig include Ezcurl_core.S end -module Make - (Deferred : Types.Deferred) - (C : C with type 'a io = 'a Deferred.t) : S with module Deferred = Deferred = struct +module Make (IO : Types.IO) (C : C with type 'a io = 'a IO.t) : S with type 'a io := 'a IO.t = struct exception Not_implemented exception Request_failed of int * string - open Deferred.Syntax + open IO.Syntax let raise_error (code, s) = raise (Request_failed (Curl.int_of_curlCode code, s)) let fold_result = Result.fold ~error:raise_error ~ok:Fun.id - module IO = struct - module Deferred = Deferred - + module Store = struct type t = {tries : int; client : C.t; base_url : string; config : Ezcurl_core.Config.t} + type 'a io = 'a IO.t let get t key = let tries = t.tries and client = t.client and config = t.config in @@ -60,8 +57,8 @@ module Make | {code; body; _} when code = 200 -> body | {code; body; _} -> raise (Request_failed (code, body)) - let size t key = try Deferred.map String.length (get t key) with - | Request_failed (404, _) -> Deferred.return 0 + let size t key = try IO.map String.length (get t key) with + | Request_failed (404, _) -> IO.return 0 (*let size t key = let tries = t.tries and client = t.client and config = t.config in let url = t.base_url ^ key in @@ -69,20 +66,20 @@ module Make let headers = [("Content-Type", "application/" ^ type')] in let* res = C.http ~headers ~tries ~client ~config ~url ~meth:HEAD () in match res with - | Error _ -> Deferred.return 0 - | Ok {code; _} when code = 404 -> Deferred.return 0 + | Error _ -> IO.return 0 + | Ok {code; _} when code = 404 -> IO.return 0 | Ok {headers; code; _} when code = 200 -> begin match List.assoc_opt "content-length" headers with - | Some "0" -> Deferred.return 0 - | Some l -> Deferred.return @@ int_of_string l + | Some "0" -> IO.return 0 + | Some l -> IO.return @@ int_of_string l | None -> begin try print_endline "empty content-length header"; - Deferred.map String.length (get t key) with - | Request_failed (404, _) -> Deferred.return 0 end + IO.map String.length (get t key) with + | Request_failed (404, _) -> IO.return 0 end end | Ok {code; body; _} -> raise (Request_failed (code, body)) *) - let is_member t key = Deferred.map (fun s -> if s > 0 then true else false) (size t key) + let is_member t key = IO.map (fun s -> if s > 0 then true else false) (size t key) let get_partial_values t key ranges = let tries = t.tries and client = t.client and config = t.config and url = t.base_url ^ key in @@ -91,9 +88,9 @@ module Make let read_range acc (ofs, len) = let none = Printf.sprintf "%d-" ofs in let range = Option.fold ~none ~some:(end_index ofs) len in - Deferred.map (fun r -> (fold_result r).body :: acc) (fetch range) + IO.map (fun r -> (fold_result r).body :: acc) (fetch range) in - Deferred.fold_left read_range [] (List.rev ranges) + IO.fold_left read_range [] (List.rev ranges) let set t key data = let tries = t.tries and client = t.client and config = t.config @@ -110,7 +107,7 @@ module Make let set_partial_values t key ?(append=false) rsv = let* size = size t key in let* ov = match size with - | 0 -> Deferred.return String.empty + | 0 -> IO.return String.empty | _ -> get t key in let f = if append || ov = String.empty then @@ -149,9 +146,9 @@ module Make |> Ezcurl_core.Config.username basic_auth.user |> Ezcurl_core.Config.password basic_auth.pwd in - f IO.{tries; client; config; base_url = url ^ "/"} + f Store.{tries; client; config; base_url = url ^ "/"} in C.with_client ~set_opts perform - include Storage.Make(IO) + include Storage.Make(IO)(Store) end