diff --git a/.github/scripts/build-posix.sh b/.github/scripts/build-posix.sh index 8bb4e971ae..dd11e99537 100755 --- a/.github/scripts/build-posix.sh +++ b/.github/scripts/build-posix.sh @@ -40,6 +40,8 @@ export PKG_CONFIG_PATH=/usr/share/pkgconfig/pkgconfig git clone https://github.com/savonet/Camomile.git cd Camomile && opam install -y . +opam install -y tls ca-certs + echo "::endgroup::" echo "::group::Checking out CI commit" diff --git a/.gitignore b/.gitignore index 709f210f62..7d3495970b 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ _build/ liquidsoap.config *.install +tests/streams/ssl.cert +tests/streams/ssl.key diff --git a/CHANGES.md b/CHANGES.md index 24fe1ec93e..376edadcea 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -12,6 +12,7 @@ New: - Added support for FLAC metadata (#2952) - Added support for YAML parsing and rendering (#2855) - Added support for the proprietary shared stereotool library (#2953) +- Added TLS support via `ocaml-tls` (#3074) - Added `video.align`. - Added `string.index`. - Added support for ffmpeg decoder parameters to allow decoding of @@ -104,6 +105,8 @@ Changed: protocol. - The `sleeper` operator is now scripted (#2899). - Reworked remote request file extension resolution (#2947) +- REMOVED `osx-secure-transport`. Doubt it was ever used, API deprecated + upstream (#3067) Fixed: @@ -114,6 +117,7 @@ Fixed: - Fixed race condition when switching `input.ffmpeg`-based urls (#2956) - Fixed deadlock in `%external` encoder (#3029) - Fixed crash in encoders due to concurrent access (#3064) +- Fixed long-term connection issues with SSL (#3067) --- diff --git a/dune-project b/dune-project index 692f90f295..2ab154f5fd 100644 --- a/dune-project +++ b/dune-project @@ -62,7 +62,6 @@ ogg opus osc-unix - osx-secure-transport portaudio posix-time2 pulseaudio @@ -74,6 +73,7 @@ srt ssl taglib + tls-liquidsoap theora tsdl tsdl-image @@ -168,3 +168,10 @@ (liquidsoap-lang (<> :version))) (synopsis "Liquidosap emacs mode") ) + +(package + (name tls-liquidsoap) + (allow_empty) + (depends tls ca-certs) + (synopsis "Liquidosap dependencies for TLS optional features") +) diff --git a/liquidsoap.opam b/liquidsoap.opam index 6caf07d855..6b367b1f03 100644 --- a/liquidsoap.opam +++ b/liquidsoap.opam @@ -65,7 +65,6 @@ depopts: [ "ogg" "opus" "osc-unix" - "osx-secure-transport" "portaudio" "posix-time2" "pulseaudio" @@ -77,6 +76,7 @@ depopts: [ "srt" "ssl" "taglib" + "tls-liquidsoap" "theora" "tsdl" "tsdl-image" @@ -166,10 +166,10 @@ to decode metadata tags from many audio and video media files. This is a feature most users want.""" {success & !taglib-enabled} """\ -We noticed that you did not install any ssl support package. Liquidsoap won't -be able to use any of the `https.{get,...}` operators. You might want to install one of ssl or -osx-secure-transport package.""" - {success & !ssl-enabled & !secure-transport-enabled} +We noticed that you did not install any ssl or tls support. Liquidsoap won't +be able to use SSL encryption in its input or output operators. You might want +to install one of ssl or tls-liquidsoap package.""" + {success & !ssl-enabled & !tls-enabled} """\ We noticed that your build includes GStreamer support. This support is DEPRECATED. We suggest you consider moving to FFmpeg, which should provide same the same level diff --git a/liquidsoap.opam.template b/liquidsoap.opam.template index 7471537bea..64b41ce40d 100644 --- a/liquidsoap.opam.template +++ b/liquidsoap.opam.template @@ -23,10 +23,10 @@ to decode metadata tags from many audio and video media files. This is a feature most users want.""" {success & !taglib-enabled} """\ -We noticed that you did not install any ssl support package. Liquidsoap won't -be able to use any of the `https.{get,...}` operators. You might want to install one of ssl or -osx-secure-transport package.""" - {success & !ssl-enabled & !secure-transport-enabled} +We noticed that you did not install any ssl or tls support. Liquidsoap won't +be able to use SSL encryption in its input or output operators. You might want +to install one of ssl or tls-liquidsoap package.""" + {success & !ssl-enabled & !tls-enabled} """\ We noticed that your build includes GStreamer support. This support is DEPRECATED. We suggest you consider moving to FFmpeg, which should provide same the same level diff --git a/src/config/osx_secure_transport_option.disabled.ml b/src/config/osx_secure_transport_option.disabled.ml deleted file mode 100644 index b44442d659..0000000000 --- a/src/config/osx_secure_transport_option.disabled.ml +++ /dev/null @@ -1,2 +0,0 @@ -let detected = "no (requires osx-secure-transport)" -let enabled = false diff --git a/src/config/tls_option.disabled.ml b/src/config/tls_option.disabled.ml new file mode 100644 index 0000000000..d63e34ea7f --- /dev/null +++ b/src/config/tls_option.disabled.ml @@ -0,0 +1,2 @@ +let detected = "no (requires tls-liquidsoap)" +let enabled = false diff --git a/src/config/osx_secure_transport_option.enabled.ml b/src/config/tls_option.enabled.ml similarity index 100% rename from src/config/osx_secure_transport_option.enabled.ml rename to src/config/tls_option.enabled.ml diff --git a/src/core/builtins/builtins_cry.ml b/src/core/builtins/builtins_cry.ml index cfd7b7869f..3eb2466a4f 100644 --- a/src/core/builtins/builtins_cry.ml +++ b/src/core/builtins/builtins_cry.ml @@ -114,6 +114,7 @@ let _ = in begin try + let transport = (transport :> Cry.transport) in Cry.manual_update_metadata ~host ~port ~protocol ~user ~password ~mount ~headers ~transport metas with e -> diff --git a/src/core/builtins/builtins_http_secure_transport.ml b/src/core/builtins/builtins_http_secure_transport.ml deleted file mode 100644 index 701e9e10f7..0000000000 --- a/src/core/builtins/builtins_http_secure_transport.ml +++ /dev/null @@ -1,95 +0,0 @@ -(* -*- mode: tuareg; -*- *) -(***************************************************************************** - - Liquidsoap, a programmable audio stream generator. - Copyright 2003-2023 Savonet team - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details, fully stated in the COPYING - file at the root of the liquidsoap distribution. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - - *****************************************************************************) - -let secure_transport_socket transport fd ctx = - object - method typ = "secure_transport" - method transport = transport - method file_descr = fd - - method wait_for ?log event timeout = - let event = - match event with - | `Read -> `Read fd - | `Write -> `Write fd - | `Both -> `Both fd - in - Tutils.wait_for ?log event timeout - - method write = SecureTransport.write ctx - method read = SecureTransport.read ctx - - method close = - SecureTransport.close ctx; - Unix.close fd - end - -let transport ~password ~certificate ~key:_ () = - object (self) - method name = "secure_transport" - method protocol = "https" - method default_port = 443 - - method connect ?bind_address ?timeout host port = - let socket = Http.connect ?bind_address ?timeout host port in - let ctx = - SecureTransport.init SecureTransport.Client SecureTransport.Stream - in - SecureTransport.set_peer_domain_name ctx host; - SecureTransport.set_connection ctx socket; - SecureTransport.handshake ctx; - secure_transport_socket self socket ctx - - method accept sock = - let sock, caller = Unix.accept ~cloexec:true sock in - let ctx = - SecureTransport.init SecureTransport.Server SecureTransport.Stream - in - let certs = - SecureTransport.import_p12_certificate ?password certificate - in - List.iter (SecureTransport.set_certificate ctx) certs; - SecureTransport.set_connection ctx sock; - SecureTransport.handshake ctx; - (secure_transport_socket self sock ctx, caller) - end - -let _ = - Lang.add_builtin ~base:Modules.http_transport "secure_transport" - ~category:`Liquidsoap ~descr:"Https transport using macos' SecureTransport" - [ - ( "password", - Lang.nullable_t Lang.string_t, - Some Lang.null, - Some "SSL certificate password" ); - ("certificate", Lang.string_t, None, Some "Path to certificate file"); - ("key", Lang.string_t, None, Some "Path to certificate private key"); - ] - Lang.http_transport_t - (fun p -> - let password = - Lang.to_valued_option Lang.to_string (List.assoc "password" p) - in - let certificate = Lang.to_string (List.assoc "certificate" p) in - let key = Lang.to_string (List.assoc "key" p) in - Lang.http_transport (transport ~password ~certificate ~key ())) diff --git a/src/core/builtins/builtins_optionals.ml b/src/core/builtins/builtins_optionals.ml index 5a87ed392f..60bfa83dc5 100644 --- a/src/core/builtins/builtins_optionals.ml +++ b/src/core/builtins/builtins_optionals.ml @@ -42,7 +42,6 @@ let () = ("opus", Opus_option.enabled); ("osc", Osc_option.enabled); ("oss", Oss_option.enabled); - ("osx_secure_transport", Osx_secure_transport_option.enabled); ("portaudio", Portaudio_option.enabled); ("posix_time2", Posix_time_option.enabled); ("prometheus", Prometheus_option.enabled); @@ -54,6 +53,7 @@ let () = ("speex", Speex_option.enabled); ("srt", Srt_option.enabled); ("ssl", Ssl_option.enabled); + ("tls", Tls_option.enabled); ("taglib", Taglib_option.enabled); ("theora", Theora_option.enabled); ("vorbis", Vorbis_option.enabled); diff --git a/src/core/builtins/builtins_socket.ml b/src/core/builtins/builtins_socket.ml index 41768e2ede..8152bcaa97 100644 --- a/src/core/builtins/builtins_socket.ml +++ b/src/core/builtins/builtins_socket.ml @@ -405,7 +405,9 @@ module Socket_value = struct [ ( "accept", Lang.val_fun [] (fun _ -> - let fd, sockaddr = socket#transport#accept socket#file_descr in + let fd, sockaddr = + socket#transport#server#accept socket#file_descr + in Lang.product (to_value fd) (Socket_addr.to_value sockaddr)) ); ( "connect", Lang.val_fun diff --git a/src/core/builtins/builtins_http_ssl.ml b/src/core/builtins/builtins_ssl.ml similarity index 91% rename from src/core/builtins/builtins_http_ssl.ml rename to src/core/builtins/builtins_ssl.ml index 99ef8b8ecd..5440b3cba6 100644 --- a/src/core/builtins/builtins_http_ssl.ml +++ b/src/core/builtins/builtins_ssl.ml @@ -21,15 +21,6 @@ *****************************************************************************) -let get_ctx ~password ~certificate ~key () = - let ctx = Ssl.create_context Ssl.SSLv23 Ssl.Server_context in - ignore - (Option.map - (fun password -> Ssl.set_password_callback ctx (fun _ -> password)) - password); - Ssl.use_certificate ctx certificate key; - ctx - let set_socket_default ~read_timeout ~write_timeout fd = ignore (Option.map (Unix.setsockopt_float fd Unix.SO_RCVTIMEO) read_timeout); ignore (Option.map (Unix.setsockopt_float fd Unix.SO_SNDTIMEO) write_timeout) @@ -57,6 +48,26 @@ let ssl_socket transport ssl = Unix.close (Ssl.file_descr_of_socket ssl) end +let server ~read_timeout ~write_timeout ~password ~certificate ~key transport = + let context = Ssl.create_context Ssl.SSLv23 Ssl.Server_context in + let () = + ignore + (Option.map + (fun password -> Ssl.set_password_callback context (fun _ -> password)) + password); + Ssl.use_certificate context (certificate ()) (key ()) + in + object + method transport = transport + + method accept sock = + let s, caller = Unix.accept ~cloexec:true sock in + set_socket_default ~read_timeout ~write_timeout s; + let ssl_s = Ssl.embed_socket s context in + Ssl.accept ssl_s; + (ssl_socket transport ssl_s, caller) + end + let transport ~read_timeout ~write_timeout ~password ~certificate ~key () = object (self) method name = "ssl" @@ -111,15 +122,8 @@ let transport ~read_timeout ~write_timeout ~password ~certificate ~key () = let bt = Printexc.get_raw_backtrace () in Lang.raise_as_runtime ~bt ~kind:"ssl" exn - method accept sock = - let s, caller = Unix.accept ~cloexec:true sock in - set_socket_default ~read_timeout ~write_timeout s; - let ctx = - get_ctx ~password ~certificate:(certificate ()) ~key:(key ()) () - in - let ssl_s = Ssl.embed_socket s ctx in - Ssl.accept ssl_s; - (ssl_socket self ssl_s, caller) + method server = + server ~read_timeout ~write_timeout ~password ~certificate ~key self end let _ = diff --git a/src/core/builtins/builtins_tls.ml b/src/core/builtins/builtins_tls.ml new file mode 100644 index 0000000000..1345c0a846 --- /dev/null +++ b/src/core/builtins/builtins_tls.ml @@ -0,0 +1,286 @@ +(***************************************************************************** + + Liquidsoap, a programmable audio stream generator. + Copyright 2003-2023 Savonet team + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details, fully stated in the COPYING + file at the root of the liquidsoap distribution. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + *****************************************************************************) + +module Liq_tls = struct + type t = { + read_pending : Buffer.t; + fd : Unix.file_descr; + buf : bytes; + mutable state : Tls.Engine.state; + } + + let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) + let buf_len = 4096 + let write_all fd data = Utils.write_all fd (Cstruct.to_bytes data) + + let read h len = + let n = Unix.read h.fd h.buf 0 (min len buf_len) in + Cstruct.of_bytes ~len:n h.buf + + let handshake h = + let rec f () = + if Tls.Engine.handshake_in_progress h.state then ( + match Tls.Engine.handle_tls h.state (read h buf_len) with + | Ok (`Eof, _, _) -> + Runtime_error.raise ~pos:[] + ~message:"Connection closed while negotiating TLS handshake!" + "tls" + | Ok (`Alert alert, `Response response, _) -> + ignore (Option.map (write_all h.fd) response); + Runtime_error.raise ~pos:[] + ~message: + (Printf.sprintf "TLS handshake error: %s" + (Tls.Packet.alert_type_to_string alert)) + "tls" + | Ok (`Ok state, `Response response, `Data data) -> + ignore + (Option.map + (fun data -> + Buffer.add_string h.read_pending (Cstruct.to_string data)) + data); + ignore (Option.map (write_all h.fd) response); + h.state <- state; + f () + | Error (error, `Response response) -> + write_all h.fd response; + Runtime_error.raise ~pos:[] + ~message: + (Printf.sprintf "TLS handshake error: %s" + (Tls.Packet.alert_type_to_string + (Tls.Engine.alert_of_failure error))) + "tls") + in + f () + + let init_base ~state fd = + let buf = Bytes.create buf_len in + let read_pending = Buffer.create 4096 in + let h = { read_pending; fd; buf; state } in + handshake h; + h + + let init_server ~server fd = + let state = Tls.Engine.server server in + init_base ~state fd + + let init_client ~client fd = + let state, hello = Tls.Engine.client client in + write_all fd hello; + init_base ~state fd + + let write h b off len = + match + Tls.Engine.send_application_data h.state [Cstruct.of_bytes ~off ~len b] + with + | None -> len + | Some (state, data) -> + write_all h.fd data; + h.state <- state; + len + + let read h b off len = + let pending = Buffer.length h.read_pending in + if 0 < pending then ( + let n = min pending len in + Buffer.blit h.read_pending 0 b off n; + Utils.buffer_drop h.read_pending n; + n) + else ( + let rec f () = + match Tls.Engine.handle_tls h.state (read h len) with + | Ok (`Eof, _, _) -> 0 + | Ok (`Alert alert, `Response response, _) -> + ignore (Option.map (write_all h.fd) response); + Runtime_error.raise ~pos:[] + ~message: + (Printf.sprintf "TLS read error: %s" + (Tls.Packet.alert_type_to_string alert)) + "tls" + | Ok (`Ok state, `Response response, `Data data) -> ( + ignore (Option.map (write_all h.fd) response); + h.state <- state; + match data with + | None -> f () + | Some data -> + let data_len = Cstruct.length data in + let n = min data_len len in + Cstruct.blit_to_bytes data 0 b off n; + if n < data_len then + Buffer.add_string h.read_pending + (Cstruct.to_string data ~off:n ~len:(data_len - n)); + n) + | Error (error, `Response response) -> + write_all h.fd response; + Runtime_error.raise ~pos:[] + ~message: + (Printf.sprintf "TLS read error: %s" + (Tls.Packet.alert_type_to_string + (Tls.Engine.alert_of_failure error))) + "tls" + in + f ()) + + let close h = + let state, data = Tls.Engine.send_close_notify h.state in + write_all h.fd data; + h.state <- state; + Unix.close h.fd +end + +let set_socket_default ~read_timeout ~write_timeout fd = + Unix.set_close_on_exec fd; + ignore (Option.map (Unix.setsockopt_float fd Unix.SO_RCVTIMEO) read_timeout); + ignore (Option.map (Unix.setsockopt_float fd Unix.SO_SNDTIMEO) write_timeout) + +let tls_socket ~session transport = + object + method typ = "tls" + method transport = transport + method file_descr = session.Liq_tls.fd + + method wait_for ?log event timeout = + let event = + match event with + | `Read -> `Read session.Liq_tls.fd + | `Write -> `Write session.Liq_tls.fd + | `Both -> `Both session.Liq_tls.fd + in + Tutils.wait_for ?log event timeout + + method read = Liq_tls.read session + method write = Liq_tls.write session + method close = Liq_tls.close session + end + +let server ~read_timeout ~write_timeout ~certificate ~key transport = + let server = + try + let certificate = Cstruct.of_string (Utils.read_all (certificate ())) in + let certificates = + Result.get_ok (X509.Certificate.decode_pem_multiple certificate) + in + let key = + Result.get_ok + (X509.Private_key.decode_pem + (Cstruct.of_string (Utils.read_all (key ())))) + in + Tls.Config.server ~certificates:(`Single (certificates, key)) () + with exn -> + let bt = Printexc.get_raw_backtrace () in + Lang.raise_as_runtime ~bt ~kind:"tls" exn + in + object + method transport = transport + + method accept sock = + let fd, caller = Unix.accept ~cloexec:true sock in + let session = Liq_tls.init_server ~server fd in + set_socket_default ~read_timeout ~write_timeout fd; + (tls_socket ~session transport, caller) + end + +let transport ~read_timeout ~write_timeout ~certificate ~key () = + object (self) + method name = "tls" + method protocol = "https" + method default_port = 443 + + method connect ?bind_address ?timeout 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 = + try + let certificates = + Result.get_ok + (X509.Certificate.decode_pem_multiple + (Cstruct.of_string (Utils.read_all (certificate ())))) + in + Some + (X509.Authenticator.chain_of_trust + ~time:(fun () -> Some (Ptime_clock.now ())) + certificates) + with _ -> None + in + let authenticator ?ip ~host certs = + match certificate_authenticator with + | None -> authenticator ?ip ~host certs + | Some auth -> + let r = auth ?ip ~host certs in + 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 session = Liq_tls.init_client ~client fd in + tls_socket ~session self + + method server = server ~read_timeout ~write_timeout ~certificate ~key self + end + +let _ = + Lang.add_builtin ~base:Modules.http_transport "tls" ~category:`Internet + ~descr:"Https transport using libtls" + [ + ( "read_timeout", + Lang.nullable_t Lang.float_t, + Some Lang.null, + Some "Read timeout" ); + ( "write_timeout", + Lang.nullable_t Lang.float_t, + Some Lang.null, + Some "Write timeout" ); + ( "certificate", + Lang.nullable_t Lang.string_t, + Some Lang.null, + Some + "Path to certificate file. Required in server mode, e.g. \ + `input.harbor`, etc. If passed in client mode, certificate is added \ + to the list of valid certificates." ); + ( "key", + Lang.nullable_t Lang.string_t, + Some Lang.null, + Some + "Path to certificate private key. Required in server mode, e.g. \ + `input.harbor`, etc. Unused in client mode." ); + ] + Lang.http_transport_t + (fun p -> + let read_timeout = + Lang.to_valued_option Lang.to_float (List.assoc "read_timeout" p) + in + let write_timeout = + Lang.to_valued_option Lang.to_float (List.assoc "write_timeout" p) + in + let raise name = + Runtime_error.raise ~pos:(Lang.pos p) + ~message:("Cannot find SSL " ^ name ^ " file!") + "not_found" + in + let find name () = + match Lang.to_valued_option Lang.to_string (List.assoc name p) with + | None -> raise name + | Some f when not (Sys.file_exists f) -> raise name + | Some f -> f + in + let certificate = find "certificate" in + let key = find "key" in + Lang.http_transport + (transport ~read_timeout ~write_timeout ~certificate ~key ())) diff --git a/src/core/dune b/src/core/dune index 6a901a5b93..93793c27f0 100644 --- a/src/core/dune +++ b/src/core/dune @@ -558,14 +558,6 @@ (names oss_io_c)) (modules oss_io)) -(library - (name liquidsoap_secure_transport) - (libraries osx-secure-transport liquidsoap_core liquidsoap_builtins) - (library_flags -linkall) - (wrapped false) - (optional) - (modules builtins_http_secure_transport)) - (library (name liquidsoap_portaudio) (libraries portaudio liquidsoap_core) @@ -660,7 +652,7 @@ (library_flags -linkall) (wrapped false) (optional) - (modules ssl_base builtins_http_ssl)) + (modules ssl_base builtins_ssl)) (library (name liquidsoap_stereotool) @@ -686,6 +678,20 @@ (optional) (modules liq_theora_decoder theora_encoder)) +(library + (name liquidsoap_tls) + (libraries + tls + ca-certs + mirage-crypto-rng.unix + cstruct + liquidsoap_core + liquidsoap_builtins) + (library_flags -linkall) + (wrapped false) + (optional) + (modules builtins_tls)) + (library (name liquidsoap_vorbis) (libraries vorbis vorbis.decoder liquidsoap_core liquidsoap_ogg) @@ -751,7 +757,6 @@ opus_option osc_option oss_option - osx_secure_transport_option portaudio_option posix_time_option prometheus_option @@ -766,6 +771,7 @@ stereotool_option taglib_option theora_option + tls_option vorbis_option winsvc_option yaml_option @@ -922,11 +928,6 @@ from (liquidsoap_oss -> oss_option.enabled.ml) (-> oss_option.disabled.ml)) - (select - osx_secure_transport_option.ml - from - (liquidsoap_secure_transport -> osx_secure_transport_option.enabled.ml) - (-> osx_secure_transport_option.disabled.ml)) (select portaudio_option.ml from @@ -1002,6 +1003,11 @@ from (liquidsoap_theora -> theora_option.enabled.ml) (-> theora_option.disabled.ml)) + (select + tls_option.ml + from + (liquidsoap_tls -> tls_option.enabled.ml) + (-> tls_option.disabled.ml)) (select vorbis_option.ml from diff --git a/src/core/harbor/harbor.ml b/src/core/harbor/harbor.ml index 31dfa2d630..b93058718b 100644 --- a/src/core/harbor/harbor.ml +++ b/src/core/harbor/harbor.ml @@ -1004,9 +1004,10 @@ module Make (T : Transport_t) : T with type socket = T.socket = struct let open_port ~transport ~icy port = log#info "Opening port %d with icy = %b" port icy; let max_conn = conf_harbor_max_conn#get in + let server = transport#server in let process_client sock = try - let socket, caller = transport#accept sock in + let socket, caller = server#accept sock in let ip = Utils.name_of_sockaddr ~rev_dns:conf_revdns#get caller in log#info "New client on port %i: %s" port ip; let unix_socket = T.file_descr_of_socket socket in diff --git a/src/core/outputs/icecast2.ml b/src/core/outputs/icecast2.ml index c58d012042..0069aa4911 100644 --- a/src/core/outputs/icecast2.ml +++ b/src/core/outputs/icecast2.ml @@ -445,6 +445,7 @@ 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 @@ -592,7 +593,9 @@ class output p = * The output will just try to reconnect later. *) | e -> let bt = Printexc.get_raw_backtrace () in - self#log#severe "Connection failed: %s" (Printexc.to_string e); + Utils.log_exception ~log:self#log + ~bt:(Printexc.raw_backtrace_to_string bt) + (Printf.sprintf "Connection failed: %s" (Printexc.to_string e)); self#icecast_stop; let delay = on_error e in if delay >= 0. then ( diff --git a/src/core/tools/http.ml b/src/core/tools/http.ml index ac656e56c9..d4f06b4d59 100644 --- a/src/core/tools/http.ml +++ b/src/core/tools/http.ml @@ -6,12 +6,61 @@ type uri = { } type event = Cry.event -type socket = Cry.socket -type transport = Cry.transport + +type socket = + < typ : string + ; transport : transport + ; file_descr : Unix.file_descr + ; wait_for : ?log:(string -> unit) -> event -> float -> unit + ; write : Bytes.t -> int -> int -> int + ; read : Bytes.t -> int -> int -> int + ; close : unit > + +and server = + < transport : transport ; accept : Unix.file_descr -> socket * Unix.sockaddr > + +and transport = + < name : string + ; protocol : string + ; default_port : int + ; connect : ?bind_address:string -> ?timeout:float -> string -> int -> socket + ; server : server > let connect = Cry.unix_connect -let unix_transport = Cry.unix_transport -let unix_socket = Cry.unix_socket + +let rec unix_socket fd = + let s = Cry.unix_socket fd in + object + method typ = s#typ + method file_descr = fd + method transport = unix_transport () + method wait_for = s#wait_for + method write = s#write + method read = s#read + method close = s#close + end + +and unix_transport () = + object (self) + method name = Cry.unix_transport#name + 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 + unix_socket fd + + method server = + object + method transport = self + + method accept fd = + let fd, addr = Unix.accept ~cloexec:true fd in + (unix_socket fd, addr) + end + end + +let unix_transport = unix_transport () let user_agent = Configure.vendor let args_split s = diff --git a/src/core/tools/http.mli b/src/core/tools/http.mli index bb9cae14f4..025f32434e 100644 --- a/src/core/tools/http.mli +++ b/src/core/tools/http.mli @@ -11,12 +11,15 @@ type socket = ; read : Bytes.t -> int -> int -> int ; close : unit > +and server = + < transport : transport ; accept : Unix.file_descr -> socket * Unix.sockaddr > + and transport = < name : string ; protocol : string ; default_port : int ; connect : ?bind_address:string -> ?timeout:float -> string -> int -> socket - ; accept : Unix.file_descr -> socket * Unix.sockaddr > + ; server : server > type uri = { protocol : string; diff --git a/src/core/tools/utils.ml b/src/core/tools/utils.ml index 9b93713604..28a818d936 100644 --- a/src/core/tools/utils.ml +++ b/src/core/tools/utils.ml @@ -480,3 +480,13 @@ let concat_with_last ~last sep l = | [x; y] -> Printf.sprintf "%s %s %s" y last x | x :: l -> Printf.sprintf "%s %s %s" (String.concat sep (List.rev l)) last x + +let write_all fd b = + let rec f ofs len = + match Unix.write fd b ofs len with + | 0 -> raise End_of_file + | n when n = len -> () + | n -> f (ofs + n) (len - n) + in + let len = Bytes.length b in + if len > 0 then f 0 len diff --git a/src/runtime/build_config.ml b/src/runtime/build_config.ml index 141f445856..97edd3306d 100644 --- a/src/runtime/build_config.ml +++ b/src/runtime/build_config.ml @@ -104,8 +104,8 @@ let build_config = - memtrace : %{Memtrace_option.detected} - mem_usage : %{Mem_usage_option.detected} - osc : %{Osc_option.detected} - - SecureTransport : %{Osx_secure_transport_option.detected} - ssl : %{Ssl_option.detected} + - tls : %{Tls_option.detected} - posix-time2 : %{Posix_time_option.detected} - windows service : %{Winsvc_option.detected} - YAML support : %{Yaml_option.detected} @@ -125,9 +125,9 @@ variables { lame-enabled: %{string_of_bool Lame_option.enabled} mad-enabled: %{string_of_bool Mad_option.enabled} samperate-enabled: %{string_of_bool Samplerate_option.enabled} - secure-transport-enabled: %{string_of_bool Osx_secure_transport_option.enabled} shine-enabled: %{string_of_bool Shine_option.enabled} ssl-enabled: %{string_of_bool Ssl_option.enabled} + tls-enabled: %{string_of_bool Tls_option.enabled} taglib-enabled: %{string_of_bool Taglib_option.enabled} } |}] diff --git a/tests/streams/dune b/tests/streams/dune index 5721a9b305..96b27699de 100644 --- a/tests/streams/dune +++ b/tests/streams/dune @@ -204,7 +204,7 @@ 3650 -nodes -subj - "/C=XX/ST=StateName/L=CityName/O=CompanyName/OU=CompanySectionName/CN=CommonNameOrHostname"))) + "/C=XX/ST=StateName/L=CityName/O=CompanyName/OU=CompanySectionName/CN=localhost"))) (rule (alias citest) @@ -227,3 +227,69 @@ %{stdlib} %{test_liq} ./icecast_ssl.liq))) + +(rule + (alias citest) + (package liquidsoap) + (deps + ../../src/bin/liquidsoap.exe + ./icecast_tls.liq + ./ssl.cert + ./ssl.key + (package liquidsoap) + (:stdlib ../../src/libs/stdlib.liq) + (:test_liq ../test.liq) + (:run_test ../run_test.exe)) + (action + (run + %{run_test} + "Icecast TLS connection" + liquidsoap + --no-stdlib + %{stdlib} + %{test_liq} + ./icecast_tls.liq))) + +(rule + (alias citest) + (package liquidsoap) + (deps + ../../src/bin/liquidsoap.exe + ./icecast_ssl_tls.liq + ./ssl.cert + ./ssl.key + (package liquidsoap) + (:stdlib ../../src/libs/stdlib.liq) + (:test_liq ../test.liq) + (:run_test ../run_test.exe)) + (action + (run + %{run_test} + "Icecast SSL+TLS connection" + liquidsoap + --no-stdlib + %{stdlib} + %{test_liq} + ./icecast_ssl_tls.liq))) + +(rule + (alias citest) + (package liquidsoap) + (deps + ../../src/bin/liquidsoap.exe + ./icecast_tls_ssl.liq + ./ssl.cert + ./ssl.key + (package liquidsoap) + (:stdlib ../../src/libs/stdlib.liq) + (:test_liq ../test.liq) + (:run_test ../run_test.exe)) + (action + (run + %{run_test} + "Icecast TLS+SSL connection" + liquidsoap + --no-stdlib + %{stdlib} + %{test_liq} + ./icecast_tls_ssl.liq))) diff --git a/tests/streams/dune.inc b/tests/streams/dune.inc index 2743c334b9..1a2d7f41f6 100644 --- a/tests/streams/dune.inc +++ b/tests/streams/dune.inc @@ -395,28 +395,6 @@ (:run_test ../run_test.exe)) (action (run %{run_test} smart-crossfade.liq liquidsoap %{test_liq} smart-crossfade.liq))) -(rule - (alias citest) - (package liquidsoap) - (deps - icecast_ssl.liq - ./file1.mp3 - ./file2.mp3 - ./file3.mp3 - ./jingle1.mp3 - ./jingle2.mp3 - ./jingle3.mp3 - ./file1.png - ./file2.png - ./jingles - ./playlist - ./huge_playlist - ../../src/bin/liquidsoap.exe - (package liquidsoap) - (:test_liq ../test.liq) - (:run_test ../run_test.exe)) - (action (run %{run_test} icecast_ssl.liq liquidsoap %{test_liq} icecast_ssl.liq))) - (rule (alias citest) (package liquidsoap) diff --git a/tests/streams/gen_dune.ml b/tests/streams/gen_dune.ml index 67aaf830f7..072fac89d3 100644 --- a/tests/streams/gen_dune.ml +++ b/tests/streams/gen_dune.ml @@ -1,8 +1,18 @@ +let static_tests = + [ + "icecast_ssl.liq"; + "icecast_tls.liq"; + "icecast_tls_ssl.liq"; + "icecast_ssl_tls.liq"; + ] + let () = let location = Sys.getcwd () in let tests = List.filter - (fun f -> Filename.extension f = ".liq") + (fun f -> + (not (List.mem (Filename.basename f) static_tests)) + && Filename.extension f = ".liq") (Array.to_list (Sys.readdir location)) in List.iter diff --git a/tests/streams/icecast_ssl.liq b/tests/streams/icecast_ssl.liq index bced1fb32c..244c9b2f07 100644 --- a/tests/streams/icecast_ssl.liq +++ b/tests/streams/icecast_ssl.liq @@ -11,7 +11,7 @@ output.icecast( port=port, mount="ssl_test", transport=transport, - %mp3, + %vorbis, s) i = input.harbor( diff --git a/tests/streams/icecast_ssl_tls.liq b/tests/streams/icecast_ssl_tls.liq new file mode 100644 index 0000000000..d9907a356c --- /dev/null +++ b/tests/streams/icecast_ssl_tls.liq @@ -0,0 +1,32 @@ +log.level := 4 + +tls = http.transport.tls( + certificate="./ssl.cert", + key="./ssl.key" +) + +ssl = http.transport.ssl( + certificate="./ssl.cert", + key="./ssl.key" +) + +port = random.int(min=8000, max=10000) + +s = sine() + +output.icecast( + port=port, + mount="tls_test", + transport=ssl, + %vorbis, + s) + +i = input.harbor( + buffer=2., + port=port, + transport=tls, + "tls_test") + +i = source.on_track(i, fun (_) -> test.pass()) + +output.dummy(fallible=true, i) diff --git a/tests/streams/icecast_tls.liq b/tests/streams/icecast_tls.liq new file mode 100644 index 0000000000..892b5b7c4c --- /dev/null +++ b/tests/streams/icecast_tls.liq @@ -0,0 +1,27 @@ +log.level := 4 + +transport = http.transport.tls( + certificate="./ssl.cert", + key="./ssl.key" +) + +port = random.int(min=8000, max=10000) + +s = sine() + +output.icecast( + port=port, + mount="tls_test", + transport=transport, + %vorbis, + s) + +i = input.harbor( + buffer=2., + port=port, + transport=transport, + "tls_test") + +i = source.on_track(i, fun (_) -> test.pass()) + +output.dummy(fallible=true, i) diff --git a/tests/streams/icecast_tls_ssl.liq b/tests/streams/icecast_tls_ssl.liq new file mode 100644 index 0000000000..15c820f2cd --- /dev/null +++ b/tests/streams/icecast_tls_ssl.liq @@ -0,0 +1,32 @@ +log.level := 4 + +tls = http.transport.tls( + certificate="./ssl.cert", + key="./ssl.key" +) + +ssl = http.transport.ssl( + certificate="./ssl.cert", + key="./ssl.key" +) + +port = random.int(min=8000, max=10000) + +s = sine() + +output.icecast( + port=port, + mount="tls_test", + transport=tls, + %vorbis, + s) + +i = input.harbor( + buffer=2., + port=port, + transport=ssl, + "tls_test") + +i = source.on_track(i, fun (_) -> test.pass()) + +output.dummy(fallible=true, i) diff --git a/tls-liquidsoap.opam b/tls-liquidsoap.opam new file mode 100644 index 0000000000..9d7fd8797c --- /dev/null +++ b/tls-liquidsoap.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "2.2.0" +synopsis: "Liquidosap dependencies for TLS optional features" +maintainer: ["The Savonet Team "] +authors: ["The Savonet Team "] +license: "GPL-2.0-or-later" +homepage: "https://github.com/savonet/liquidsoap" +bug-reports: "https://github.com/savonet/liquidsoap/issues" +depends: [ + "dune" {>= "3.2"} + "tls" + "ca-certs" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "--promote-install-files=false" + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] + ["dune" "install" "-p" name "--create-install-files" name] +] +dev-repo: "git+https://github.com/savonet/liquidsoap.git"