Refactor: Move to new files

Signed-off-by: Changlei Li <changlei.li@cloud.com>

Author: changlei-li

ocaml/libs/stunnel/stunnel.ml

@@ -13,7 +13,12 @@
  *)
 (* Copyright (C) 2007 XenSource Inc *)
 
-module D = Debug.Make (struct let name = "stunnel" end)
+(* module D = Debug.Make (struct let name = "stunnel" end) *)
+module D = struct
+  let debug fmt = Printf.ksprintf (fun s -> Printf.printf "%s\n" s) fmt
+
+  let error fmt = Printf.ksprintf (fun s -> Printf.printf "%s\n" s) fmt
+end
 
 open Printf
 open Xapi_stdext_unix
@@ -135,11 +140,6 @@ type t = {
   ; verified: verification_config option
 }
 
-type stunnel_error =
-  | Certificate_verify of string list
-  | Stunnel of string
-  | Unknown of string
-
 let appliance =
   {
     sni= None
@@ -501,134 +501,21 @@ let with_client_proxy_systemd_service ~verify_cert ~remote_host ~remote_port
     )
     (fun () -> Unixext.unlink_safe conf_path)
 
-type log_line_status = Continue | LineFound | LineError of stunnel_error
-
-type log_scan_result =
-  | End of int
-  | ScanError of stunnel_error * int
-  | ScanFound of int
-
-let try_iter f lst =
-  let rec aux = function
-    | [] ->
-        Continue
-    | x :: xs -> (
-      match f x with Continue -> aux xs | other -> other
-    )
-  in
-  aux lst
-
-(** Monadic bind for log_line_status composition *)
-let ( >>= ) check1 check2 line =
-  match check1 line with Continue -> check2 line | other -> other
-
-let check_stunnel_error line =
-  [
-    "Configuration failed"
-  ; "Connection refused"
-  ; "No host resolved"
-  ; "No route to host"
-  ; "Invalid argument"
-  ; "Address already in use"
-  ]
-  |> try_iter (fun s ->
-      if Astring.String.is_infix ~affix:s line then
-        LineError (Stunnel s)
-      else
-        Continue
-  )
-
-let check_verify_error cert_errors line =
-  (* When verified with a mismatched certificate, one line of log from stunnel
-   * would look like:
-     SSL_connect: ssl/statem/statem_clnt.c:1889: error:0A000086:SSL routines::certificate verify failed
-   * in this case, Stunnel_verify_error can be raised with detailed error as
-   * reason if it can found in the log *)
-  if Astring.String.is_infix ~affix:"certificate verify failed" line then
-    LineError (Certificate_verify cert_errors)
-  else
-    Continue
-
-(** Stream through lines from a specific position, applying function to each.
-    Returns new_position. Stops early on Error. *)
-let stream_from_position (filepath : string) (start_pos : int)
-    (f : string -> log_line_status) : log_scan_result =
-  try
-    let fd = Unix.openfile filepath [Unix.O_RDONLY] 0 in
-    let finally = Xapi_stdext_pervasives.Pervasiveext.finally in
-    finally
-      (fun () ->
-        let _ = Unix.lseek fd start_pos Unix.SEEK_SET in
-        let ic = Unix.in_channel_of_descr fd in
-        let rec loop () =
-          match input_line ic with
-          | exception End_of_file ->
-              let end_pos = (Unix.fstat fd).Unix.st_size in
-              End end_pos
-          | line -> (
-            match f line with
-            | Continue ->
-                loop ()
-            | LineError e ->
-                let pos = Unix.lseek fd 0 Unix.SEEK_CUR in
-                ScanError (e, pos)
-            | LineFound ->
-                let pos = Unix.lseek fd 0 Unix.SEEK_CUR in
-                ScanFound pos
-          )
-        in
-        loop ()
-      )
-      (fun () -> Unix.close fd)
-  with
-  | Unix.Unix_error (err, fn, arg) ->
-      ScanError
-        ( Stunnel (Printf.sprintf "%s: %s(%s)" (Unix.error_message err) fn arg)
-        , start_pos )
-  | e ->
-      ScanError (Stunnel (Printexc.to_string e), start_pos)
-
-let check_stunnel_logfile_from_position logfile start_pos =
-  let cert_errors = ref [] in
-  let check_line line =
-    !stunnel_logger line ;
-    Astring.String.cut ~rev:true ~sep:"CERT: " line
-    |> Option.iter (fun (_, cert_error) ->
-        cert_errors := cert_error :: !cert_errors
-    ) ;
-    match check_verify_error !cert_errors line with
-    | Continue ->
-        check_stunnel_error line
-    | other ->
-        other
-  in
-  stream_from_position logfile start_pos check_line
-
 let diagnose_failure st_proc =
