Commit 3c8c0df8 authored by gerd's avatar gerd

Adding TLS support


git-svn-id: https://godirepo.camlcity.org/svn/lib-netamqp/trunk@5 e13cfc2c-0730-40e6-b03a-d8ac042e47ad
parent ea200e2c
#use "topfind";;
#require "netamqp,nettls-gnutls";;
open Netamqp_types
open Printf
let () =
Netamqp_endpoint.Debug.enable := true;
Netamqp_transport.Debug.enable := true
let esys = Unixqueue.create_unix_event_system()
let tls_config =
Netsys_tls.create_x509_config
~peer_auth:`None
(Netsys_crypto.current_tls())
let p = `TLS(`Inet("localhost", 5671), tls_config)
let ep = Netamqp_endpoint.create p (`AMQP_0_9 `One) esys
let c = Netamqp_connection.create ep
let auth = Netamqp_connection.plain_auth "guest" "guest"
let test1() =
Netamqp_connection.open_s c [ auth ] (`Pref "en") "/";
eprintf "*** Connection could be opened, and the proto handshake is done!\n%!";
let props = Netamqp_endpoint.tls_session_props ep in
Netamqp_connection.close_s c;
eprintf "*** Connection could be closed!\n%!";
match props with
| None -> failwith "No TLS props!"
| Some p -> p
......@@ -23,6 +23,7 @@ type connector =
type transport_layer =
[ `TCP of connector
| `TLS of connector * (module Netsys_crypto_types.TLS_CONFIG)
| `Custom of
(unit -> Netamqp_transport.amqp_multiplex_controller Uq_engines.engine)
]
......@@ -912,6 +913,11 @@ let mk_frames ep m d_opt ch =
(* connect logic *)
(**********************************************************************)
let get_tls_config ep =
match ep.transport_layer with
| `TLS(_,c) -> Some c
| _ -> None
let connect ep =
let do_it =
match ep.state with
......@@ -924,7 +930,8 @@ let connect ep =
dlog "connect";
let conn_eng =
match ep.transport_layer with
| `TCP conn ->
| `TCP conn
| `TLS(conn,_) ->
let spec, host_opt =
match conn with
| `Sockaddr (Unix.ADDR_INET(ip,port)) ->
......@@ -943,9 +950,14 @@ let connect ep =
match st with
| `Socket(fd, _) ->
dlog "socket connection established";
let tls_config =
match get_tls_config ep with
| None -> None
| Some c -> Some(c,host_opt) in
let mplex =
Netamqp_transport.tcp_amqp_multiplex_controller
~close_inactive_descr:true
?tls_config
fd ep.esys in
( match ep.conn_tmo_group with
| None -> ()
......@@ -1403,3 +1415,13 @@ let register_sync_s2c ep (mtype : sync_server_initiated_method_type_t) ch cb
with Not_found -> [] in
Hashtbl.replace ep.in_tab (ch,mtype') (reg :: l)
let tls_session_props ep =
match ep.conn_eng with
| Some e ->
( match e#state with
| `Done mplex ->
mplex # tls_session_props
| _ ->
None
)
| None -> None
......@@ -21,7 +21,7 @@ type connector =
type transport_layer =
[ `TCP of connector
(* `SSL of ... *)
| `TLS of connector * (module Netsys_crypto_types.TLS_CONFIG)
| `Custom of
(unit -> Netamqp_transport.amqp_multiplex_controller Uq_engines.engine)
]
......@@ -524,6 +524,10 @@ val create_method_exception :
exn
(** Returns a [Method_exception] *)
val tls_session_props : endpoint -> Nettls_support.tls_session_props option
(** TLS session properties *)
module Debug : sig
val enable : bool ref
end
......
......@@ -57,6 +57,7 @@ object
method cancel_shutting_down : unit -> unit
method set_timeout : notify:(unit -> unit) -> float -> unit
method inactivate : unit -> unit
method tls_session_props : Nettls_support.tls_session_props option
end
module Debug = struct
......@@ -118,7 +119,9 @@ object(self)
method event_system = esys
method getsockname = sockname
method getpeername = peername
method transport_type = `TCP
method transport_type =
if mplex#tls_session_props = None then `TCP else `TLS
method tls_session_props = mplex # tls_session_props
method set_max_frame_size size =
if size < 255 then
......@@ -539,7 +542,9 @@ end
let tcp_amqp_multiplex_controller ?(close_inactive_descr=true)
?(preclose=fun()->()) fd esys =
?(preclose=fun()->())
?tls_config
fd esys =
let sockname =
try
`Sockaddr(Unix.getsockname fd)
......@@ -550,9 +555,17 @@ let tcp_amqp_multiplex_controller ?(close_inactive_descr=true)
`Sockaddr(Netsys.getpeername fd)
with
| Unix.Unix_error(_,_,_) -> `Implied in
let mplex =
let mplex1 =
Uq_multiplex.create_multiplex_controller_for_connected_socket
~close_inactive_descr ~preclose
fd esys in
let mplex =
match tls_config with
| None -> mplex1
| Some(c, host_opt) ->
Uq_multiplex.tls_multiplex_controller
~role:`Client
~peer_name:host_opt
c mplex1 in
new tcp_amqp_multiplex_controller sockname peername mplex esys
;;
......@@ -136,12 +136,15 @@ object
* Callbacks are not invoked.
*)
method tls_session_props : Nettls_support.tls_session_props option
end
val tcp_amqp_multiplex_controller :
?close_inactive_descr:bool ->
?preclose:(unit -> unit) ->
?tls_config:((module Netsys_crypto_types.TLS_CONFIG) * string option) ->
Unix.file_descr -> Unixqueue.event_system ->
amqp_multiplex_controller
(** The multiplex controller for stream encapsulation
......@@ -150,6 +153,9 @@ val tcp_amqp_multiplex_controller :
inactivated
- [preclose]: This function is called just before the descriptor
is closed.
- [tls_config:(config,hostname)]: If set, a TLS connection is created
using [config]. The [hostname] is the name of the server (for checking
the name in the certificate).
*)
(** {1 Debugging} *)
......
......@@ -3,7 +3,7 @@
type channel = int
type transport_type =
[ `TCP | `SSL ]
[ `TCP | `TLS ]
type frame_type =
[ `Proto_header | `Method | `Header | `Body | `Heartbeat ]
......
......@@ -8,7 +8,7 @@ type channel = int
(** AMQP channels have numbers 0-65535. Channel 0 has a special function *)
type transport_type =
[ `TCP | `SSL ]
[ `TCP | `TLS ]
type frame_type =
[ `Proto_header | `Method | `Header | `Body | `Heartbeat ]
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment