From b9278a5ca2738b39f90842a934567d7200f03a88 Mon Sep 17 00:00:00 2001 From: Kyle Robbertze Date: Thu, 18 Jan 2024 13:16:58 +0000 Subject: New upstream version 1.0.2 --- CHANGES | 7 +++ cry.opam | 2 +- dune-project | 2 +- src/cry.ml | 68 +++++++++++++++++++++-------- src/cry.mli | 15 ++++++- src/cry_stubs.c | 131 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/dune | 3 ++ 7 files changed, 205 insertions(+), 23 deletions(-) create mode 100644 src/cry_stubs.c diff --git a/CHANGES b/CHANGES index f3f79d0..aed4890 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,10 @@ +1.0.2 (2024-01-08) +====== +* Use `poll` for select when available. +* Make sure `close` call always closes the socket. +* Add option to prevert ipv4 over ipv6. Defer to system + defaults otherwise. + 1.0.1 (2023-07-01) ===== * Fix wrong transport being used when updating metadata. diff --git a/cry.opam b/cry.opam index c36b504..3316d79 100644 --- a/cry.opam +++ b/cry.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "1.0.1" +version: "1.0.2" synopsis: "OCaml client for the various icecast & shoutcast source protocols" description: "The cry library is an implementation of the various icecast & shoutcast protocols to connect to streaming servers such as icecast" diff --git a/dune-project b/dune-project index 59b4dec..b202341 100644 --- a/dune-project +++ b/dune-project @@ -1,5 +1,5 @@ (lang dune 2.8) -(version 1.0.1) +(version 1.0.2) (name cry) (source (github savonet/ocaml-cry)) (license GPL-2.0-only) diff --git a/src/cry.ml b/src/cry.ml index 8580ebd..7c6b223 100644 --- a/src/cry.ml +++ b/src/cry.ml @@ -20,6 +20,23 @@ (** OCaml low level implementation of the shout source protocol. *) +external poll : + Unix.file_descr array -> + Unix.file_descr array -> + Unix.file_descr array -> + float -> + Unix.file_descr array * Unix.file_descr array * Unix.file_descr array + = "caml_cry_poll" + +let poll r w e timeout = + let r = Array.of_list r in + let w = Array.of_list w in + let e = Array.of_list e in + let r, w, e = poll r w e timeout in + (Array.to_list r, Array.to_list w, Array.to_list e) + +let select = match Sys.os_type with "Unix" -> poll | _ -> Unix.select + type error = | Create of exn | Connect of exn @@ -52,7 +69,13 @@ and transport = < name : string ; protocol : string ; default_port : int - ; connect : ?bind_address:string -> ?timeout:float -> string -> int -> socket > + ; connect : + ?bind_address:string -> + ?timeout:float -> + ?prefer:[ `System_default | `Ipv4 | `Ipv6 ] -> + string -> + int -> + socket > (* Wait for [`Read socker], [`Write socket] or [`Both socket] for at most * [timeout] seconds on the given [socket]. Raises [Timeout] if timeout @@ -68,7 +91,7 @@ let wait_for ?(log = fun _ -> ()) event timeout = in let rec wait t = let r, w, _ = - try Unix.select r w [] t + try select r w [] t with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], []) in if r = [] && w = [] then ( @@ -106,18 +129,23 @@ let sockaddr_of_address address = | addr :: _ -> addr.ai_addr let addrinfo_order = function - | Unix.ADDR_UNIX _ -> 2 - | Unix.ADDR_INET (s, _) -> if Unix.is_inet6_addr s then 1 else 0 + | _, Unix.ADDR_UNIX _ -> 2 + | `Ipv4, Unix.ADDR_INET (s, _) -> if Unix.is_inet6_addr s then 1 else 0 + | `Ipv6, Unix.ADDR_INET (s, _) -> if Unix.is_inet6_addr s then 0 else 1 -let resolve_host host port = +let resolve_host ~prefer host port = match - Unix.getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] + ( prefer, + Unix.getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] ) with - | [] -> raise Not_found - | l -> + | _, [] -> raise Not_found + | `System_default, l -> l + | ((`Ipv4, l) as v) | ((`Ipv6, l) as v) -> List.sort (fun { Unix.ai_addr = s; _ } { Unix.ai_addr = s'; _ } -> - Stdlib.compare (addrinfo_order s) (addrinfo_order s')) + Stdlib.compare + (addrinfo_order (fst v, s)) + (addrinfo_order (fst v, s'))) l let connect_sockaddr ?bind_address ?timeout sockaddr = @@ -138,7 +166,7 @@ let connect_sockaddr ?bind_address ?timeout sockaddr = match timeout with | Some timeout -> (* Block in a select call for [timeout] seconds. *) - let _, w, _ = Unix.select [] [socket] [] timeout in + let _, w, _ = select [] [socket] [] timeout in if w = [] then raise Timeout; Unix.clear_nonblock socket; socket @@ -163,7 +191,7 @@ let connect_sockaddr ?bind_address ?timeout sockaddr = end; Printexc.raise_with_backtrace e bt -let unix_connect ?bind_address ?timeout host port = +let unix_connect ?bind_address ?timeout ?(prefer = `System_default) host port = let rec connect_any ?bind_address ?timeout (addrs : Unix.addr_info list) = match addrs with | [] -> raise Not_found @@ -174,7 +202,7 @@ let unix_connect ?bind_address ?timeout host port = try connect_sockaddr ?bind_address ?timeout addr.ai_addr with _ -> connect_any ?bind_address ?timeout tail) in - connect_any ?bind_address ?timeout (resolve_host host port) + connect_any ?bind_address ?timeout (resolve_host ~prefer host port) let unix_transport : transport = object (self) @@ -182,8 +210,8 @@ let unix_transport : transport = method protocol = "http" method default_port = 80 - method connect ?bind_address ?timeout host port = - let socket = unix_connect ?bind_address ?timeout host port in + method connect ?bind_address ?timeout ?prefer host port = + let socket = unix_connect ?bind_address ?timeout ?prefer host port in unix_socket self socket end @@ -321,11 +349,13 @@ let write_data ~timeout ?(offset = 0) ?length (socket : socket) request = let close x = try let c = get_connection_data x in - if x.chunked then write_data ~timeout:x.timeout c.socket "0\r\n\r\n"; - c.socket#close; - x.chunked <- false; - x.icy_cap <- false; - x.status <- PrivDisconnected + Fun.protect + ~finally:(fun () -> c.socket#close) + (fun () -> + if x.chunked then write_data ~timeout:x.timeout c.socket "0\r\n\r\n"; + x.chunked <- false; + x.icy_cap <- false; + x.status <- PrivDisconnected) with | Error _ as e -> raise e | e -> raise (Error (Close e)) diff --git a/src/cry.mli b/src/cry.mli index 3b041db..c33db28 100644 --- a/src/cry.mli +++ b/src/cry.mli @@ -48,7 +48,13 @@ and transport = < name : string ; protocol : string ; default_port : int - ; connect : ?bind_address:string -> ?timeout:float -> string -> int -> socket > + ; connect : + ?bind_address:string -> + ?timeout:float -> + ?prefer:[ `System_default | `Ipv4 | `Ipv6 ] -> + string -> + int -> + socket > (** Possible errors. *) type error = @@ -70,7 +76,12 @@ exception Timeout (** Base unix connect *) val unix_connect : - ?bind_address:string -> ?timeout:float -> string -> int -> Unix.file_descr + ?bind_address:string -> + ?timeout:float -> + ?prefer:[ `System_default | `Ipv4 | `Ipv6 ] -> + string -> + int -> + Unix.file_descr (** Unix transport and socket. *) val unix_transport : transport diff --git a/src/cry_stubs.c b/src/cry_stubs.c new file mode 100644 index 0000000..5246fa1 --- /dev/null +++ b/src/cry_stubs.c @@ -0,0 +1,131 @@ +#include +#include +#include +#include +#include +#include +#include + +#include + +/* On native Windows platforms, many macros are not defined. */ +#if (defined _WIN32 || defined __WIN32__) && !defined __CYGWIN__ + +#ifndef EWOULDBLOCK +#define EWOULDBLOCK EAGAIN +#endif + +#endif + +#ifdef WIN32 +#define Fd_val(fd) win_CRT_fd_of_filedescr(fd) +#define Val_fd(fd) caml_failwith("Val_fd") +#else +#define Fd_val(fd) Int_val(fd) +#define Val_fd(fd) Val_int(fd) +#endif + +#ifndef WIN32 +#include + +CAMLprim value caml_cry_poll(value _read, value _write, value _err, + value _timeout) { + CAMLparam3(_read, _write, _err); + CAMLlocal4(_pread, _pwrite, _perr, _ret); + + struct pollfd *fds; + nfds_t nfds = 0; + nfds_t nread = 0; + nfds_t nwrite = 0; + nfds_t nerr = 0; + int timeout; + size_t last = 0; + int n, ret; + + if (Double_val(_timeout) == -1) + timeout = -1; + else + timeout = Double_val(_timeout) * 1000; + + nfds += Wosize_val(_read); + nfds += Wosize_val(_write); + nfds += Wosize_val(_err); + + fds = calloc(nfds, sizeof(struct pollfd)); + if (fds == NULL) + caml_raise_out_of_memory(); + + for (n = 0; n < Wosize_val(_read); n++) { + fds[last + n].fd = Fd_val(Field(_read, n)); + fds[last + n].events = POLLIN; + } + last += Wosize_val(_read); + + for (n = 0; n < Wosize_val(_write); n++) { + fds[last + n].fd = Fd_val(Field(_write, n)); + fds[last + n].events = POLLOUT; + } + last += Wosize_val(_write); + + for (n = 0; n < Wosize_val(_err); n++) { + fds[last + n].fd = Fd_val(Field(_err, n)); + fds[last + n].events = POLLERR; + } + + caml_release_runtime_system(); + ret = poll(fds, nfds, timeout); + caml_acquire_runtime_system(); + + if (ret == -1) { + free(fds); + uerror("poll", Nothing); + } + + for (n = 0; n < nfds; n++) { + if (fds[n].revents & POLLIN) + nread++; + if (fds[n].revents & POLLOUT) + nwrite++; + if (fds[n].revents & POLLERR) + nerr++; + } + + _pread = caml_alloc_tuple(nread); + nread = 0; + + _pwrite = caml_alloc_tuple(nwrite); + nwrite = 0; + + _perr = caml_alloc_tuple(nerr); + nerr = 0; + + for (n = 0; n < nfds; n++) { + if (fds[n].revents & POLLIN) { + Store_field(_pread, nread, Val_fd(fds[n].fd)); + nread++; + } + if (fds[n].revents & POLLOUT) { + Store_field(_pwrite, nwrite, Val_fd(fds[n].fd)); + nwrite++; + } + if (fds[n].revents & POLLERR) { + Store_field(_pread, nerr, Val_fd(fds[n].fd)); + nerr++; + } + } + + free(fds); + + _ret = caml_alloc_tuple(3); + Store_field(_ret, 0, _pread); + Store_field(_ret, 1, _pwrite); + Store_field(_ret, 2, _perr); + + CAMLreturn(_ret); +} +#else +CAMLprim value caml_cry_poll(value _read, value _write, value _err, + value _timeout) { + caml_failwith("caml_poll"); +} +#endif diff --git a/src/dune b/src/dune index 3d486f6..07f8143 100644 --- a/src/dune +++ b/src/dune @@ -2,5 +2,8 @@ (name cry) (public_name cry) (libraries bytes unix) + (foreign_stubs + (language c) + (names cry_stubs)) (synopsis "OCaml client for the various icecast & shoutcast source protocols")) -- cgit v1.2.3