-  match check_stunnel_logfile_from_position st_proc.logfile 0 with
+  let open Stunnel_log_scanner in
+  match
+    check_stunnel_logfile_from_position
+      (fun s -> !stunnel_logger s)
+      st_proc.logfile 0
+  with
   | End _ | ScanFound _ ->
       ()
-  | ScanError (Certificate_verify reasons, _pos) ->
+  | ScanError (Stunnel_error.Certificate_verify reasons, _pos) ->
       raise (Stunnel_verify_error reasons)
-  | ScanError (Stunnel reason, _pos) | ScanError (Unknown reason, _pos) ->
+  | ScanError (Stunnel_error.Stunnel reason, _pos)
+  | ScanError (Stunnel_error.Unknown reason, _pos) ->
       raise (Stunnel_error reason)
 
-(* check stunnel log, until *)
-let check_stunnel_log_until logfile check_line interval count start_pos =
-  let rec check ~max_retries cnt start_pos =
-    Thread.delay interval ;
-    match stream_from_position logfile start_pos check_line with
-    | End new_pos when cnt <= max_retries ->
-        check ~max_retries (cnt + 1) new_pos
-    | ScanError (e, _pos) ->
-        Error e
-    | ScanFound new_pos ->
-        Ok new_pos
-    | End _ ->
-        Error (Stunnel "Timed out waiting for stunnel condition")
-  in
-  check ~max_retries:count 0 start_pos
-
 module UnixSocketProxy = struct
   (** Handle for a long-running stunnel proxy *)
   type t = {
@@ -653,7 +540,7 @@ module UnixSocketProxy = struct
   let diagnose handle =
     let start_pos = handle.last_checked_position in
     let current_size = (Unix.stat handle.proxy_logfile).Unix.st_size in
-
+    let open Stunnel_log_scanner in
     if current_size <= start_pos then (
       D.debug "%s: no new log entries (position %d)" __FUNCTION__ start_pos ;
       Ok ()
@@ -675,7 +562,9 @@ module UnixSocketProxy = struct
         )
         (fun () -> Unix.close fd) ;
       match
-        check_stunnel_logfile_from_position handle.proxy_logfile start_pos
+        check_stunnel_logfile_from_position
+          (fun s -> !stunnel_logger s)
+          handle.proxy_logfile start_pos
       with
       | End pos | ScanFound pos ->
           handle.last_checked_position <- pos ;
@@ -686,24 +575,18 @@ module UnixSocketProxy = struct
     )
 
   let wait_for_init_done logfile =
-    let check_init_success line =
-      if Astring.String.is_infix ~affix:"Configuration successful" line then
-        LineFound
-      else
-        Continue
-    in
-    let check_line = check_init_success >>= check_stunnel_error in
+    let open Stunnel_log_scanner in
+    let check_line = check_configuration_success >>= check_stunnel_error in
     check_stunnel_log_until logfile check_line 1.0 3 0
 
   let wait_for_connection_done logfile start_pos =
-    let certs = ref [] in
-    let connected line =
-      if Astring.String.is_infix ~affix:"connected remote server from" line then
-        LineFound
-      else
-        Continue
+    let open Stunnel_log_scanner in
+    let check_verify_error = make_check_verify_error () in
+    let check_line =
+      check_connection_established
+      >>= check_verify_error
+      >>= check_stunnel_error
     in
-    let check_line = connected >>= check_verify_error !certs in
     check_stunnel_log_until logfile check_line 1.0 10 start_pos
 
   (** Start a long-running stunnel proxy listening on a UNIX socket.
@@ -719,8 +602,9 @@ module UnixSocketProxy = struct
       is not started. If successful, subsequent connections by stubs will also
       be verified automatically by stunnel. *)
   let start ~verify_cert ~remote_host ~remote_port ?unix_socket_path
-      ?socket_mode () =
+      ?socket_mode ?(test_connection = true) () =
     let ( let* ) = Result.bind in
+    let open Stunnel_error in
     let unix_socket_path =
       match unix_socket_path with
       | Some path ->
@@ -781,22 +665,28 @@ module UnixSocketProxy = struct
     D.debug "%s: started stunnel proxy (pid:%d):%s -> %s:%d log: %s"
       __FUNCTION__ (getpid pid) unix_socket_path remote_host remote_port logfile ;
 
-    (* Make initial connection to verify certificate *)
-    let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
-    let finally = Xapi_stdext_pervasives.Pervasiveext.finally in
+    (* Optionally make initial connection to verify certificate *)
     let* pos =
