Add preferred address option.

dune-project

@@ -50,7 +50,7 @@
     (mm (>= 0.8.4))
     (re (>= 1.11.0))
     (ocurl (>= 0.9.2))
-    (cry (>= 1.0.0))
+    (cry (>= 1.0.2))
     (camomile (>= 2.0.0))
     uri
     fileutils

liquidsoap-core.opam

@@ -15,7 +15,7 @@ depends: [
   "mm" {>= "0.8.4"}
   "re" {>= "1.11.0"}
   "ocurl" {>= "0.9.2"}
-  "cry" {>= "1.0.0"}
+  "cry" {>= "1.0.2"}
   "camomile" {>= "2.0.0"}
   "uri"
   "fileutils"

src/core/builtins/builtins_ssl.ml

@@ -102,7 +102,7 @@ let transport ~min_protocol ~max_protocol ~read_timeout ~write_timeout ~password
     method protocol = "https"
     method default_port = 443
 
-    method connect ?bind_address ?timeout host port =
+    method connect ?bind_address ?timeout ?prefer host port =
       try
         let ctx =
           Ssl.create_context (Ssl.SSLv23 [@alert "-deprecated"])
@@ -123,7 +123,9 @@ let transport ~min_protocol ~max_protocol ~read_timeout ~write_timeout ~password
          with _ -> ());
         Ssl.set_verify_depth ctx 3;
         ignore (Ssl.set_default_verify_paths ctx);
-        let unix_socket = Http.connect ?bind_address ?timeout host port in
+        let unix_socket =
+          Http.connect ?bind_address ?timeout ?prefer host port
+        in
         try
           let socket = Ssl.embed_socket unix_socket ctx in
           (try Ssl.set_client_SNI_hostname socket host with _ -> ());

src/core/builtins/builtins_tls.ml

@@ -209,7 +209,7 @@ let transport ~read_timeout ~write_timeout ~certificate ~key () =
     method protocol = "https"
     method default_port = 443
 
-    method connect ?bind_address ?timeout host port =
+    method connect ?bind_address ?timeout ?prefer host port =
       let domain = Domain_name.host_exn (Domain_name.of_string_exn host) in
       let authenticator = Result.get_ok (Ca_certs.authenticator ()) in
       let certificate_authenticator =
@@ -233,7 +233,7 @@ let transport ~read_timeout ~write_timeout ~certificate ~key () =
               if Result.is_ok r then r else authenticator ?ip ~host certs
       in
       let client = Tls.Config.client ~authenticator ~peer_name:domain () in
-      let fd = Http.connect ?bind_address ?timeout host port in
+      let fd = Http.connect ?bind_address ?timeout ?prefer host port in
       let session = Liq_tls.init_client ~client fd in
       tls_socket ~session self
 

src/core/outputs/icecast2.ml

@@ -218,6 +218,12 @@ let proto frame_t =
       ("name", Lang.nullable_t Lang.string_t, Some Lang.null, None);
       ("host", Lang.string_t, Some (Lang.string "localhost"), None);
       ("port", Lang.int_t, Some (Lang.int 8000), None);
+      ( "prefer_address",
+        Lang.nullable_t Lang.string_t,
+        Some Lang.null,
+        Some
+          "Preferred address type when resolving hostnames. One of: `\"ipv4\"` \
+           or `\"ipv6\"`. Defaults to system default when `null`." );
       ( "transport",
         Lang.http_transport_base_t,
         Some (Lang.base_http_transport Http.unix_transport),
@@ -421,6 +427,27 @@ class output p =
   let host = s "host" in
   let port = e Lang.to_int "port" in
   let transport = e Lang.to_http_transport "transport" in
+  let prefer_address =
+    let v = List.assoc "prefer_address" p in
+    match Lang.to_valued_option Lang.to_string v with
+      | None -> `System_default
+      | Some "ipv4" -> `Ipv4
+      | Some "ipv6" -> `Ipv6
+      | Some _ ->
+          raise (Error.Invalid_value (v, "Valid values are: 'ipv4' or 'ipv6'."))
+  in
+  let transport = (transport :> Cry.transport) in
+  let transport =
+    object
+      method name = transport#name
+      method protocol = transport#protocol
+      method default_port = transport#default_port
+
+      method connect ?bind_address ?timeout ?prefer =
+        transport#connect ?bind_address ?timeout
+          ~prefer:(Option.value ~default:prefer_address prefer)
+    end
+  in
   let user =
     match (protocol, s_opt "user") with
       | Cry.Http _, None -> "source"
@@ -450,7 +477,6 @@ class output p =
         f (Lang.to_product v))
       (Lang.to_list (List.assoc "headers" p))
   in
-  let transport = (transport :> Cry.transport) in
   let connection = Cry.create ~timeout ~transport ?connection_timeout () in
   object (self)
     inherit

src/core/tools/http.ml

@@ -25,7 +25,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
   ; server : server >
 
 let connect = Cry.unix_connect
@@ -48,8 +54,8 @@ and unix_transport () =
     method protocol = Cry.unix_transport#protocol
     method default_port = Cry.unix_transport#default_port
 
-    method connect ?bind_address ?timeout host port =
-      let fd = Cry.unix_connect ?bind_address ?timeout host port in
+    method connect ?bind_address ?timeout ?prefer host port =
+      let fd = Cry.unix_connect ?bind_address ?timeout ?prefer host port in
       unix_socket fd
 
     method server =

src/core/tools/http.mli

@@ -18,7 +18,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
   ; server : server >
 
 type uri = {
@@ -30,7 +36,12 @@ type uri = {
 
 (** Base unix connect *)
 val 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