New upstream version 1.0.2

7 files changed, 205 insertions, 23 deletions

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 <caml/alloc.h>
+#include <caml/bigarray.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/threads.h>
+#include <caml/unixsupport.h>
+
+#include <errno.h>
+
+/* 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 <poll.h>
+
+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"))