commit 4b5aad70a424917e1bdc12d468e0abb60407fc52 · anil.recoil.org/ocaml-conpool

+28

lib/config.ml

···

       30
        
           ?on_connection_closed

     

       31
        
           ?on_connection_reused

     

       32
        
           () =

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       33
        
         Log.debug (fun m ->

     

       34
        
           m "Creating config: max_connections=%d, max_idle=%.1fs, max_lifetime=%.1fs"

     

       35
        
             max_connections_per_endpoint max_idle_time max_connection_lifetime);

···

       30
        
           ?on_connection_closed

     

       31
        
           ?on_connection_reused

     

       32
        
           () =

     

       33
       +
         (* Validate parameters *)

     

       34
       +
         if max_connections_per_endpoint <= 0 then

     

       35
       +
           invalid_arg (Printf.sprintf "max_connections_per_endpoint must be positive, got %d"

     

       36
       +
             max_connections_per_endpoint);

     

       37
       +
       

     

       38
       +
         if max_idle_time <= 0.0 then

     

       39
       +
           invalid_arg (Printf.sprintf "max_idle_time must be positive, got %.2f" max_idle_time);

     

       40
       +
       

     

       41
       +
         if max_connection_lifetime <= 0.0 then

     

       42
       +
           invalid_arg (Printf.sprintf "max_connection_lifetime must be positive, got %.2f"

     

       43
       +
             max_connection_lifetime);

     

       44
       +
       

     

       45
       +
         (match max_connection_uses with

     

       46
       +
          | Some n when n <= 0 ->

     

       47
       +
              invalid_arg (Printf.sprintf "max_connection_uses must be positive, got %d" n)

     

       48
       +
          | _ -> ());

     

       49
       +
       

     

       50
       +
         if connect_timeout <= 0.0 then

     

       51
       +
           invalid_arg (Printf.sprintf "connect_timeout must be positive, got %.2f" connect_timeout);

     

       52
       +
       

     

       53
       +
         if connect_retry_count < 0 then

     

       54
       +
           invalid_arg (Printf.sprintf "connect_retry_count must be non-negative, got %d"

     

       55
       +
             connect_retry_count);

     

       56
       +
       

     

       57
       +
         if connect_retry_delay <= 0.0 then

     

       58
       +
           invalid_arg (Printf.sprintf "connect_retry_delay must be positive, got %.2f"

     

       59
       +
             connect_retry_delay);

     

       60
       +
       

     

       61
        
         Log.debug (fun m ->

     

       62
        
           m "Creating config: max_connections=%d, max_idle=%.1fs, max_lifetime=%.1fs"

     

       63
        
             max_connections_per_endpoint max_idle_time max_connection_lifetime);

+15 -3

lib/connection.ml

···

       9
        
         mutable last_used : float;

     

       10
        
         mutable use_count : int;

     

       11
        
         endpoint : Endpoint.t;

     

       0
        
       
     

       12
        
       }

     

       13
        
       

     

       14
        
       let flow t = t.flow

     

       15
        
       let endpoint t = t.endpoint

     

       16
        
       let created_at t = t.created_at

     

       17
       -
       let last_used t = t.last_used

     

       18
       -
       let use_count t = t.use_count

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       19
        
       

     

       20
        
       let pp ppf t =

     

       0
        
       
     

       21
        
         Fmt.pf ppf "Connection(endpoint=%a, age=%.2fs, uses=%d)"

     

       22
        
           Endpoint.pp t.endpoint

     

       23
        
           (Unix.gettimeofday () -. t.created_at)

     

       24
       -
           t.use_count

···

       9
        
         mutable last_used : float;

     

       10
        
         mutable use_count : int;

     

       11
        
         endpoint : Endpoint.t;

     

       12
       +
         mutex : Eio.Mutex.t;

     

       13
        
       }

     

       14
        
       

     

       15
        
       let flow t = t.flow

     

       16
        
       let endpoint t = t.endpoint

     

       17
        
       let created_at t = t.created_at

     

       18
       +
       

     

       19
       +
       let last_used t =

     

       20
       +
         Eio.Mutex.use_ro t.mutex (fun () -> t.last_used)

     

       21
       +
       

     

       22
       +
       let use_count t =

     

       23
       +
         Eio.Mutex.use_ro t.mutex (fun () -> t.use_count)

     

       24
       +
       

     

       25
       +
       let update_usage t ~now =

     

       26
       +
         Eio.Mutex.use_rw ~protect:true t.mutex (fun () ->

     

       27
       +
           t.last_used <- now;

     

       28
       +
           t.use_count <- t.use_count + 1

     

       29
       +
         )

     

       30
        
       

     

       31
        
       let pp ppf t =

     

       32
       +
         let uses = Eio.Mutex.use_ro t.mutex (fun () -> t.use_count) in

     

       33
        
         Fmt.pf ppf "Connection(endpoint=%a, age=%.2fs, uses=%d)"

     

       34
        
           Endpoint.pp t.endpoint

     

       35
        
           (Unix.gettimeofday () -. t.created_at)

     

       36
       +
           uses

