From 290b882151ee84e708f4d8bd8337411ba4e43928 Mon Sep 17 00:00:00 2001 From: Romain Beauxis Date: Sun, 7 Jan 2024 14:00:57 -0600 Subject: [PATCH] Add preferred address option. --- dune-project | 2 +- liquidsoap-core.opam | 2 +- src/core/builtins/builtins_ssl.ml | 6 ++++-- src/core/builtins/builtins_tls.ml | 4 ++-- src/core/outputs/icecast2.ml | 28 +++++++++++++++++++++++++++- src/core/tools/http.ml | 12 +++++++++--- src/core/tools/http.mli | 15 +++++++++++++-- 7 files changed, 57 insertions(+), 12 deletions(-) diff --git a/dune-project b/dune-project index a57b1dff5c..954267b9d8 100644 --- a/dune-project +++ b/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 diff --git a/liquidsoap-core.opam b/liquidsoap-core.opam index efe29ec3ba..16ec484153 100644 --- a/liquidsoap-core.opam +++ b/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" diff --git a/src/core/builtins/builtins_ssl.ml b/src/core/builtins/builtins_ssl.ml index c3e61218ad..a4d600c276 100644 --- a/src/core/builtins/builtins_ssl.ml +++ b/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 _ -> ()); diff --git a/src/core/builtins/builtins_tls.ml b/src/core/builtins/builtins_tls.ml index 9b59293045..35a12cc936 100644 --- a/src/core/builtins/builtins_tls.ml +++ b/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 diff --git a/src/core/outputs/icecast2.ml b/src/core/outputs/icecast2.ml index 9e6205b239..0db21286b3 100644 --- a/src/core/outputs/icecast2.ml +++ b/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 diff --git a/src/core/tools/http.ml b/src/core/tools/http.ml index 2408d3860d..b0703f3df1 100644 --- a/src/core/tools/http.ml +++ b/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 = diff --git a/src/core/tools/http.mli b/src/core/tools/http.mli index 025f32434e..82405e19ec 100644 --- a/src/core/tools/http.mli +++ b/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