Skip to content

Commit b43969c

Browse files
zoj613zoj613
committed
streamline httpstore for sync and lwt
1 parent 1260055 commit b43969c

File tree

8 files changed

+147
-244
lines changed

8 files changed

+147
-244
lines changed

‎zarr-lwt/src/storage.ml‎

Lines changed: 1 addition & 117 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ end
1919

2020
module ZipStore = Zarr.Zip.Make(Deferred)
2121
module MemoryStore = Zarr.Memory.Make(Deferred)
22+
module HttpStore = Zarr.Http.Make(Deferred)(Ezcurl_lwt)
2223

2324
module FilesystemStore = struct
2425
module IO = struct
@@ -337,120 +338,3 @@ module AmazonS3Store = struct
337338

338339
include Zarr.Storage.Make(IO)
339340
end
340-
341-
module HttpStore = struct
342-
exception Not_implemented
343-
exception Request_failed of int * string
344-
open Deferred.Syntax
345-
346-
let raise_error (code, s) =
347-
raise (Request_failed (Curl.int_of_curlCode code, s))
348-
349-
let fold_result = Result.fold ~error:raise_error ~ok:Fun.id
350-
351-
module IO = struct
352-
module Deferred = Deferred
353-
354-
type t =
355-
{tries : int
356-
;base_url : string
357-
;client : Ezcurl_lwt.t
358-
;config : Ezcurl_lwt.Config.t}
359-
360-
let get t key =
361-
let tries = t.tries and client = t.client and config = t.config in
362-
let url = t.base_url ^ key in
363-
let+ res = Ezcurl_lwt.get ~tries ~client ~config ~url () in
364-
match fold_result res with
365-
| {code; body; _} when code = 200 -> body
366-
| {code; body; _} -> raise (Request_failed (code, body))
367-
368-
let size t key = Lwt.catch
369-
(fun () ->
370-
let+ data = get t key in
371-
String.length data)
372-
(function
373-
| Request_failed (404, _) -> Deferred.return 0
374-
| exn -> raise exn)
375-
(*let size t key =
376-
let tries = t.tries and client = t.client and config = t.config in
377-
let url = t.base_url ^ key in
378-
let type' = if String.ends_with ~suffix:".json" key then "json" else "octet-stream" in
379-
let headers = [("Content-Type", "application/" ^ type')] in
380-
let res = Ezcurl.http ~headers ~tries ~client ~config ~url ~meth:HEAD () in
381-
match fold_result res with
382-
| {code; _} when code = 404 -> 0
383-
| {headers; _} ->
384-
match List.assoc_opt "content-length" headers with
385-
| (Some "0" | None) ->
386-
begin try print_endline "empty content-length header"; String.length (get t key) with
387-
| Request_failed (404, _) -> 0 end
388-
| Some l -> int_of_string l *)
389-
390-
let is_member t key =
391-
let+ s = size t key in
392-
if s = 0 then false else true
393-
394-
let get_partial_values t key ranges =
395-
let tries = t.tries and client = t.client and config = t.config and url = t.base_url ^ key in
396-
let fetch range = Ezcurl_lwt.get ~range ~tries ~client ~config ~url () in
397-
let end_index ofs l = Printf.sprintf "%d-%d" ofs (ofs + l - 1) in
398-
let read_range acc (ofs, len) =
399-
let none = Printf.sprintf "%d-" ofs in
400-
let range = Option.fold ~none ~some:(end_index ofs) len in
401-
let+ res = fetch range in
402-
let response = fold_result res in
403-
response.body :: acc
404-
in
405-
Deferred.fold_left read_range [] (List.rev ranges)
406-
407-
let set t key data =
408-
let tries = t.tries and client = t.client and config = t.config
409-
and url = t.base_url ^ key and content = `String data in
410-
let type' = if String.ends_with ~suffix:".json" key then "json" else "octet-stream" in
411-
let headers =
412-
[("Content-Length", string_of_int (String.length data))
413-
;("Content-Type", "application/" ^ type')] in
414-
let+ res = Ezcurl_lwt.post ~params:[] ~headers ~tries ~client ~config ~url ~content () in
415-
match fold_result res with
416-
| {code; _} when code = 200 || code = 201 -> ()
417-
| {code; body; _} -> raise (Request_failed (code, body))
418-
419-
let set_partial_values t key ?(append=false) rsv =
420-
let* size = size t key in
421-
let* ov = match size with
422-
| 0 -> Deferred.return String.empty
423-
| _ -> get t key
424-
in
425-
let f = if append || ov = String.empty then
426-
fun acc (_, v) -> acc ^ v else
427-
fun acc (rs, v) ->
428-
let s = Bytes.unsafe_of_string acc in
429-
Bytes.blit_string v 0 s rs String.(length v);
430-
Bytes.unsafe_to_string s
431-
in
432-
set t key (List.fold_left f ov rsv)
433-
434-
(* make reshaping arrays possible *)
435-
let erase t key =
436-
let tries = t.tries and client = t.client and config = t.config in
437-
let url = t.base_url ^ key in
438-
let+ res = Ezcurl_lwt.http ~tries ~client ~config ~url ~meth:DELETE () in
439-
match fold_result res with
440-
| {code; _} when code = 200 -> ()
441-
| {code; body; _} -> raise (Request_failed (code, body))
442-
443-
let erase_prefix _ = raise Not_implemented
444-
let list _ = raise Not_implemented
445-
let list_dir _ = raise Not_implemented
446-
let rename _ = raise Not_implemented
447-
end
448-
449-
let with_open ?(redirects=5) ?(tries=3) ?(timeout=5) url f =
450-
let config = Ezcurl_lwt.Config.(default |> max_redirects redirects |> follow_location true) in
451-
let perform client = f IO.{tries; client; config; base_url = url ^ "/"} in
452-
let set_opts client = Curl.set_connecttimeout client timeout in
453-
Ezcurl_lwt.with_client ~set_opts perform
454-
455-
include Zarr.Storage.Make(IO)
456-
end

‎zarr-lwt/src/storage.mli‎

Lines changed: 3 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,9 @@ module MemoryStore : Zarr.Memory.S with module Deferred = Deferred
66
(** An Lwt-aware Zip file storage backend for a Zarr v3 hierarchy. *)
77
module ZipStore : Zarr.Zip.S with module Deferred = Deferred
88

9+
(** An Lwt-aware Http storage backend for a Zarr v3 hierarchy. *)
10+
module HttpStore : Zarr.Http.S with module Deferred = Deferred
11+
912
(** An Lwt-aware local filesystem storage backend for a Zarr V3 hierarchy. *)
1013
module FilesystemStore : sig
1114
include Zarr.Storage.STORE with module Deferred = Deferred
@@ -21,19 +24,6 @@ module FilesystemStore : sig
2124
@raise Failure if [dir] is not a Zarr store path. *)
2225
end
2326

24-
module HttpStore : sig
25-
exception Not_implemented
26-
exception Request_failed of int * string
27-
include Zarr.Storage.STORE with module Deferred = Deferred
28-
val with_open :
29-
?redirects:int ->
30-
?tries:int ->
31-
?timeout:int ->
32-
string ->
33-
(t -> 'a Lwt.t) ->
34-
'a Lwt.t
35-
end
36-
3727
(** An Lwt-aware Amazon S3 bucket storage backend for a Zarr V3 hierarchy. *)
3828
module AmazonS3Store : sig
3929
exception Request_failed of Aws_s3_lwt.S3.error

‎zarr-sync/src/storage.ml‎

Lines changed: 1 addition & 107 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ end
1919

2020
module ZipStore = Zarr.Zip.Make(Deferred)
2121
module MemoryStore = Zarr.Memory.Make(Deferred)
22+
module HttpStore = Zarr.Http.Make(Deferred)(Ezcurl)
2223

2324
module FilesystemStore = struct
2425
module IO = struct
@@ -116,110 +117,3 @@ module FilesystemStore = struct
116117

117118
include Zarr.Storage.Make(IO)
118119
end
119-
120-
module HttpStore = struct
121-
exception Not_implemented
122-
exception Request_failed of int * string
123-
124-
let raise_error (code, s) = raise (Request_failed (Curl.int_of_curlCode code, s))
125-
126-
let fold_result = Result.fold ~error:raise_error ~ok:Fun.id
127-
128-
module IO = struct
129-
module Deferred = Deferred
130-
131-
type t =
132-
{tries : int
133-
;base_url : string
134-
;client : Ezcurl_core.t
135-
;config : Ezcurl_core.Config.t}
136-
137-
let get t key =
138-
let tries = t.tries and client = t.client and config = t.config in
139-
let url = t.base_url ^ key in
140-
let res = Ezcurl.get ~tries ~client ~config ~url () in
141-
match fold_result res with
142-
| {code; body; _} when code = 200 -> body
143-
| {code; body; _} -> raise (Request_failed (code, body))
144-
145-
let size t key = try String.length (get t key) with
146-
| Request_failed (404, _) -> 0
147-
(*let size t key =
148-
let tries = t.tries and client = t.client and config = t.config in
149-
let url = t.base_url ^ key in
150-
let type' = if String.ends_with ~suffix:".json" key then "json" else "octet-stream" in
151-
let headers = [("Content-Type", "application/" ^ type')] in
152-
let res = Ezcurl.http ~headers ~tries ~client ~config ~url ~meth:HEAD () in
153-
match fold_result res with
154-
| {code; _} when code = 404 -> 0
155-
| {headers; _} ->
156-
match List.assoc_opt "content-length" headers with
157-
| (Some "0" | None) ->
158-
begin try print_endline "empty content-length header"; String.length (get t key) with
159-
| Request_failed (404, _) -> 0 end
160-
| Some l -> int_of_string l *)
161-
162-
let is_member t key = if (size t key) = 0 then false else true
163-
164-
let get_partial_values t key ranges =
165-
let tries = t.tries and client = t.client and config = t.config and url = t.base_url ^ key in
166-
let fetch range = Ezcurl.get ~range ~tries ~client ~config ~url () in
167-
let end_index ofs l = Printf.sprintf "%d-%d" ofs (ofs + l - 1) in
168-
let read_range (ofs, len) =
169-
let none = Printf.sprintf "%d-" ofs in
170-
let range = Option.fold ~none ~some:(end_index ofs) len in
171-
let response = fold_result (fetch range) in
172-
response.body
173-
in
174-
List.map read_range ranges
175-
176-
let set t key data =
177-
let tries = t.tries and client = t.client and config = t.config
178-
and url = t.base_url ^ key and content = `String data in
179-
let type' = if String.ends_with ~suffix:".json" key then "json" else "octet-stream" in
180-
let headers =
181-
[("Content-Length", string_of_int (String.length data))
182-
;("Content-Type", "application/" ^ type')] in
183-
let res = Ezcurl.post ~params:[] ~headers ~tries ~client ~config ~url ~content () in
184-
match fold_result res with
185-
| {code; _} when code = 200 || code = 201 -> ()
186-
| {code; body; _} -> raise (Request_failed (code, body))
187-
188-
let set_partial_values t key ?(append=false) rsv =
189-
let size = size t key in
190-
let ov = match size with
191-
| 0 -> String.empty
192-
| _ -> get t key
193-
in
194-
let f = if append || ov = String.empty then
195-
fun acc (_, v) -> acc ^ v else
196-
fun acc (rs, v) ->
197-
let s = Bytes.unsafe_of_string acc in
198-
Bytes.blit_string v 0 s rs String.(length v);
199-
Bytes.unsafe_to_string s
200-
in
201-
set t key (List.fold_left f ov rsv)
202-
203-
(* make reshaping arrays possible *)
204-
let erase t key =
205-
let tries = t.tries and client = t.client and config = t.config in
206-
let url = t.base_url ^ key in
207-
let res = Ezcurl.http ~tries ~client ~config ~url ~meth:DELETE () in
208-
match fold_result res with
209-
| {code; _} when code = 200 -> ()
210-
| {code; body; _} -> raise (Request_failed (code, body))
211-
212-
let erase_prefix _ = raise Not_implemented
213-
let list _ = raise Not_implemented
214-
let list_dir _ = raise Not_implemented
215-
let rename _ = raise Not_implemented
216-
end
217-
218-
let with_open ?(redirects=5) ?(tries=3) ?(timeout=5) url f =
219-
let config = Ezcurl_core.Config.(default |> max_redirects redirects |> follow_location true) in
220-
let perform client = f IO.{tries; client; config; base_url = url ^ "/"} in
221-
let set_opts client = Curl.set_connecttimeout client timeout in
222-
Ezcurl_core.with_client ~set_opts perform
223-
224-
include Zarr.Storage.Make(IO)
225-
end

‎zarr-sync/src/storage.mli‎

Lines changed: 3 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,9 @@ module MemoryStore : Zarr.Memory.S with module Deferred = Deferred
66
(** A blocking I/O Zip file storage backend for a Zarr v3 hierarchy. *)
77
module ZipStore : Zarr.Zip.S with module Deferred = Deferred
88

9+
(** A blocking I/O Http storage backend for a Zarr v3 hierarchy. *)
10+
module HttpStore : Zarr.Http.S with module Deferred = Deferred
11+
912
(** A blocking I/O local filesystem storage backend for a Zarr v3 hierarchy. *)
1013
module FilesystemStore : sig
1114
include Zarr.Storage.STORE with module Deferred = Deferred
@@ -20,10 +23,3 @@ module FilesystemStore : sig
2023
2124
@raise Failure if [dir] is not a Zarr store path. *)
2225
end
23-
24-
module HttpStore : sig
25-
exception Not_implemented
26-
exception Request_failed of int * string
27-
include Zarr.Storage.STORE with module Deferred = Deferred
28-
val with_open : ?redirects:int -> ?tries:int -> ?timeout:int -> string -> (t -> 'a) -> 'a
29-
end

‎zarr/src/dune‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
bytesrw.zstd
77
bytesrw.zlib
88
zipc
9+
ezcurl
910
stdint
1011
checkseum)
1112
(ocamlopt_flags

0 commit comments

Comments
 (0)