-      finally
-        (fun () ->
-          Unix.connect sock (Unix.ADDR_UNIX unix_socket_path) ;
-          (* Wait for TLS handshake and certificate verification *)
-          wait_for_connection_done logfile pos
-          |> Result.map_error (fun e ->
-              D.error "%s: stunnel connection failed" __FUNCTION__ ;
-              clean_up () ;
-              e
+      if test_connection then (
+        D.debug "%s: performing initial connection test" __FUNCTION__ ;
+        let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+        let finally = Xapi_stdext_pervasives.Pervasiveext.finally in
+        finally
+          (fun () ->
+            Unix.connect sock (Unix.ADDR_UNIX unix_socket_path) ;
+            (* Wait for TLS handshake and certificate verification *)
+            wait_for_connection_done logfile pos
+            |> Result.map_error (fun e ->
+                D.error "%s: stunnel connection failed" __FUNCTION__ ;
+                clean_up () ;
+                e
+            )
           )
-        )
-        (fun () -> Unix.close sock)
+          (fun () -> Unix.close sock)
+      ) else (
+        D.debug "%s: skipping initial connection test" __FUNCTION__ ;
+        Ok pos
+      )
     in
 
     let handle =
@@ -829,10 +719,10 @@ module UnixSocketProxy = struct
       If [socket_mode] is provided, stunnel will set the socket file permissions.
       This is the preferred way to use the proxy for most use cases. *)
   let with_proxy ~verify_cert ~remote_host ~remote_port ?unix_socket_path
-      ?socket_mode f =
+      ?socket_mode ?test_connection f =
     match
       start ~verify_cert ~remote_host ~remote_port ?unix_socket_path
-        ?socket_mode ()
+        ?socket_mode ?test_connection ()
     with
     | Error _ as e ->
         e

ocaml/libs/stunnel/stunnel.mli

@@ -55,11 +55,6 @@ type t = {
   ; verified: verification_config option
 }
 
-type stunnel_error =
-  | Certificate_verify of string list
-  | Stunnel of string
-  | Unknown of string
-
 module UnixSocketProxy : sig
   (** Handle for a long-running stunnel proxy that exposes TLS connection
       via a UNIX socket file *)
@@ -76,20 +71,25 @@ module UnixSocketProxy : sig
     -> remote_port:int
     -> ?unix_socket_path:string
     -> ?socket_mode:int
+    -> ?test_connection:bool
     -> unit
-    -> (t, stunnel_error) result
+    -> (t, Stunnel_error.t) result
   (** Start a long-running stunnel proxy listening on a UNIX socket.
 
-      This function starts the proxy and immediately performs certificate
-      verification by making an initial test connection. If certificate 
-      verification fails, the proxy is stopped and cleaned up automatically.
+      Returns [Ok handle] if stunnel starts successfully. If [test_connection]
+      is [true] (the default), performs an immediate certificate verification
+      test connection. If certificate verification fails, the proxy is stopped
+      and cleaned up automatically.
+
+      Set [~test_connection:false] to skip the initial connection test and
+      only verify that stunnel initializes successfully. Certificate validation
+      will then happen on the first actual connection.
 
-      Returns [Ok handle] if stunnel starts successfully and the certificate
-      is valid. Returns [Error] if stunnel fails to start, initialize, or
-      if certificate verification fails.
+      Returns [Error] if stunnel fails to start, initialize, or (when
+      [test_connection] is [true]) if certificate verification fails.
 
       If [unix_socket_path] is not provided, a unique path will be generated
-      automatically in /var/run with the format:
+      automatically in /tmp with the format:
       stunnel-proxy-{host}-{port}-{uuid}.sock
 
       If [socket_mode] is provided (e.g., [~socket_mode:0o666]), the socket
@@ -99,7 +99,7 @@ module UnixSocketProxy : sig
   (** Stop a running stunnel proxy and clean up resources.
       This kills the stunnel process and removes the socket and log files. *)
 
-  val diagnose : t -> (unit, stunnel_error) result
+  val diagnose : t -> (unit, Stunnel_error.t) result
   (** Diagnose the status of a running stunnel proxy by checking its logfile.
 
       Only checks NEW log entries since the last call to [diagnose] (or since
@@ -114,12 +114,14 @@ module UnixSocketProxy : sig
     -> remote_port:int
     -> ?unix_socket_path:string
     -> ?socket_mode:int
-    -> (t -> ('a, stunnel_error) result)
-    -> ('a, stunnel_error) result
+    -> ?test_connection:bool
+    -> (t -> ('a, Stunnel_error.t) result)
+    -> ('a, Stunnel_error.t) result
   (** Start a proxy, execute a function with it, and automatically stop it.
       The proxy is guaranteed to be stopped even if the function raises an exception.
       If [unix_socket_path] is not provided, a unique path will be generated.
       If [socket_mode] is provided, stunnel will set the socket file permissions.
+      If [test_connection] is [true] (default), performs initial certificate verification.
       This is the preferred way to use the proxy for most use cases. *)
 end
 

ocaml/libs/stunnel/stunnel_error.ml

@@ -0,0 +1,20 @@
+(*
+ * Copyright (c) Cloud Software Group, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * 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 Lesser General Public License for more details.
+ *)
+
+(** Stunnel error types shared between modules *)
+
+type t =
+  | Certificate_verify of string list
+  | Stunnel of string
+  | Unknown of string