Skip to content

Commit

Permalink
conduit-lwt-unix: allow users to configure client ssl verification
Browse files Browse the repository at this point in the history
The only options allowed are whether the hostname or the IP are used to
validate the remote host's certificate

Signed-off-by: Pau Ruiz Safont <pau.safont@citrix.com>
  • Loading branch information
psafont committed Nov 30, 2022
1 parent 5cdd0f5 commit 4f88d42
Show file tree
Hide file tree
Showing 6 changed files with 18 additions and 8 deletions.
16 changes: 11 additions & 5 deletions src/conduit-lwt-unix/conduit_lwt_unix.ml
Original file line number Diff line number Diff line change
Expand Up @@ -108,6 +108,7 @@ type ctx = {
src : Unix.sockaddr option;
tls_own_key : tls_own_key;
tls_authenticator : Conduit_lwt_tls.X509.authenticator;
ssl_client_verify : Conduit_lwt_unix_ssl.Client.verify;
ssl_ctx : Ssl.context;
}

Expand Down Expand Up @@ -155,21 +156,25 @@ let default_ctx =
src = None;
tls_own_key = `None;
tls_authenticator = Lazy.force Conduit_lwt_tls.X509.default_authenticator;
ssl_client_verify = Conduit_lwt_unix_ssl.Client.default_verify;
ssl_ctx = Conduit_lwt_unix_ssl.Client.default_ctx;
}

let init ?src ?(tls_own_key = `None)
?(tls_authenticator = Lazy.force Conduit_lwt_tls.X509.default_authenticator)
?(ssl_ctx = Conduit_lwt_unix_ssl.Client.default_ctx) () =
?(ssl_ctx = Conduit_lwt_unix_ssl.Client.default_ctx)
?(ssl_client_verify = Conduit_lwt_unix_ssl.Client.default_verify) () =
let no_source_ctx =
{ src = None; tls_own_key; tls_authenticator; ssl_ctx; ssl_client_verify }
in
match src with
| None -> Lwt.return { src = None; tls_own_key; tls_authenticator; ssl_ctx }
| None -> Lwt.return no_source_ctx
| Some host -> (
let open Unix in
Lwt_unix.getaddrinfo host "0" [ AI_PASSIVE; AI_SOCKTYPE SOCK_STREAM ]
>>= function
| { ai_addr; _ } :: _ ->
Lwt.return
{ src = Some ai_addr; tls_own_key; tls_authenticator; ssl_ctx }
Lwt.return { no_source_ctx with src = Some ai_addr }
| [] -> Lwt.fail_with "Invalid conduit source address specified")

module Sockaddr_io = struct
Expand Down Expand Up @@ -296,7 +301,8 @@ let connect_with_openssl ~ctx (`Hostname hostname, `IP ip, `Port port) =
in
ctx_ssl
in
Conduit_lwt_unix_ssl.Client.connect ~ctx:ctx_ssl ?src:ctx.src ~hostname ~ip sa
Conduit_lwt_unix_ssl.Client.connect ~ctx:ctx_ssl ?src:ctx.src ~hostname ~ip
~verify:ctx.ssl_client_verify sa
>>= fun (fd, ic, oc) ->
let flow = TCP { fd; ip; port } in
Lwt.return (flow, ic, oc)
Expand Down
1 change: 1 addition & 0 deletions src/conduit-lwt-unix/conduit_lwt_unix.mli
Original file line number Diff line number Diff line change
Expand Up @@ -162,6 +162,7 @@ val init :
?tls_own_key:tls_own_key ->
?tls_authenticator:Conduit_lwt_tls.X509.authenticator ->
?ssl_ctx:Ssl.context ->
?ssl_client_verify:Conduit_lwt_unix_ssl.Client.verify ->
unit ->
ctx io
(** [init ?src ?tls_own_key ?tls_authenticator ?ssl_ctx ()] will initialize a
Expand Down
1 change: 1 addition & 0 deletions src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.ml
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@
module Client = struct
type verify = { hostname : bool; ip : bool }

let default_verify = { hostname = true; ip = true }
let default_ctx = `Ssl_not_available
let create_ctx ?certfile:_ ?keyfile:_ ?password:_ () = default_ctx

Expand Down
1 change: 1 addition & 0 deletions src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.mli
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@
module Client : sig
type verify = { hostname : bool; ip : bool }

val default_verify : verify
val default_ctx : [ `Ssl_not_available ]

val create_ctx :
Expand Down
6 changes: 3 additions & 3 deletions src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.ml
Original file line number Diff line number Diff line change
Expand Up @@ -54,6 +54,8 @@ module Client = struct

type verify = { hostname : bool; ip : bool }

let default_verify = { hostname = true; ip = false }

let verification { hostname; ip } = function
| None, _ when hostname -> invalid_arg "impossible to verify hostname"
| _, None when ip -> invalid_arg "impossible to verify ip"
Expand All @@ -80,9 +82,7 @@ module Client = struct
| Some src_sa -> Lwt_unix.bind fd src_sa)
>>= fun () ->
Lwt_unix.connect fd sa >>= fun () ->
let verify =
Option.value ~default:{ hostname = true; ip = false } verify
in
let verify = Option.value ~default:default_verify verify in
let with_socket f =
let s = Lwt_ssl.embed_uninitialized_socket fd ctx in
let socket = Lwt_ssl.ssl_socket_of_uninitialized_socket s in
Expand Down
1 change: 1 addition & 0 deletions src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.mli
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@
module Client : sig
type verify = { hostname : bool; ip : bool }

val default_verify : verify
val default_ctx : Ssl.context

val create_ctx :
Expand Down

0 comments on commit 4f88d42

Please sign in to comment.