simon/ezcurl
1
0
Fork 0
mirror of https://github.com/c-cube/ezcurl.git synced 2025-12-06 03:05:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

ocamlformat

Browse source
This commit is contained in:
Simon Cruanes 2023-06-09 21:06:20 -04:00
parent 73899acdf2
commit be03f25cc0
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
6 changed files with 207 additions and 185 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
.ocamlformat Normal file
View file

@ -0,0 +1,15 @@
version = 0.24.1
profile=conventional
margin=80
if-then-else=k-r
parens-ite=true
parens-tuple=multi-line-only
sequence-style=terminator
type-decl=sparse
break-cases=toplevel
cases-exp-indent=2
field-space=tight-decl
leading-nested-match-parens=true
module-item-spacing=compact
quiet=true
ocaml-version=4.08.0

229
src/core/Ezcurl_core.ml
View file

@ -1,4 +1,6 @@
let opt_iter ~f = function None -> () | Some x -> f x
let opt_iter ~f = function
| None -> ()
| Some x -> f x
module Config = struct
type t = {
@ -11,22 +13,23 @@ module Config = struct
user_agent: string option;
}
let default : t = {
verbose=false;
let default : t =
{
verbose = false;
max_redirects = 50;
follow_location=true;
authmethod=None;
username=None;
password=None;
user_agent=Some "curl";
follow_location = true;
authmethod = None;
username = None;
password = None;
user_agent = Some "curl";
}
let password x self = {self with password=Some x}
let username x self = {self with username=Some x}
let verbose x self = { self with verbose=x}
let follow_location x self = {self with follow_location=x}
let max_redirects x self = {self with max_redirects=max 1 x}
let authmethod x self = {self with authmethod=Some x}
let password x self = { self with password = Some x }
let username x self = { self with username = Some x }
let verbose x self = { self with verbose = x }
let follow_location x self = { self with follow_location = x }
let max_redirects x self = { self with max_redirects = max 1 x }
let authmethod x self = { self with authmethod = Some x }
let string_of_authmethod = function
| Curl.CURLAUTH_ANY -> "any"
@ -40,31 +43,39 @@ module Config = struct
| None -> "<none>"
| Some s -> s
let pp out (self:t) =
let pp out (self : t) =
let {
verbose; authmethod; max_redirects; follow_location;
username; password; user_agent
} = self in
verbose;
authmethod;
max_redirects;
follow_location;
username;
password;
user_agent;
} =
self
in
Format.fprintf out
"{@[verbose=%B;@ max_redirects=%d;@ follow_location=%B;@ \
username=%s;@ password=%s;@ authmethod=%s;@ user_agent=%s@]}"
verbose max_redirects follow_location
(str_of_str_opt username) (str_of_str_opt password)
"{@[verbose=%B;@ max_redirects=%d;@ follow_location=%B;@ username=%s;@ \
password=%s;@ authmethod=%s;@ user_agent=%s@]}"
verbose max_redirects follow_location (str_of_str_opt username)
(str_of_str_opt password)
(match authmethod with
| None -> "none"
| Some l -> List.map string_of_authmethod l |> String.concat ",") (str_of_str_opt user_agent)
| Some l -> List.map string_of_authmethod l |> String.concat ",")
(str_of_str_opt user_agent)
let to_string s = Format.asprintf "%a" pp s
end
type t = Curl.t
let _init = lazy (
Curl.global_init Curl.CURLINIT_GLOBALALL;
at_exit Curl.global_cleanup;
)
let _init =
lazy
(Curl.global_init Curl.CURLINIT_GLOBALALL;
at_exit Curl.global_cleanup)
let make ?(set_opts=fun _ -> ()) () : t =
let make ?(set_opts = fun _ -> ()) () : t =
Lazy.force _init;
let c = Curl.init () in
Gc.finalise Curl.cleanup c;
@ -74,11 +85,18 @@ let make ?(set_opts=fun _ -> ()) () : t =
let delete = Curl.cleanup
(* set options *)
let _apply_config (self:t) (config:Config.t) : unit =
let _apply_config (self : t) (config : Config.t) : unit =
let {
Config.verbose; max_redirects; follow_location; authmethod;
username; password; user_agent
} = config in
Config.verbose;
max_redirects;
follow_location;
authmethod;
username;
password;
user_agent;
} =
config
in
Curl.set_verbose self verbose;
Curl.set_maxredirs self max_redirects;
Curl.set_followlocation self follow_location;
@ -88,10 +106,8 @@ let _apply_config (self:t) (config:Config.t) : unit =
opt_iter password ~f:(Curl.set_password self);
()
let _set_headers (self:t) (headers: _ list) : unit =
let headers =
List.map (fun (k,v) -> k ^ ": " ^ v) headers
in
let _set_headers (self : t) (headers : _ list) : unit =
let headers = List.map (fun (k, v) -> k ^ ": " ^ v) headers in
Curl.set_httpheader self headers;
()
@ -111,7 +127,7 @@ type response_info = {
}
let pp_response_info out r =
let {ri_response_time; ri_redirect_count} = r in
let { ri_response_time; ri_redirect_count } = r in
Format.fprintf out "{@[response_time=%.3fs;@ redirect_count=%d@]}"
ri_response_time ri_redirect_count
@ -125,17 +141,13 @@ type response = {
}
let pp_response out r =
let pp_header out (s1,s2) =
Format.fprintf out "@[<2>%s:@ %s@]" s1 s2
in
let pp_header out (s1, s2) = Format.fprintf out "@[<2>%s:@ %s@]" s1 s2 in
let pp_headers out l =
Format.fprintf out "@[<v>%a@]" (Format.pp_print_list pp_header) l
in
let {code; body; headers; info; } = r in
let { code; body; headers; info } = r in
Format.fprintf out "{@[code=%d;@ headers=@[%a@];@ info=%a;@ body=@[%a@]@]}"
code pp_headers headers pp_response_info info
Format.pp_print_text body
code pp_headers headers pp_response_info info Format.pp_print_text body
let string_of_response s = Format.asprintf "%a" pp_response s
@ -165,9 +177,10 @@ let pp_meth out m = Format.pp_print_string out (string_of_meth m)
module type IO = sig
type 'a t
val return : 'a -> 'a t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t
val fail : exn -> 'a t
val perform : Curl.t -> Curl.curlCode t
end
@ -180,8 +193,8 @@ module type S = sig
?client:t ->
?config:Config.t ->
?range:string ->
?content:[`String of string | `Write of (bytes -> int -> int)] ->
?headers:(string*string) list ->
?content:[ `String of string | `Write of bytes -> int -> int ] ->
?headers:(string * string) list ->
url:string ->
meth:meth ->
unit ->
@ -211,7 +224,7 @@ module type S = sig
?client:t ->
?config:Config.t ->
?range:string ->
?headers:(string*string) list ->
?headers:(string * string) list ->
url:string ->
unit ->
(response, Curl.curlCode * string) result io
@ -223,9 +236,9 @@ module type S = sig
?tries:int ->
?client:t ->
?config:Config.t ->
?headers:(string*string) list ->
?headers:(string * string) list ->
url:string ->
content:[`String of string | `Write of (bytes -> int -> int)] ->
content:[ `String of string | `Write of bytes -> int -> int ] ->
unit ->
(response, Curl.curlCode * string) result io
(** Shortcut for [http ~meth:PUT]
@ -236,8 +249,8 @@ module type S = sig
?tries:int ->
?client:t ->
?config:Config.t ->
?headers:(string*string) list ->
?content:[`String of string | `Write of (bytes -> int -> int)] ->
?headers:(string * string) list ->
?content:[ `String of string | `Write of bytes -> int -> int ] ->
params:Curl.curlHTTPPost list ->
url:string ->
unit ->
@ -249,33 +262,34 @@ end
exception Parse_error of Curl.curlCode * string
let mk_res (self:t) headers body : (response,_) result =
let mk_res (self : t) headers body : (response, _) result =
let split_colon s =
match String.index s ':' with
| exception Not_found ->
raise (Parse_error (Curl.CURLE_CONV_FAILED, "header line without a ':': " ^ s))
raise
(Parse_error (Curl.CURLE_CONV_FAILED, "header line without a ':': " ^ s))
| i ->
String.sub s 0 i,
String.trim (String.sub s (i+1) (String.length s-i-1))
( String.sub s 0 i,
String.trim (String.sub s (i + 1) (String.length s - i - 1)) )
in
try
let code = Curl.get_httpcode self in
let headers =
match headers with
| [] -> []
| _ :: tl -> List.map split_colon tl (* first one is "http1.1 NNN <descr>" *)
| _ :: tl ->
List.map split_colon tl (* first one is "http1.1 NNN <descr>" *)
in
let info = {
ri_redirect_count=Curl.get_redirectcount self;
ri_response_time=Curl.get_totaltime self;
} in
Ok {headers; code; body; info}
with Parse_error (e, msg) ->
Error (e, Curl.strerror e ^ ": " ^ msg)
let info =
{
ri_redirect_count = Curl.get_redirectcount self;
ri_response_time = Curl.get_totaltime self;
}
in
Ok { headers; code; body; info }
with Parse_error (e, msg) -> Error (e, Curl.strerror e ^ ": " ^ msg)
module Make(IO : IO)
: S with type 'a io = 'a IO.t
= struct
module Make (IO : IO) : S with type 'a io = 'a IO.t = struct
open IO
type 'a io = 'a IO.t
@ -284,90 +298,83 @@ module Make(IO : IO)
match content with
| `String s ->
let n = ref 0 in
(fun i ->
fun i ->
let len = min i (String.length s - !n) in
let r = String.sub s !n len in
n := !n + len;
r)
r
| `Write f ->
let buf = Bytes.create 1024 in
(fun i ->
fun i ->
let len = min i (Bytes.length buf) in
let n = f buf len in
Bytes.sub_string buf i n)
Bytes.sub_string buf i n
let content_size_ = function
| `String s -> Some (String.length s)
| `Write _ -> None
let http
?(tries=1) ?client ?(config=Config.default) ?range ?content ?(headers=[]) ~url ~meth ()
: _ result io =
let http ?(tries = 1) ?client ?(config = Config.default) ?range ?content
?(headers = []) ~url ~meth () : _ result io =
let headers = ref headers in
let do_cleanup, self = match client with
| None -> true, make()
| Some c ->
false, c
let do_cleanup, self =
match client with
| None -> true, make ()
| Some c -> false, c
in
_apply_config self config;
opt_iter range ~f:(fun s -> Curl.set_range self s);
(* TODO: ability to make content a stream with a `read` function *)
opt_iter content
~f:(fun content ->
opt_iter content ~f:(fun content ->
Curl.set_readfunction self (content_read_fun_ content);
(* also set size if known *)
match content_size_ content, meth with
| None, _ ->
headers := ("expect", "") :: ("transfer-encoding", "chunked") :: !headers
| Some size , POST _ ->
Curl.set_postfieldsize self size;
| Some size, _ ->
Curl.set_infilesize self size
);
headers :=
("expect", "") :: ("transfer-encoding", "chunked") :: !headers
| Some size, POST _ -> Curl.set_postfieldsize self size
| Some size, _ -> Curl.set_infilesize self size);
(* local state *)
let tries = max tries 1 in (* at least one attempt *)
let tries = max tries 1 in
(* at least one attempt *)
let body = Buffer.create 64 in
let resp_headers = ref [] in
let resp_headers_done = ref false in (* once we get "\r\n" header line *)
let resp_headers_done = ref false in
(* once we get "\r\n" header line *)
Curl.set_url self url;
begin match meth with
| POST [] when (content <> None) ->
Curl.set_post self true
| POST l ->
Curl.set_httppost self l;
| GET -> Curl.set_httpget self true;
(match meth with
| POST [] when content <> None -> Curl.set_post self true
| POST l -> Curl.set_httppost self l
| GET -> Curl.set_httpget self true
| PUT ->
Curl.set_customrequest self "PUT";
Curl.set_upload self true;
| DELETE -> Curl.set_customrequest self "DELETE";
Curl.set_upload self true
| DELETE -> Curl.set_customrequest self "DELETE"
| HEAD -> Curl.set_customrequest self "HEAD"
| CONNECT -> Curl.set_customrequest self "CONNECT"
| OPTIONS -> Curl.set_customrequest self "OPTIONS"
| TRACE -> Curl.set_customrequest self "TRACE"
| PATCH -> Curl.set_customrequest self "PATCH"
end;
| PATCH -> Curl.set_customrequest self "PATCH");
_set_headers self !headers;
Curl.set_headerfunction self
(fun s0 ->
Curl.set_headerfunction self (fun s0 ->
let s = String.trim s0 in
(* Printf.printf "got header %S\n%!" s0; *)
if s0 = "\r\n" then (
resp_headers_done := true;
) else (
if s0 = "\r\n" then
resp_headers_done := true
else (
(* redirection: drop previous headers *)
if !resp_headers_done then (
resp_headers_done := false;
resp_headers := [];
resp_headers := []
);
resp_headers := s :: !resp_headers;
resp_headers := s :: !resp_headers
);
String.length s0);
Curl.set_writefunction self
(fun s ->
Curl.set_writefunction self (fun s ->
Buffer.add_string body s;
String.length s);
let rec loop i =
@ -376,8 +383,7 @@ module Make(IO : IO)
let r = mk_res self (List.rev !resp_headers) (Buffer.contents body) in
if do_cleanup then Curl.cleanup self;
return r
| Curl.CURLE_AGAIN when i > 1 ->
loop (i-1) (* try again *)
| Curl.CURLE_AGAIN when i > 1 -> loop (i - 1) (* try again *)
| c ->
if do_cleanup then Curl.cleanup self;
return (Error (c, Curl.strerror c))
@ -387,7 +393,8 @@ module Make(IO : IO)
let get ?tries ?client ?config ?range ?headers ~url () : _ result io =
http ?tries ?client ?config ?range ?headers ~url ~meth:GET ()
let post ?tries ?client ?config ?headers ?content ~params ~url () : _ result io =
let post ?tries ?client ?config ?headers ?content ~params ~url () :
_ result io =
http ?tries ?client ?config ?headers ?content ~url ~meth:(POST params) ()
let put ?tries ?client ?config ?headers ~url ~content () : _ result io =

47
src/core/Ezcurl_core.mli
View file

@ -1,9 +1,9 @@
(** Core signatures and implementation *)
(** Configuration for the client. *)
module Config : sig
type t
val default : t
val verbose : bool -> t -> t
val authmethod : Curl.curlAuth list -> t -> t
@ -11,7 +11,6 @@ module Config : sig
val follow_location : bool -> t -> t
val username : string -> t -> t
val password : string -> t -> t
val pp : Format.formatter -> t -> unit
val to_string : t -> string
end
@ -19,23 +18,19 @@ end
type t = Curl.t
(** A client, i.e. a cURL instance. *)
val make :
?set_opts:(t -> unit) ->
unit -> t
(** Create a new client.
val make : ?set_opts:(t -> unit) -> unit -> t
(** Create a new client.
@param set_opts called before returning the client, to set options *)
val delete : t -> unit
(** Delete the client. It cannot be used anymore. *)
val with_client :
?set_opts:(t -> unit) ->
(t -> 'a) -> 'a
val with_client : ?set_opts:(t -> unit) -> (t -> 'a) -> 'a
(** Make a temporary client, call the function with it, then cleanup. *)
(* TODO: duphandle is deprecated, how do we iterate on options?
val copy : t -> t
*)
val copy : t -> t
*)
type response_info = {
ri_response_time: float;
@ -53,12 +48,9 @@ val string_of_response_info : response_info -> string
type response = {
code: int;
(** Response code. See https://developer.mozilla.org/en-US/docs/Web/HTTP/Status *)
headers: (string * string) list;
(** Response headers *)
body: string;
(** Response body, or [""] *)
info: response_info;
(** Information about the response *)
headers: (string * string) list; (** Response headers *)
body: string; (** Response body, or [""] *)
info: response_info; (** Information about the response *)
}
(** Response for a given request. *)
@ -84,9 +76,10 @@ val string_of_meth : meth -> string
(** {2 Underlying IO Monad} *)
module type IO = sig
type 'a t
val return : 'a -> 'a t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t
val fail : exn -> 'a t
val perform : Curl.t -> Curl.curlCode t
end
@ -100,8 +93,8 @@ module type S = sig
?client:t ->
?config:Config.t ->
?range:string ->
?content:[`String of string | `Write of (bytes -> int -> int)] ->
?headers:(string*string) list ->
?content:[ `String of string | `Write of bytes -> int -> int ] ->
?headers:(string * string) list ->
url:string ->
meth:meth ->
unit ->
@ -131,7 +124,7 @@ module type S = sig
?client:t ->
?config:Config.t ->
?range:string ->
?headers:(string*string) list ->
?headers:(string * string) list ->
url:string ->
unit ->
(response, Curl.curlCode * string) result io
@ -143,9 +136,9 @@ module type S = sig
?tries:int ->
?client:t ->
?config:Config.t ->
?headers:(string*string) list ->
?headers:(string * string) list ->
url:string ->
content:[`String of string | `Write of (bytes -> int -> int)] ->
content:[ `String of string | `Write of bytes -> int -> int ] ->
unit ->
(response, Curl.curlCode * string) result io
(** Shortcut for [http ~meth:PUT]
@ -156,8 +149,8 @@ module type S = sig
?tries:int ->
?client:t ->
?config:Config.t ->
?headers:(string*string) list ->
?content:[`String of string | `Write of (bytes -> int -> int)] ->
?headers:(string * string) list ->
?content:[ `String of string | `Write of bytes -> int -> int ] ->
params:Curl.curlHTTPPost list ->
url:string ->
unit ->
@ -167,4 +160,4 @@ module type S = sig
*)
end
module Make(IO : IO) : S with type 'a io = 'a IO.t
module Make (IO : IO) : S with type 'a io = 'a IO.t

4
src/lwt/Ezcurl_lwt.ml
View file

@ -1,7 +1,7 @@
include Ezcurl_core
include Make(struct
include Make (struct
include Lwt
let perform = Curl_lwt.perform
end)

23
src/sync/Ezcurl.ml
View file

@ -1,16 +1,19 @@
(** {1 Synchronous API} *)
include Ezcurl_core
include Ezcurl_core.Make(struct
include Ezcurl_core.Make (struct
type 'a t = 'a
let return x = x
let (>>=) x f = f x
let (>|=) x f = f x
let fail e = raise e
let perform c =
try Curl.perform c; Curl.CURLE_OK
with Curl.CurlException (c, _, _) -> c
end)
let return x = x
let ( >>= ) x f = f x
let ( >|= ) x f = f x
let fail e = raise e
let perform c =
try
Curl.perform c;
Curl.CURLE_OK
with Curl.CurlException (c, _, _) -> c
end)

10
test/basic_test.ml
View file

@ -1,6 +1,10 @@
let () =
match Ezcurl.get ~url:"https://archive.softwareheritage.org/api/1/content/sha1_git:7bdf38d4468c114206c9b6ebd9cf1176e085d346/" () with
match
Ezcurl.get
~url:
"https://archive.softwareheritage.org/api/1/content/sha1_git:7bdf38d4468c114206c9b6ebd9cf1176e085d346/"
()
with
| Error (code, msg) ->
Format.eprintf "curl error: code `%s` (%s)@." (Curl.strerror code) msg
| Ok _response ->
Format.printf "OK@."
| Ok _response -> Format.printf "OK@."