Skip to content
Permalink
Browse files

record tls fingerprint in config (depends on unmerged PRs in x.509 an…

…d tls)
  • Loading branch information...
hannesm committed Dec 4, 2014
1 parent ddbbdf5 commit a1e6f3159be1e45e6b690845e1b29366c41239a2
Showing with 27 additions and 12 deletions.
  1. +9 −3 cli/cli_config.ml
  2. +13 −6 src/config.ml
  3. +4 −1 src/xmpp_callbacks.ml
  4. +1 −2 src/xmpp_connection.ml
@@ -74,8 +74,14 @@ let configure term () =
else return_unit ) >>= fun () ->
(new read_password term)#run >>= fun password ->
(* trust anchor *)
(new read_inputline ~term ~prompt:"enter path to trust anchor: " ())#run >>= fun trust_anchor ->
Lwt_unix.access trust_anchor [ Unix.F_OK ; Unix.R_OK ] >>= fun () ->
read_yes_no term "Provide trust anchor (alternative: tls server fingerprint)?" >>= fun ta ->
( if ta then
(new read_inputline ~term ~prompt:"enter path to trust anchor: " ())#run >>= fun trust_anchor ->
Lwt_unix.access trust_anchor [ Unix.F_OK ; Unix.R_OK ] >|= fun () ->
(Some trust_anchor, None)
else
(new read_inputline ~term ~prompt:"enter server certificate fingerprint (by running for example `openssl s_client -connect jabber.ccc.de:5222 -starttls xmpp | openssl x509 -sha256 -fingerprint -noout`): " ())#run >|= fun fp ->
(None, Some fp) ) >>= fun (trust_anchor, tls_fingerprint) ->
(* otr config *)
LTerm.fprintl term "OTR config" >>= fun () ->
read_yes_no term "Protocol version 2 support (recommended)" >>= fun v2 ->
@@ -97,5 +103,5 @@ let configure term () =
if error_starts then [`ERROR_START_AKE] else [] ]
in
let otr_config = { Otr.State.versions = versions ; Otr.State.policies = policies ; Otr.State.dsa = dsa } in
let config = Config.({ version = 0 ; jid ; port ; password ; trust_anchor ; otr_config }) in
let config = Config.({ version = 0 ; jid ; port ; password ; trust_anchor ; tls_fingerprint ; otr_config }) in
return config
@@ -7,16 +7,18 @@ type t = {
jid : JID.t ;
port : int ;
password : string ;
trust_anchor : string ;
trust_anchor : string option ;
tls_fingerprint : string option ;
otr_config : Otr.State.config ;
}

let empty = {
version = 0 ;
version = 1 ;
jid = JID.of_string "user@server/resource" ;
port = 5222 ;
password = "" ;
trust_anchor = "" ;
trust_anchor = None ;
tls_fingerprint = None ;
otr_config = Otr.State.default_config
}

@@ -34,8 +36,12 @@ let t_of_sexp t =
{ t with port = int_of_sexp port }
| Sexp.List [ Sexp.Atom "password" ; Sexp.Atom password ] ->
{ t with password }
| Sexp.List [ Sexp.Atom "trust_anchor" ; Sexp.Atom trust_anchor ] ->
{ t with trust_anchor }
| Sexp.List [ Sexp.Atom "trust_anchor" ; trust_anchor ] ->
(match t.version with
| 0 -> { t with trust_anchor = Some (string_of_sexp trust_anchor) }
| _ -> { t with trust_anchor = option_of_sexp string_of_sexp trust_anchor } )
| Sexp.List [ Sexp.Atom "tls_fingerprint" ; tls_fp ] ->
{ t with tls_fingerprint = option_of_sexp string_of_sexp tls_fp }
| Sexp.List [ Sexp.Atom "otr_config" ; v ] ->
{ t with otr_config = Otr.State.config_of_sexp v }
| _ -> assert false)
@@ -51,7 +57,8 @@ let sexp_of_t t =
"jid" , sexp_of_string (JID.string_of_jid t.jid) ;
"port" , sexp_of_int t.port ;
"password" , sexp_of_string t.password ;
"trust_anchor" , sexp_of_string t.trust_anchor ;
"trust_anchor" , sexp_of_option sexp_of_string t.trust_anchor ;
"tls_fingerprint" , sexp_of_option sexp_of_string t.tls_fingerprint ;
"otr_config" , Otr.State.sexp_of_config t.otr_config ;
]

@@ -247,7 +247,10 @@ let connect config user_data _ =
include PlainSocket
end in
let make_tls () =
TLSSocket.switch (PlainSocket.get_fd socket_data) server config.trust_anchor >>= fun socket_data ->
(match config.trust_anchor, config.tls_fingerprint with
| Some x, None -> X509_lwt.authenticator (`Ca_file x)
| None, Some fp -> X509_lwt.authenticator (`Fingerprint fp) ) >>= fun authenticator ->
TLSSocket.switch (PlainSocket.get_fd socket_data) server authenticator >>= fun socket_data ->
let module TLS_module = struct type t = Tls_lwt.Unix.t
let socket = socket_data
include TLSSocket
@@ -59,8 +59,7 @@ struct
print_endline str;
Tls_lwt.Unix.write s (Cstruct.of_string str)

let switch fd host trust_anchor =
X509_lwt.authenticator (`Ca_file trust_anchor) >>= fun authenticator ->
let switch fd host authenticator =
let config = Tls.Config.client ~authenticator () in
Tls_lwt.Unix.client_of_fd config ~host fd

0 comments on commit a1e6f31

Please sign in to comment.
You can’t perform that action at this time.