+50 -15

lib/conpool.ml

···

       10
        
       module Stats = Stats

     

       11
        
       module Cmd = Cmd

     

       12
        
       

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       13
        
       type endp_stats = {

     

       14
        
         mutable active : int;

     

       15
        
         mutable idle : int;

     
···

       77
        
             addr

     

       78
        
         | [] ->

     

       79
        
             Log.err (fun m -> m "Failed to resolve hostname: %s" (Endpoint.host endpoint));

     

       80
       -
             failwith (Printf.sprintf "Failed to resolve hostname: %s" (Endpoint.host endpoint))

     

       81
        
       

     

       82
        
       (** {1 Connection Creation with Retry} *)

     

       83
        
       

     

       84
       -
       let rec create_connection_with_retry (pool : ('clock, 'net) internal) endpoint attempt =

     

       85
        
         let retry_count = Config.connect_retry_count pool.config in

     

       86
        
         if attempt > retry_count then begin

     

       87
        
           Log.err (fun m -> m "Failed to connect to %a after %d attempts"

     

       88
        
             Endpoint.pp endpoint retry_count);

     

       89
       -
           failwith (Printf.sprintf "Failed to connect to %s:%d after %d attempts"

     

       90
       -
             (Endpoint.host endpoint) (Endpoint.port endpoint) retry_count)

     

       91
        
         end;

     

       92
        
       

     

       93
        
         Log.debug (fun m -> m "Connecting to %a (attempt %d/%d)"

     
···

       130
        
             last_used = now;

     

       131
        
             use_count = 0;

     

       132
        
             endpoint;

     

       0
        
       
     

       133
        
           }

     

       134
        
       

     

       135
        
         with

     

       136
       -
         | Eio.Time.Timeout ->

     

       137
        
             Log.warn (fun m -> m "Connection timeout to %a (attempt %d)" Endpoint.pp endpoint attempt);

     

       138
       -
             (* Exponential backoff *)

     

       139
       -
             let delay = Config.connect_retry_delay pool.config *. (2.0 ** float_of_int (attempt - 1)) in

     

       140
       -
             Eio.Time.sleep pool.clock delay;

     

       141
       -
             create_connection_with_retry pool endpoint (attempt + 1)

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       142
        
         | e ->

     

       143
        
             (* Other errors - retry with backoff *)

     

       0
        
       
     

       144
        
             Log.warn (fun m -> m "Connection attempt %d to %a failed: %s"

     

       145
       -
               attempt Endpoint.pp endpoint (Printexc.to_string e));

     

       146
        
             if attempt < Config.connect_retry_count pool.config then (

     

       147
        
               let delay = Config.connect_retry_delay pool.config *. (2.0 ** float_of_int (attempt - 1)) in

     

       148
        
               Eio.Time.sleep pool.clock delay;

     

       149
       -
               create_connection_with_retry pool endpoint (attempt + 1)

     

       150
        
             ) else

     

       151
       -
               raise e

     

       152
        
       

     

       153
        
       let create_connection (pool : ('clock, 'net) internal) endpoint =

     

       154
       -
         create_connection_with_retry pool endpoint 1

     

       155
        
       

     

       156
        
       (** {1 Connection Validation} *)

     

       157
        
       

     
···

       406
        
                 Endpoint.pp endpoint (Connection.use_count conn));

     

       407
        
       

     

       408
        
               (* Update last used time and use count *)

     

       409
       -
               conn.last_used <- get_time pool;

     

       410
       -
               conn.use_count <- conn.use_count + 1;

     

       411
        
       

     

       412
        
               (* Update idle stats (connection taken from idle pool) *)

     

       413
        
               Eio.Mutex.use_rw ~protect:true ep_pool.mutex (fun () ->

···

       10
        
       module Stats = Stats

     

       11
        
       module Cmd = Cmd

     

       12
        
       

     

       13
       +
       (** {1 Error Types} *)

     

       14
       +
       

     

       15
       +
       type error =

     

       16
       +
         | Dns_resolution_failed of { hostname : string }

     

       17
       +
         | Connection_failed of { endpoint : Endpoint.t; attempts : int; last_error : string }

     

       18
       +
         | Connection_timeout of { endpoint : Endpoint.t; timeout : float }

     

       19
       +
         | Invalid_config of string

     

       20
       +
         | Invalid_endpoint of string

     

       21
       +
       

     

       22
       +
       exception Pool_error of error

     

       23
       +
       

     

       24
       +
       let pp_error ppf = function

     

       25
       +
         | Dns_resolution_failed { hostname } ->

     

       26
       +
             Fmt.pf ppf "DNS resolution failed for hostname: %s" hostname

     

       27
       +
         | Connection_failed { endpoint; attempts; last_error } ->

     

       28
       +
             Fmt.pf ppf "Failed to connect to %a after %d attempts: %s"

     

       29
       +
               Endpoint.pp endpoint attempts last_error

     

       30
       +
         | Connection_timeout { endpoint; timeout } ->

     

       31
       +
             Fmt.pf ppf "Connection timeout to %a after %.2fs"

     

       32
       +
               Endpoint.pp endpoint timeout

     

       33
       +
         | Invalid_config msg ->

     

       34
       +
             Fmt.pf ppf "Invalid configuration: %s" msg

     

       35
       +
         | Invalid_endpoint msg ->

     

       36
       +
             Fmt.pf ppf "Invalid endpoint: %s" msg

     

       37
       +
       

     

       38
        
       type endp_stats = {

     

       39
        
         mutable active : int;

     

       40
        
         mutable idle : int;

     
···

       102
        
             addr

     

       103
        
         | [] ->

     

       104
        
             Log.err (fun m -> m "Failed to resolve hostname: %s" (Endpoint.host endpoint));

     

       105
       +
             raise (Pool_error (Dns_resolution_failed { hostname = Endpoint.host endpoint }))

     

       106
        
       

     

       107
        
       (** {1 Connection Creation with Retry} *)

     

       108
        
       

     

       109
       +
       let rec create_connection_with_retry (pool : ('clock, 'net) internal) endpoint attempt last_error =

     

       110
        
         let retry_count = Config.connect_retry_count pool.config in

     

       111
        
         if attempt > retry_count then begin

     

       112
        
           Log.err (fun m -> m "Failed to connect to %a after %d attempts"

     

       113
        
             Endpoint.pp endpoint retry_count);

     

       114
       +
           raise (Pool_error (Connection_failed { endpoint; attempts = retry_count; last_error }))

     

       0
        
       
     

       115
        
         end;

     

       116
        
       

     

       117
        
         Log.debug (fun m -> m "Connecting to %a (attempt %d/%d)"

     
···

       154
        
             last_used = now;

     

       155
        
             use_count = 0;

     

       156
        
             endpoint;

     

       157
       +
             mutex = Eio.Mutex.create ();

     

       158
        
           }

     

       159
        
       

     

       160
        
         with

     

       161
       +
         | Eio.Time.Timeout as e ->

     

       162
        
             Log.warn (fun m -> m "Connection timeout to %a (attempt %d)" Endpoint.pp endpoint attempt);

     

       163
       +
             let error_msg = Printexc.to_string e in

     

       164
       +
             if attempt >= Config.connect_retry_count pool.config then

     

       165
       +
               (* Last attempt - convert to our error type *)

     

       166
       +
               match Config.connect_timeout pool.config with

     

       167
       +
               | Some timeout ->

     

       168
       +
                   raise (Pool_error (Connection_timeout { endpoint; timeout }))

     

       169
       +
               | None ->

     

       170
       +
                   raise (Pool_error (Connection_failed { endpoint; attempts = attempt; last_error = error_msg }))

     

       171
       +
             else begin

     

       172
       +
               (* Retry with exponential backoff *)

     

       173
       +
               let delay = Config.connect_retry_delay pool.config *. (2.0 ** float_of_int (attempt - 1)) in

     

       174
       +
               Eio.Time.sleep pool.clock delay;

     

       175
       +
               create_connection_with_retry pool endpoint (attempt + 1) error_msg

     

       176
       +
             end

     

       177
        
         | e ->

     

       178
        
             (* Other errors - retry with backoff *)

     

       179
       +
             let error_msg = Printexc.to_string e in

     

       180
        
             Log.warn (fun m -> m "Connection attempt %d to %a failed: %s"

     

       181
       +
               attempt Endpoint.pp endpoint error_msg);

     

       182
        
             if attempt < Config.connect_retry_count pool.config then (

     

       183
        
               let delay = Config.connect_retry_delay pool.config *. (2.0 ** float_of_int (attempt - 1)) in

     

       184
        
               Eio.Time.sleep pool.clock delay;

     

       185
       +
               create_connection_with_retry pool endpoint (attempt + 1) error_msg

     

       186
        
             ) else

     

       187
       +
               raise (Pool_error (Connection_failed { endpoint; attempts = attempt; last_error = error_msg }))

     

       188
        
       

     

       189
        
       let create_connection (pool : ('clock, 'net) internal) endpoint =

     

       190
       +
         create_connection_with_retry pool endpoint 1 "No attempts made"

     

       191
        
       

     

       192
        
       (** {1 Connection Validation} *)

     

       193
        
       

     
···

       442
        
                 Endpoint.pp endpoint (Connection.use_count conn));

     

       443
        
       

     

       444
        
               (* Update last used time and use count *)

     

       445
       +
               Connection.update_usage conn ~now:(get_time pool);

     

       0
        
       
     

       446
        
       

     

       447
        
               (* Update idle stats (connection taken from idle pool) *)

     

       448
        
               Eio.Mutex.use_rw ~protect:true ep_pool.mutex (fun () ->

+27

lib/conpool.mli

···

       32
        
       (** Cmdliner terms for connection pool configuration *)

     

       33
        
       module Cmd : module type of Cmd

     

       34
        
       

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       35
        
       (** {1 Connection Pool} *)

     

       36
        
       

     

       37
        
       type t

···

       32
        
       (** Cmdliner terms for connection pool configuration *)

     

       33
        
       module Cmd : module type of Cmd

     

       34
        
       

     

       35
       +
       (** {1 Errors} *)

     

       36
       +
       

     

       37
       +
       type error =

     

       38
       +
         | Dns_resolution_failed of { hostname : string }

     

       39
       +
         (** DNS resolution failed for the given hostname *)

     

       40
       +
       

     

       41
       +
         | Connection_failed of { endpoint : Endpoint.t; attempts : int; last_error : string }

     

       42
       +
         (** Failed to establish connection after all retry attempts *)

     

       43
       +
       

     

       44
       +
         | Connection_timeout of { endpoint : Endpoint.t; timeout : float }

     

       45
       +
         (** Connection attempt timed out *)

     

       46
       +
       

     

       47
       +
         | Invalid_config of string

     

       48
       +
         (** Invalid configuration parameter *)

     

       49
       +
       

     

       50
       +
         | Invalid_endpoint of string

     

       51
       +
         (** Invalid endpoint specification *)

     

       52
       +
       

     

       53
       +
       exception Pool_error of error

     

       54
       +
       (** Exception raised by pool operations.

     

       55
       +
       

     

       56
       +
           Most pool operations can raise this exception. Use {!pp_error} to get

     

       57
       +
           human-readable error messages. *)

     

       58
       +
       

     

       59
       +
       val pp_error : error Fmt.t

     

       60
       +
       (** Pretty-printer for error values. *)

     

       61
       +
       

     

       62
        
       (** {1 Connection Pool} *)

     

       63
        
       

     

       64
        
       type t

lib/endpoint.ml

···

       9
        
       }

     

       10
        
       

     

       11
        
       let make ~host ~port =

     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       0
        
       
     

       12
        
         Log.debug (fun m -> m "Creating endpoint: %s:%d" host port);

     

       13
        
         { host; port }

     

       14

···

       9
        
       }

     

       10
        
       

     

       11
        
       let make ~host ~port =

     

       12
       +
         (* Validate port range *)

     

       13
       +
         if port < 1 || port > 65535 then

     

       14
       +
           invalid_arg (Printf.sprintf "Invalid port number: %d (must be 1-65535)" port);

     

       15
       +
       

     

       16
       +
         (* Validate hostname is not empty *)

     

       17
       +
         if String.trim host = "" then

     

       18
       +
           invalid_arg "Hostname cannot be empty";

     

       19
       +
       

     

       20
        
         Log.debug (fun m -> m "Creating endpoint: %s:%d" host port);

     

       21
        
         { host; port }

     

       22