Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

1858 lines (1587 sloc) 70.494 kB
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA 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 Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(*
@author Raja Boujbel
@author Louis Gesbert (review, rewrite to add channel specs with specialised (de)serialisers)
**)
module IM = IntMap
module H = Hashtbl
module String = BaseString
module List = BaseList
module NA = NetAddr
open Cps.Ops
(* FIXME, this is too generic; HLnet should be split into protocols *)
let protocol = NA.mk_protocol "HLnet"
(* ------------------------------------------------------------ *)
(* Utility functions & constants *)
(* ------------------------------------------------------------ *)
let protocol_version = 1
let gc_finalise _sched = Scheduler.finalise _sched
let apply_fun_option opt =
match opt with
| Some f -> f
| None -> fun _ -> ()
(* ------------------------------------------------------------ *)
(* Type definitions *)
(* ------------------------------------------------------------ *)
type 'a cps = ('a -> unit) -> unit
type 'a errcps = (exn -> unit) -> ('a -> unit) -> unit
type 'a stream_unserialise = string -> int -> [ `data of 'a * int | `needmore of int | `failure of string ]
type endpoint =
| Tcp of Unix.inet_addr * int
| Ssl of Unix.inet_addr * int * SslAS.secure_type option
(* | Udp of Unix.inet_addr * int *)
exception Hlnet_ssl
exception Disconnected of endpoint
type channel_id = int
type service_id = { name: string; version: int; }
(* Used for dummy instanciation of the ['out'] and ['in'] types in channels,
which are abstracted in most of the code here (only before serialisation, and
after deserialisation in the user code do we need to be careful about
them) *)
type black
module rec Types : sig
(* don't look at this, it's a copy-paste of the definitions below (ocaml needs
an explicit sig for functors and here the module only contains type
definitions *)
type ('out','in') channel_spec = { service: service_id; out_serialise: 'out' -> string; in_unserialise: ('out','in') channel -> 'in' stream_unserialise; } and ('out','in') channel = { id: channel_id; spec: ('out','in') channel_spec; connection: connection; mutable handler : ('in' -> ('out' -> unit) -> unit) option; mutable waiting_handler : ((exn -> unit) * ('in' -> unit)) IM.t; mutable pending: 'in' list IM.t ; on_disconnect: ((bool -> unit) -> unit) ref; mutable propagate_removal: bool ref option } and black_channel = (black,black) channel and connection = { remote: endpoint; mutable local: endpoint; scheduler: Scheduler.t; mutable info: Scheduler.connection_info option Cps.Lazy.t; channels: Wchannels.t; mutable num_listeners: int; mutable finalised: bool; }
val _define_at_least_one_value_in_the_module_to_avoid_ocaml_bug_: unit
end = struct
type ('out','in') channel_spec = {
service: service_id;
out_serialise: 'out' -> string;
in_unserialise: ('out','in') channel -> 'in' stream_unserialise;
(** the de-serialisation function to get back received values *)
}
and ('out','in') channel = {
id: channel_id;
spec: ('out','in') channel_spec;
connection: connection;
(* Generic handler for received requests (setup_respond) *)
mutable handler : ('in' -> ('out' -> unit) -> unit) option;
(* Handler for specific request-ids (responses to sendreceive) *)
mutable waiting_handler : ((exn -> unit) * ('in' -> unit)) IM.t;
(* stored received messages, by request ids *)
mutable pending: 'in' list IM.t ;
(* Cps function to be run whenever the channel is disconnected. The bool
passed to the continuation is [true] if the channel has been reconnected.
(it's reinitialised every time before called, persistent handlers should
re-push themselves. *)
on_disconnect: ((bool -> unit) -> unit) ref;
(* Indicates the finalisation status: None if no finaliser is set; otherwise,
if set to true, the finalisation function should send a message to inform
the other hand of the deletion of this channel *)
mutable propagate_removal: bool ref option;
}
and black_channel = (black,black) channel
and connection = {
remote: endpoint; (* also used as key to recover connections *)
mutable local: endpoint; (* real local endpoint may only be known once connected *)
scheduler: Scheduler.t;
mutable info: Scheduler.connection_info option Cps.Lazy.t;
channels: Wchannels.t;
(* each connection needs to know about all channels it hosts, to trigger
their [on_disconnect] handler in case of problem *)
mutable num_listeners: int;
(* keep track of listeners, to detect when that list becomes empty *)
mutable finalised: bool; (* used to finalise only once *)
}
(* Without this, it won't compile on windows with 3.12 (generates bad assembly) *)
let _define_at_least_one_value_in_the_module_to_avoid_ocaml_bug_ = ()
end
(* weak channel set, by id *)
and Wchannels : sig
include Weak.S with type data = Types.black_channel
val get_opt: t -> channel_id -> Types.black_channel option
end = struct
include Weak.Make
(struct
type t = Types.black_channel
let equal c1 c2 = c1.Types.id = c2.Types.id
let hash c = c.Types.id
end)
let dummy_chan = (* for lookup, we rewrite field [id] and the others never get accessed *)
{ Types. id = Obj.magic(); spec = Obj.magic(); connection = Obj.magic();
handler = None; waiting_handler = IM.empty;
pending = IM.empty; on_disconnect = Obj.magic(); propagate_removal = None; }
let get_opt t id = try Some (find t { dummy_chan with Types. id }) with Not_found -> None
end
include Types (* Defined in a sub-module because of mutual recursion with a functor instance *)
(* weak connection set, by remote *)
module Wconnections : sig
include Weak.S with type data = connection
val get_opt: t -> endpoint -> connection option (** get connetion by remote *)
end = struct
include Weak.Make
(struct
type t = connection
let equal c1 c2 = c1.remote = c2.remote
let hash c = Hashtbl.hash c.remote
end)
let dummy_connection = (* for lookup, we rewrite field [remote] and the others never get accessed *)
{ remote = Obj.magic(); local = Obj.magic(); scheduler = Obj.magic();
info = Obj.magic(); channels = Obj.magic(); num_listeners = 0;
finalised = false; }
let get_opt t remote = try Some (find t { dummy_connection with remote }) with Not_found -> None
end
(* Used when unserialising, until we lookup the tables to rebuild the whole channel *)
type pre_channel = {
pc_cid: channel_id;
pc_remote_endpoint: endpoint;
pc_service_name: string;
pc_service_version: int;
}
(* Type stored in the EPH table, that is used to dispatch channel handling from
incoming connections *)
type ('out', 'in') connection_handler = {
chan_handlers : (service_id, ('out','in') channel_spec * (('out', 'in') channel -> unit)) Hashtbl.t;
abort_listen : (unit -> unit) (* Scheduler key used to abort a listen *)
}
(* -- Request tracking -- *)
module RequestId =
struct
type id = int
let dummy_request_id = max_int
let is_dummy req = req = dummy_request_id
let fresh_request_id =
Base.Random.ensure_init ();
let r = ref (Base.Random.max_int ()) in
fun () ->
let id = !r in
r := if id == min_int then max_int else pred id;
id
end
(* -- Reading loop -- *)
type reading_loop_status =
| Ready of string (* data already available *)
| Waiting_for_more of string * int (* receiving buffer (only partially full), how much I already got *)
| Inconsistent
(* We received something we don't understand; we don't even know how long it should be, so the only option is to close the connection *)
(* -- Protocol definition interface -- *)
type ('query,'response) protocol = {
client_spec: ('query,'response) channel_spec;
server_spec: ('response,'query) channel_spec;
}
(* ------------------------------------------------------------ *)
(* Debugging & logging *)
(* ------------------------------------------------------------ *)
#<Debugvar:HLNET_DEBUG>
(* -- generic -- *)
let debug fmt =
#<If> Printf.fprintf stderr ("[hlnet] "^^fmt^^"\n%!")
#<Else> Printf.ifprintf stderr fmt
#<End>
let warning fmt = Logger.warning ("[hlnet] " ^^ fmt)
let hexprint ?(chars_per_line=32) s =
let pfx0 = "" and pfx1 = "" in
let pfxlen = String.length pfx0 in
let sfx = "" in
let sfxlen = String.length sfx in
let len = String.length s in
let buf = String.create (6 * len + ((len - 1) / chars_per_line + 1) * 2 * pfxlen + sfxlen) in
for i = 0 to len - 1 do
let c = s.[i] in
let line_len = min chars_per_line (len - (i / chars_per_line) * chars_per_line) in
let pad = if i mod chars_per_line = line_len - 1 then '\n' else ' ' in
let start = (i / chars_per_line) * (chars_per_line * 3 + pfxlen) * 2 + (i mod chars_per_line) * 3 in
let offset = start in
if i mod chars_per_line = 0 then String.blit pfx0 0 buf offset pfxlen;
let offset = offset + pfxlen in
String.blit (Printf.sprintf "%02x" (int_of_char c)) 0 buf offset 2;
let offset = offset + 2 in
buf.[offset] <- if pad = ' ' && i mod 8 = 7 then '.' else pad;
let offset = start + pfxlen + line_len * 3 in
if i mod chars_per_line = 0 then String.blit pfx1 0 buf offset pfxlen;
let offset = offset + pfxlen in
buf.[offset] <- ' ';
let offset = offset + 1 in
buf.[offset] <- if ' ' <= c && c <= '~' then c else ' ';
let offset = offset + 1 in
buf.[offset] <- pad;
done;
String.blit sfx 0 buf (String.length buf - sfxlen) sfxlen;
buf
let int64_to_debug_string ld =
let color = 31 + Int64.to_int (Int64.rem ld (Int64.of_int 6)) in
Printf.sprintf "[%dm%016Lx" color ld
let int_to_debug_string i =
let color = 31 + i mod 6 in
Printf.sprintf "[%dm%016x" color i
let print_marshalled str beg =
let s = ref "" in
for i = beg to String.length str -1 do
let topr =
let code = Char.code str.[i] in
if code < 32 || code > 126 then
string_of_int code
else Char.escaped str.[i] in
s := !s ^ "-" ^ topr
done;
!s^""
let string_of_htable keystr valstr ht =
Format.fprintf Format.str_formatter "(%d) - %a"
(H.length ht)
(fun f -> H.iter (fun k v -> Format.fprintf f "{ %s+%s }|" (keystr k) (valstr v))) ht;
Format.flush_str_formatter ()
(* -- Type specific -- *)
let endpoint_to_string =
#<If:TESTING> function (* don't show random output ports when testing *)
| Tcp (addr, _port) ->
Printf.sprintf "tcp://%s" (Unix.string_of_inet_addr addr)
| Ssl (addr, _port, _) ->
Printf.sprintf "ssl://%s" (Unix.string_of_inet_addr addr)
(* | Udp (addr, _port) -> *)
(* Printf.sprintf "udp://%s" (Unix.string_of_inet_addr addr) *)
#<Else> function
| Tcp (addr, port) ->
Printf.sprintf "tcp://%s:%d" (Unix.string_of_inet_addr addr) port
| Ssl (addr, port, _) ->
Printf.sprintf "ssl://%s:%d" (Unix.string_of_inet_addr addr) port
(* | Udp (addr, port) -> *)
(* Printf.sprintf "udp://%s:%d" (Unix.string_of_inet_addr addr) port *)
#<End>
let connection_to_string conn =
Printf.sprintf "(%s -> %s, %s)"
(endpoint_to_string conn.local) (endpoint_to_string conn.remote)
(match Cps.Lazy.get_state conn.info with
| None -> "PENDING"
| Some None -> "DISCONNECTED"
| Some (Some info) ->
let fd = NA.get_fd (Scheduler.get_connection_addr info) in
Printf.sprintf "%s (fd %d)"
(if Scheduler.check_connection conn.scheduler info then "UP" else "DOWN")
(Obj.magic fd))
let channel_id_to_debug_string id =
(int_to_debug_string id)
let print_service_id { name; version } =
Printf.sprintf "%s, v.%d" name version
let channel_to_string channel =
String.concat ""
[ "service: "; channel.spec.service.name; ", version: "; string_of_int channel.spec.service.version; "|";
"endpoint: "; (endpoint_to_string channel.connection.remote); "|";
"id: "; channel_id_to_debug_string channel.id; "|";
"pending: ("; string_of_int (IM.size channel.pending); ") "; List.print string_of_int (IM.keys channel.pending); "|";
"handler: "; if Option.is_some channel.handler then "SET" else "UNSET"; "|";
"waiting_handler: ("; string_of_int (IM.size channel.waiting_handler); ") "; List.print string_of_int (IM.keys channel.waiting_handler); "|";
]
let request_id_to_debug_string x = Printf.sprintf "%s" (int_to_debug_string x)
(* ------------------------------------------------------------ *)
(* Auxiliary functions on types *)
(* ------------------------------------------------------------ *)
(* -- Endpoints -- *)
(* Clean ssl endpoint (to be able to found the connection) *)
let clean_ssl_endpoint = function
| Ssl (a,p,_) -> Ssl (a,p,None)
| ep -> ep
(* -- Connections -- *)
(* Returns the endpoint of given connection *)
let get_remote_endpoint conn = conn.remote
let get_local_endpoint conn = conn.local
let get_connection_specification conn_info get =
let addr = Scheduler.get_connection_addr conn_info in
let fd = NA.get_fd addr in
match get fd with
| Unix.ADDR_INET (addr,port) -> addr, port
| _ -> assert false
let local_of_conn_info conn_info =
let addr, port = get_connection_specification conn_info Unix.getsockname in
match NA.get_type (Scheduler.get_connection_addr conn_info) with
| NA.TCP -> Tcp (addr, port)
| NA.SSL -> Ssl (addr, port, None)
| _ -> assert false
let remote_of_conn_info conn_info =
let addr, port = get_connection_specification conn_info Unix.getpeername in
match NA.get_type (Scheduler.get_connection_addr conn_info) with
| NA.TCP -> Tcp (addr, port)
| NA.SSL -> Ssl (addr, port, None)
| _ -> assert false
(* -- Channels and services -- *)
let fresh_channel_id =
Base.Random.ensure_init();
let r = ref (Base.Random.max_int()) in
fun () ->
let x = !r in
r := (if x == max_int then min_int else succ x);
x
let make_service_id ~name ~version =
if version < 0 || version > 9999 then raise (Invalid_argument "make_service_id");
let name =
if String.length name <= 12 then name else
let h = Hashtbl.hash name in
Base.String.init 8 (fun b -> char_of_int ((h lsr (7-b)) land 0xFF)) ^
"/" ^ String.sub name (String.length name - 3) 3
in
{ name = name; version = version }
let remote_of_channel chan = chan.connection.remote
let local_of_channel chan = chan.connection.local
let scheduler_of_channel chan = chan.connection.scheduler
let channel_to_black : ('out','in') channel -> black_channel = Obj.magic
let black_to_channel : black_channel -> ('out','in') channel = Obj.magic
let is_channel_listening ch =
ch.handler <> None || not (IM.is_empty ch.waiting_handler)
(* ------------------------------------------------------------ *)
(* Serialisation / deserialisation *)
(* ------------------------------------------------------------ *)
let write_int64 buf offset i =
let (>>) = Int64.shift_right_logical in
for byte = 0 to 7 do
buf.[offset + byte] <- Char.chr (Int64.to_int (i >> (8* (7 - byte))) land 0xFF)
done
let read_int64 buf offset =
let (<<) = Int64.shift_left in
let rec aux offset value byte =
if byte >= 8 then value else
aux offset (Int64.logor value (Int64.of_int (Char.code buf.[offset+byte]) << (8 * (7 - byte)))) (byte+1)
in
aux offset Int64.zero 0
let write_int buf offset i =
for byte = 0 to 7 do
buf.[offset + byte] <- Char.chr ((i lsr (8* (7 - byte))) land 0xFF)
done
let read_int buf offset =
let rec aux offset value byte =
if byte >= 8 then value else
aux offset (value lor (Char.code buf.[offset+byte] lsl (8 * (7 - byte)))) (byte+1)
in
aux offset 0 0
let serialised_endpoint_size = 8
let serialise_endpoint ep =
let buf = String.make serialised_endpoint_size '\000' in
let addr, port =
match ep with
| Tcp (addr,port) -> (* ['T'|0|address(4bytes)|port(2bytes)] *)
buf.[0] <- 'T';
addr, port
| Ssl (addr,port,_) -> (* ['S'|0|address(4bytes)|port(2bytes)] *)
buf.[0] <- 'S';
addr, port
in
(* only for tcp & ssl *)
let saddr = (Obj.magic addr : string) in
(* ocaml provides no conversion, but it's actually "\127\000\000\001" internally *)
String.blit saddr 0 buf 2 4;
assert (0 <= port && port <= 0xFFFF);
buf.[6] <- Char.chr ((port lsr 8) land 0xFF );
buf.[7] <- Char.chr (port land 0xFF);
buf
(* end tcp & ssl *)
(* | Udp (addr,port) -> (\* ['U'|0|address(4bytes)|port(2bytes)] *\) *)
(* buf.[0] <- 'U'; *)
(* let saddr = (Obj.magic addr : string) in *)
(* (\* ocaml provides no conversion, but it's actually "\127\000\000\001" internally *\) *)
(* String.blit saddr 0 buf 2 4; *)
(* assert (0 <= port && port <= 0xFFFF); *)
(* buf.[6] <- Char.chr ((port lsr 8) land 0xFF ); *)
(* buf.[7] <- Char.chr (port land 0xFF); *)
(* buf *)
let unserialise_endpoint ?(offset=0) s =
let offset0 = offset in
if String.length s - offset < serialised_endpoint_size then raise (Invalid_argument "unserialise_endpoint");
let cons a p =
match s.[offset0] with
| 'T' -> Tcp (a,p)
| 'S' -> Ssl (a,p,None)
| _ ->
raise (Invalid_argument "unserialise_endpoint")
in
(* only for tcp & ssl *)
let offset = offset + 2 in
let saddr = String.sub s offset 4 in
let addr = (Obj.magic saddr : Unix.inet_addr) in (* see comment in "serialise" *)
let offset = offset + 4 in
let port = (Char.code s.[offset] lsl 8) lor Char.code s.[offset + 1] in
let offset = offset + 2 in
assert (offset0 + serialised_endpoint_size = offset);
cons addr port
(* end tcp & ssl *)
(* | 'U' -> *)
(* let offset = offset + 2 in *)
(* let saddr = String.sub s offset 4 in *)
(* let addr = (Obj.magic saddr : Unix.inet_addr) in (\* see comment in "serialise" *\) *)
(* let offset = offset + 4 in *)
(* let port = (Char.code s.[offset] lsl 8) lor Char.code s.[offset + 1] in *)
(* let offset = offset + 2 in *)
(* assert (offset0 + serialised_endpoint_size = offset); *)
(* Udp (addr, port) *)
let serialised_channel_size =
8 (* numeric channel id (an int64) *)
+ serialised_endpoint_size
+ 16 (* length of serialised service: 12 for name and 4 for version *)
let serialise_channel_with_endpoint chan endpoint =
(* format:
[ channel_id(8bytes) | local_endpoint(8bytes) ]
[service_name_padded_with_\000(12bytes)|stringified_service_version(4bytes)]
*)
let service_name = chan.spec.service.name in
let service_version = Printf.sprintf "%04d" chan.spec.service.version in
let chan_id = chan.id
in
let buf = String.make serialised_channel_size '\000' in
let offset = 0 in
write_int buf offset chan_id;
let offset = offset + 8 in
String.blit (serialise_endpoint endpoint) 0 buf 8 serialised_endpoint_size;
let offset = offset + serialised_endpoint_size in
assert (String.length service_name <= 12);
String.blit service_name 0 buf offset (String.length service_name);
let offset = offset + 12 in
assert (String.length service_version = 4);
String.blit service_version 0 buf offset 4;
let offset = offset + 4 in
assert (offset = serialised_channel_size);
buf
let serialise_channel chan =
serialise_channel_with_endpoint chan chan.connection.local
(* This first pass doesn't do any registering in the tables for channel
handling, and returns a simplified structure. The internal function
used to rebuild a real channel is [first_channel_treatment], and you
should see the [_secondpass] function for the user binding *)
let unserialise_remote_channel_firstpass ?(offset=0) s =
if String.length s - offset < serialised_channel_size then
raise (Invalid_argument (Printf.sprintf "unserialise_remote_channel: wrong message length (%d/%d)" (String.length s - offset) serialised_channel_size));
let offset0 = offset in
let pc_cid = read_int s offset in
let offset = offset + 8 in
let pc_remote_endpoint = unserialise_endpoint ~offset s in
let offset = offset + serialised_endpoint_size in
let pc_service_name = Base.String.rtrim ~is_space:(fun c -> c = '\000') (String.sub s offset 12) in
let offset = offset + 12 in
let pc_service_version = try int_of_string (String.sub s offset 4) with
| Failure "int_of_string" -> raise (Invalid_argument "unserialise_remote_channel: invalid header")
in
let offset = offset + 4 in
assert (offset = offset0 + serialised_channel_size);
{ pc_cid; pc_remote_endpoint; pc_service_name; pc_service_version }
(* -- (De)Serialisation of the messages in the HLnet protocol -- *)
module Serialise :
sig
type operation =
| Message of channel_id * RequestId.id
| Delete of channel_id
| Channel of pre_channel
| Reset
val unserialise_operation : endpoint -> operation stream_unserialise
val serialise_message : RequestId.id -> ('out','in') channel -> 'out' -> string
val serialise_delchan: channel_id -> string
val serialise_channel: black_channel -> endpoint (* local *) -> string
val reset_message : string
end =
struct
type operation =
| Message of channel_id * RequestId.id
| Delete of channel_id
| Channel of pre_channel
| Reset
(** Format specification for a message :
- (1c) char M, the "shebang" for a message
- (8c) one int64, the id of the channel
- (8c) one int64, the id of the request
- a string using the serialisation functions provided by the user in the channel_spec
*)
let message_shebang = 'M'
let shebang_length = 1
let message_header_length = shebang_length + 8 + 8
(** Format specification for a channel
- (1c) char S, the "shebang" for a channel
- (1c) unused ('\000')
- (2c) the HLnet protocol version
- a serialised channel (using the functions above)
*)
(* A channel is always the first message sent to open a dialog: therefore,
it's here that we insert HLnet's version number & check it (so that it's
not done in every subsequent message) *)
let channel_shebang = 'S'
let serialised_protocol_version =
assert (0 <= protocol_version && protocol_version < 0xFFFF);
let s = String.create 2 in
s.[0] <- Char.chr (protocol_version lsr 8);
s.[1] <- Char.chr (protocol_version land 0xFF);
s
let channel_prefix =
let s = String.make 4 '\000' in
s.[0] <- channel_shebang;
String.blit serialised_protocol_version 0 s 2 2;
s
let protocol_version_of_channel_prefix s = (Char.code s.[2] lsl 8) lor (Char.code s.[3])
let channel_prefix_size = 4
let channel_size = channel_prefix_size + serialised_channel_size
let serialise_channel chan local_endpoint =
let buf = String.create channel_size in
let offset = 0 in
String.blit channel_prefix 0 buf offset channel_prefix_size;
let offset = offset + channel_prefix_size in
String.blit (serialise_channel_with_endpoint chan local_endpoint) 0 buf offset serialised_channel_size;
let offset = offset + serialised_channel_size in
assert (offset = channel_size);
buf
(** Format specification for deleting a channel
- (1c) char D, the "shebang" for deleting a channel
- (8c) one int64, the id of the channel
*)
let delchan_shebang = 'D'
let delchan_length = shebang_length + 8
let serialise_message request_id chan msg =
let message = chan.spec.out_serialise msg in
let message_length = String.length message in
let buf = String.create (shebang_length + 8 + 8 + message_length) in
let offset = 0 in
buf.[offset] <- 'M';
let offset = offset + 1 in
write_int buf offset chan.id;
let offset = offset + 8 in
write_int buf offset request_id;
let offset = offset + 8 in
assert (offset = message_header_length);
String.blit message 0 buf offset message_length;
buf
let unserialise_message_header ?(offset=0) msg =
let offset0 = offset in
let offset = offset + shebang_length in
let chanid = read_int msg offset in
let offset = offset + 8 in
let reqid = read_int msg offset in
let offset = offset + 8 in
assert (offset = offset0 + message_header_length);
(chanid, reqid)
let serialise_delchan chanid =
let buf = String.create delchan_length in
let offset = 0 in
buf.[offset] <- delchan_shebang;
let offset = offset + 1 in
write_int buf offset chanid;
let offset = offset + 8 in
assert (offset = delchan_length);
buf
let unserialise_delchan msg =
read_int msg shebang_length
let reset_message = "R"
let unserialise_operation remote_endpoint msg offset =
assert (offset=0); (* only called that way, but would be a nice optimisation *)
let len = String.length msg in
assert (len > 0);
match msg.[0] with
| 'S' -> (* channel creation *)
if len < channel_size then `needmore (offset + channel_size)
else if Base.String.is_prefix channel_prefix msg then
try
let pre_channel = unserialise_remote_channel_firstpass ~offset:channel_prefix_size msg in
let pre_channel = { pre_channel with pc_remote_endpoint = remote_endpoint } in
`data (Channel pre_channel, offset + channel_size)
with Invalid_argument _ as _exc->
#<If> Printf.eprintf "at unserialise of operation: %s\n%s\n" (Printexc.to_string _exc) (Printexc.get_backtrace ()) #<End>;
`failure "Invalid channel creation message"
else
`failure
(Printf.sprintf "Ignoring message from a different HLnet version: %d (current exe uses %d)"
(protocol_version_of_channel_prefix msg) protocol_version)
| 'D' -> (* channel deletion *)
if len < delchan_length then `needmore (offset + delchan_length)
else
let channel_id = unserialise_delchan msg in
`data (Delete (channel_id), offset + delchan_length)
| 'M' -> (* message within an open channel *)
if len < message_header_length then `needmore (offset + message_header_length)
else
let channel_id,request_id = unserialise_message_header msg in
`data (Message (channel_id, request_id), offset + message_header_length)
| 'R' -> (* reset *)
`data (Reset, offset + 1)
| _ ->
`failure "Invalid message"
end
(* ------------------------------------------------------------ *)
(* Connection-handling engine *)
(* ------------------------------------------------------------ *)
module Connection : sig
(** Returns a registered connection to the given [endpoint]. Connects if
needed. Calls err_cont if the connection couldn't be made. Simultaneous
attempts to connect to the same remote are safe. *)
val get: ?ssl:SslAS.secure_type -> Scheduler.t -> endpoint -> connection
(** Same as [get], but does not attempt to connect, just return the connection
if existing *)
val find: endpoint -> connection option
(** Registers an already open low-level connection (e.g. returned by
[accept]). Warning, the connection will be closed if you let the returned
value be garbage collected. *)
val register: Scheduler.t -> Scheduler.connection_info -> connection
(** Closes and unregisters a connection (and then calls the [on_disconnect]
handlers of hosted channels, which may attempt to reconnect) *)
val disconnect: connection -> unit
(** Register a channel to the connection it uses, so that it can be
notified in clase of disconnection *)
val register_channel: ('out','in') channel -> unit
(** Returns the channel with given id if it is registered to the given
connection (and either alive, or not GCed yet) *)
val get_channel: connection -> channel_id -> black_channel option
(** Returns true if the connection hosts any channel expecting to receive a
message. You probably also want to check if we accept incoming channels
on the local endpoint, see module [EP] below ; *)
val is_listening: connection -> bool
(* -- Operation on connections -- *)
val write: connection -> string -> failure:(exn -> unit) -> success:(int -> unit) -> unit
val read: connection -> failure:(exn -> unit) -> success:(int * string -> unit) -> unit
(* -- Debug -- *)
val dump: unit -> string
val live_channels: unit -> int
end = struct
let table = Wconnections.create 11
let certificates = Hashtbl.create 11
let disconnect conn =
if conn.finalised then () else
let _ = conn.finalised <- true in
let channels = conn.channels in
#<If$minlevel 12> debug "Closing connection to %s" (endpoint_to_string conn.remote) #<End>;
let channels_handling () =
Wchannels.iter
(fun ch ->
(* Abort all expected answers *)
IM.iter
(fun _ (errcont,_) ->
Scheduler.push (conn.scheduler) (fun () -> errcont (Disconnected conn.remote))
)
ch.waiting_handler;
(* Reset and call the disconnection handlers *)
let on_disconnect = ch.on_disconnect in
let f = !on_disconnect in
on_disconnect := (fun cont -> false |> cont);
f @> fun _reconnected -> ())
channels
in
match Cps.Lazy.get_state conn.info with
| Some (Some info) when Scheduler.check_connection conn.scheduler info ->
let cont _ =
Scheduler.remove_connection conn.scheduler info;
conn.info <- Cps.Lazy.lazy_from_val None;
channels_handling ()
in
Scheduler.write conn.scheduler info "" (* make sure everything has been flushed before closing *)
~err_cont:cont cont;
| _ ->
conn.info <- Cps.Lazy.lazy_from_val None;
channels_handling()
let register sched connection_info =
let endpoint = remote_of_conn_info connection_info in
let connection = {
local = local_of_conn_info connection_info;
remote = endpoint;
scheduler = sched;
info = Cps.Lazy.lazy_from_val (Some connection_info);
channels = Wchannels.create 17;
num_listeners = 0;
finalised = false;
} in
gc_finalise sched disconnect connection;
assert (not (Wconnections.mem table connection));
Wconnections.merge table connection
let get ?ssl sched remote =
let connection_opt = Wconnections.get_opt table remote in
(* The use of Cps.Lazy is so that we don't open several connections if
several channels have been opened just at once to the same remote. *)
match connection_opt with
| Some connection when Cps.Lazy.get_state connection.info <> Some None ->
(* we are either connected or connecting *)
connection
| _ ->
(* we are either unconnected, or disconnected *)
let addr, port, encryption, local =
match remote with
| Tcp (addr, port) -> addr, port, Network.Unsecured, Tcp (Unix.inet_addr_any, 0)
| Ssl (addr, port, None) ->
let sec =
match ssl with
| Some sec ->
(try
let found = Hashtbl.find certificates remote in
if sec <> found then
warning "Want to replace the certificate ??";
with Not_found -> Hashtbl.add certificates remote sec);
sec
| None -> Hashtbl.find certificates remote in
addr, port, Network.Secured sec, Ssl (Unix.inet_addr_any, 0, None)
| _ -> assert false
in
match connection_opt with
| Some connection -> (* the structure exists, but is disconnected *)
let reconnect cont =
Logger.info "Reconnecting to %s" (endpoint_to_string remote);
Network.connect sched (Network.make_port_spec ~protocol addr port) encryption
~socket_flags:[Unix.SO_KEEPALIVE]
~err_cont:(
fun _ ->
Logger.info "Reconnection to %s failed" (endpoint_to_string remote);
disconnect connection; None |> cont
)
@> fun connection_info ->
Logger.info "Reconnected to %s" (endpoint_to_string remote);
connection.local <- (local_of_conn_info connection_info);
connection.finalised <- false;
Some connection_info |> cont
in
connection.info <- Cps.Lazy.make (Scheduler.push sched) reconnect;
connection
| None -> (* we have yet to connect *)
let update_local_ref = ref (fun _ -> assert false) in
let disconnect_ref = ref (fun _ -> assert false) in
let connect cont =
#<If$minlevel 10> debug "Connecting to %s" (endpoint_to_string remote) #<End>;
Network.connect sched (Network.make_port_spec ~protocol addr port) encryption
~socket_flags:[Unix.SO_KEEPALIVE]
~err_cont:(fun _ -> !disconnect_ref (); None |> cont)
@> fun connection_info ->
Logger.info "Connected to %s" (endpoint_to_string remote);
!update_local_ref (local_of_conn_info connection_info);
Some connection_info |> cont
in
let connection = {
local = local; (* to be initialised below *)
remote = remote;
scheduler = sched;
info = Cps.Lazy.make (Scheduler.push sched) connect;
channels = Wchannels.create 17;
num_listeners = 0;
finalised = false;
} in
update_local_ref := (fun local -> connection.local <- local);
disconnect_ref := (fun () -> disconnect connection);
Wconnections.add table connection;
gc_finalise sched disconnect connection;
connection
let find = Wconnections.get_opt table
let register_channel channel =
let channel = channel_to_black channel in
Wchannels.add channel.connection.channels channel
let get_channel connection id =
Wchannels.get_opt connection.channels id
let is_listening connection = connection.num_listeners > 0
let write connection message ~failure ~success =
Cps.Lazy.force connection.info
@> function
| Some info ->
Scheduler.write connection.scheduler info message
~err_cont:(fun e -> failure e; disconnect connection)
@> success
| None ->
failure (Failure "Connection closed")
let read connection ~failure ~success =
Cps.Lazy.force connection.info
@> function
| Some info ->
Scheduler.read connection.scheduler info
~err_cont:(fun e -> failure e; disconnect connection)
@> success
| None ->
failure (Failure "Connection closed")
let dump () =
Wconnections.fold
(fun c acc -> Printf.sprintf "%s%s\n" acc (connection_to_string c))
table ""
let live_channels () =
Wconnections.fold
(fun c acc -> acc + Wchannels.count c.channels)
table 0
end
(* ------------------------------------------------------------ *)
(* Tables of stored handlers *)
(* ------------------------------------------------------------ *)
(*
Overview of the tables that are maintained inside hlnet:
- [Connection]: connection ID (weak) -> connection
- [EP]: endpoint -> (handlers = service -> channel handler)
- [ChanH]: channel ID -> channel
- in [reading_loop]: connection -> err_cont (only for the connections on which we're reading)
References:
- in each channel, to a connection ID
GC mechanism:
- Connection IDs are bound to a finaliser closing the connection
- Channels are removed manually from ChanH if there is no handler
left after a message was received for that channel
- Whenever a channel is collected, it sends notice to the other end
(unless the other hand already asked to close)
- When all channels referring to a connection ID are closed, the
connection can be collected and closed naturally
*)
(* -- Hashtable functor used in the tables below -- *)
module PolyHash (V :
sig
type key
type ('out', 'in') value
val key2str: key -> string
end) :
sig
(* This module provides semi-heterogeneous hashtables, needed to handle channels
and connection-handlers that deal with different types (for example, a
connection handler needs to know all channels registered to its connection,
and those may receive different types).
Values in a PolyHash have type [exists('out','in'). ('out','in') value]. Since
the user can only access this data if he already got a (typed) channel, type-
safety is regained before he gets his hands on the value. *)
type t
val create : unit -> t
val add : t -> V.key -> ('out','in') V.value -> unit
val find : t -> V.key -> ('out','in') V.value option
val mem : t -> V.key -> bool
val remove : t -> V.key -> unit
val update : t -> V.key -> (('out','in') V.value -> ('out','in') V.value) -> unit
val fold : t -> (V.key -> ('out','in') V.value -> 'acc -> 'acc) -> 'acc -> 'acc
val to_string : t -> string
end = struct
type t = (V.key, Obj.t) H.t
let create () = H.create 5
let add tbl k v =
H.replace tbl k (Obj.repr v)
let find tbl k =
try Some (Obj.obj(H.find tbl k ) : ('out','in') V.value)
with Not_found -> None
let mem = H.mem
let to_string tbl =
BaseList.print V.key2str (H.fold (fun k _v acc -> k::acc) tbl [])
let remove tbl k =
H.remove tbl k
let update tbl k f =
try
let v = H.find tbl k in
let new_v = Obj.repr (f ((Obj.obj v) : ('out','in') V.value)) in
H.replace tbl k new_v
with Not_found -> ()
let fold (tbl : t) f acc =
H.fold (fun k v acc -> f (k:V.key) ((Obj.obj v) : ('out','in') V.value) acc) tbl acc
end
(* -- Table of handlers for incoming connections -- *)
module EP : sig
val add: endpoint -> ('out', 'in') connection_handler -> unit
val find: endpoint -> ('out', 'in') connection_handler option
val update: endpoint -> (('out', 'in') connection_handler -> ('out', 'in') connection_handler) -> unit
val remove: endpoint -> unit
val to_string: unit -> string
end = struct
module E = struct
type key = endpoint
type ('out','in') value = ('out', 'in') connection_handler
let key2str = endpoint_to_string
end
module EPH = PolyHash(E) (** Hash from (local) endpoints to their connection handler *)
(* Only concerns endpoints which have a handler, consequently, not weak: it's
cleaned by hand when one doesn't want to listen anymore *)
let table = EPH.create ()
let find ep =
EPH.find table ep
let add ep connection_handler =
if not (EPH.mem table ep) then
EPH.add table ep connection_handler
let remove ep =
EPH.remove table ep
let update ep f =
EPH.update table ep f
let to_string () = EPH.to_string table
end
(* -- Table of the channels with pending handlers (kept from the GC) -- *)
module ChanH : sig
val add : ('out','in') channel -> unit
val find: channel_id -> black_channel option
val mem: channel_id -> bool
val remove: channel_id -> unit
(** If [propagate] (the default), inform the other end of the deletion *)
val to_string: unit -> string
val count: unit -> int
end = struct
let table = H.create 89
let add chan =
chan.connection.num_listeners <- chan.connection.num_listeners + 1;
H.replace table chan.id (channel_to_black chan)
(* Strong ref, CH is for channels with pending operations, we hold it in memory *)
let mem id = H.mem table id
let find id = Base.Hashtbl.find_opt table id
let remove id =
#<If$minlevel 20> debug "Channel %s unregistered" (channel_id_to_debug_string id) #<End>;
try
let ch = Hashtbl.find table id in
ch.connection.num_listeners <- ch.connection.num_listeners - 1;
H.remove table id
with Not_found -> ()
let to_string () =
H.fold
(fun id _chan acc -> Printf.sprintf "%s, %s" acc (channel_id_to_debug_string id))
table ""
let count () = H.length table
end
(* Channels have two special closing treatments:
- at disconnection, the on_disconnect field within the channel is triggered
(this should also remove it from ChanH if present)
- when garbage collected, inform the other hand so that it can clean it up too
this is what these functions handle
The two are mutually exclusive, and disable each other *)
(* Whenever a channel is collected, inform the other end by sending a delchan
message (if [propagate_removal] is [Some true]). Otherwise used to add the
finalise function only once *)
let register_channel =
let finaliser channel =
let propagate_ref = Option.get channel.propagate_removal in
let propagate = !propagate_ref in
propagate_ref := false;
#<If$minlevel 25>
debug "--- Call finalise function for channel %s" (channel_id_to_debug_string channel.id)
#<End>;
if propagate then
Connection.write channel.connection (Serialise.serialise_delchan channel.id)
~failure:(fun _ -> ())
~success:(fun _ -> ())
in
fun chan -> match chan.propagate_removal with
| Some propagate_ref -> propagate_ref := true
| None ->
Connection.register_channel chan;
#<If$minlevel 25>
debug "--- Set a finalise function on channel %s" (channel_id_to_debug_string chan.id)
#<End>;
let id = chan.id in
let propagate_ref = ref true in
chan.propagate_removal <- Some propagate_ref;
(let f = !(chan.on_disconnect) in
chan.on_disconnect := fun cont -> ChanH.remove id; propagate_ref := false; f @> cont);
gc_finalise chan.connection.scheduler finaliser chan
(* No need to propagate when the channel deletion was already propagated to us *)
let channel_stop_removal_propagation chan =
match chan.propagate_removal with Some r -> r := false | None -> ()
let channel_write channel value errcont cont =
Connection.write channel.connection value
~failure: (
fun e ->
Logger.error "Could not write to channel %016x (%s)"
channel.id (Printexc.to_string e);
errcont (Disconnected (channel.connection.remote))
)
~success:cont
(*
(fun _ ->
let f = !(channel.on_disconnect) in
channel.on_disconnect :=
(fun cont1 -> f @> function
| true ->
Scheduler.push scheduler (fun () -> channel_write channel value @> cont);
true |> cont1
| false -> false |> cont1))
*)
(*
let get_channel_connection chan cont =
Connection.get chan.connection
@> fun connection ->
Connection.register_channel connection channel;
channel_propagate_removal connection channel;
connection |> cont
*)
(* ------------------------------------------------------------ *)
(* Core engine: operation handlers *)
(* ------------------------------------------------------------ *)
(* send over a channel *)
(* The error continuation does not need to trigger the on_disconnect handler,
because in case of problem the whole connection will be marked as
disconnected, and trigger that for all hosted channels including this one *)
let send_aux chan ?(request_id=RequestId.dummy_request_id) ?(errcont=(fun _ -> ())) ?(cont=(fun _ -> ())) value =
let msg = Serialise.serialise_message request_id chan value in
#<If$minlevel 21>
debug "Sending a packet on channel %s, over %s" (channel_id_to_debug_string chan.id) (connection_to_string chan.connection)
#<End>;
#<If$minlevel 30>
debug "«\n%s»" (hexprint msg)
#<End>;
channel_write chan msg errcont @> fun buflen -> cont buflen
(* -- Treatment of incoming messages -- *)
(* Treatment on incoming channels : find out the handler and apply it *)
let first_channel_treatment connection pre_channel =
let local_ep = get_local_endpoint connection
and remote_ep = connection.remote in
match EP.find local_ep with
| None ->
warning "Refusing a request for opening a channel from %s (not accepting any service on %s): %s, v%d"
(endpoint_to_string remote_ep) (endpoint_to_string local_ep)
pre_channel.pc_service_name pre_channel.pc_service_version
| Some { chan_handlers; _ } ->
let service_id = {
name = pre_channel.pc_service_name;
version = pre_channel.pc_service_version
} in
match Base.Hashtbl.find_opt chan_handlers service_id with
| None ->
warning "Refusing a request for opening a channel from %s (not accepting this service on %s): %s, v%d"
(endpoint_to_string remote_ep) (endpoint_to_string local_ep)
pre_channel.pc_service_name pre_channel.pc_service_version
| Some (spec,handler) ->
let channel = {
id = pre_channel.pc_cid;
spec = spec;
connection = connection;
pending = IM.empty;
handler = None;
waiting_handler = IM.empty;
on_disconnect = ref (fun cont -> false |> cont);
propagate_removal = None;
} in
register_channel channel;
#<If$minlevel 20>
debug "Applying set channel handler for service %s of %s on %s"
pre_channel.pc_service_name (endpoint_to_string local_ep)
(channel_id_to_debug_string channel.id)
#<End>;
handler channel
let store_message channel reqid msg =
channel.pending <- IM.update_default reqid (fun l -> msg::l) [msg] channel.pending
let first_message_treatment (channel:black_channel) reqid msg =
match IM.find_opt reqid channel.waiting_handler with
| Some (_errh,inh) ->
#<If$minlevel 10>
debug "-- Received a message, waiting handler for %s" (request_id_to_debug_string reqid)
#<End>;
channel.waiting_handler <- IM.remove reqid channel.waiting_handler;
if not (is_channel_listening channel) then ChanH.remove channel.id;
inh msg
| None ->
match channel.handler with
| Some f ->
#<If$minlevel 10>
debug "-- Received a message, handler set (r: %s; c: %s)"
(request_id_to_debug_string reqid) (channel_id_to_debug_string channel.id)
#<End>;
f msg (send_aux ~request_id:reqid channel)
| None ->
#<If$minlevel 10>
debug "-- Received a message : %d messages stored, add r: %s on %s"
(IM.size channel.pending) (request_id_to_debug_string reqid)
(channel_id_to_debug_string channel.id)
#<End>;
store_message channel reqid msg
(*
let on_delete_channel msg conn =
let local_endpoint = get_local_endpoint conn in
let cid = Serialise.unserialise_delchan msg 0 in
Option.iter close_channel (ChanH.find (ChannelId.get ~cid local_endpoint))
*)
(* -- Reading loop -- *)
let reading_loop_aux sched connection loop_end =
let reading_status = ref (Ready "")
in
let rec raw_read : 'a. 'a stream_unserialise -> 'a Cps.t = fun unserialise k ->
let try_unserialise (len, buf) =
if len = 0 then
(warning "Connection lost ! Please handle me.";
reading_status := Inconsistent);
(* re-initiate the connection and start a new loop ? Remove it from the channel ?
We'd need to make sure only the client end attempts to reconnect *)
match unserialise buf 0 with
| `data (x,rest) ->
#<If$minlevel 30>
debug "unserialise: consumed %d chars (rest %d%s) «\n%s»\n"
rest (len - rest) (if len > rest then Printf.sprintf ", starting with '%s'" (Char.escaped buf.[rest]) else "")
(hexprint (String.sub buf 0 rest))
#<End>;
reading_status := Ready (String.sub buf rest (len - rest));
x |> k
| `needmore n ->
#<If$minlevel 10>
debug "unserialise: read again, I got only %d chars and need %d to continue\n"
len n
#<End>;
let receive_buf = String.create n in
String.blit buf 0 receive_buf 0 len;
reading_status := Waiting_for_more (receive_buf,len);
raw_read unserialise @> k
| `failure msg ->
Logger.warning "invalid message received on connection %s: %s\n« %s »"
(connection_to_string connection) msg
(String.escaped (String.citation "[...]" 60 buf));
#<If$minlevel 10>
debug "Bad message from %s: «\n%s»" (connection_to_string connection) (hexprint buf)
#<End>;
Connection.write connection Serialise.reset_message ~success:(fun _ -> ()) ~failure:(fun _ -> ());
loop_end ()
in
match !reading_status with
| Ready "" ->
Connection.read connection ~failure:(fun _ -> loop_end()) ~success:try_unserialise
| Ready s ->
try_unserialise (String.length s, s)
| Waiting_for_more (buf,amount_full) ->
Connection.read connection
~failure:
(fun _ -> loop_end())
~success:
(fun (len,buf2) ->
let amount_needed = String.length buf in
let amount_received = amount_full + len in
if amount_received < amount_needed then
(String.blit buf2 0 buf amount_full len;
reading_status := Waiting_for_more (buf, amount_received);
raw_read unserialise @> k)
else if amount_received = amount_needed then
(String.blit buf2 0 buf amount_full len;
try_unserialise (amount_received, buf))
else
(* we're screwed, Scheduler returned too much data, we can't use our
buffer and have to realloc *)
(let rebuf = String.create amount_received in
String.blit buf 0 rebuf 0 amount_full;
String.blit buf2 0 rebuf amount_full len;
try_unserialise (amount_received, rebuf)))
| Inconsistent ->
Logger.warning "Aborting connection to %s" (connection_to_string connection);
loop_end()
in
let remote_endpoint = get_remote_endpoint connection in
let rec loop () =
let loop () = (* make sure to run the loop at least once *)
if
EP.find connection.local <> None || Connection.is_listening connection
then
loop()
else
(#<If$minlevel 10> debug "Stopping reading loop on %s" (connection_to_string connection) #<End>;
#<If$minlevel 40> debug "Existing connections:\n%s" (Connection.dump()) #<End>;
loop_end())
in
raw_read (Serialise.unserialise_operation remote_endpoint)
@> function
| Serialise.Reset ->
Logger.warning "remote end reset connection %s" (connection_to_string connection);
loop_end();
Connection.disconnect connection
| Serialise.Channel pre_channel ->
first_channel_treatment connection pre_channel;
loop ()
| Serialise.Delete channel_id ->
Option.iter channel_stop_removal_propagation (Connection.get_channel connection channel_id);
ChanH.remove channel_id;
loop ()
| Serialise.Message (channel_id, req_id) ->
match ChanH.find channel_id with
| None ->
warning "Incoming message on an unknown channel%s"
(#<If:TESTING> ""
#<Else>
Printf.sprintf " (r: %s; c: %s)" (request_id_to_debug_string req_id) (channel_id_to_debug_string channel_id)
#<End>);
#<If$minlevel 30> debug "Existing channels:\n%s" (ChanH.to_string()) #<End>;
reading_status := Ready ""; (* reinit the receiving buffer (maybe we should close the channel) *)
loop ()
| Some (channel: black_channel) ->
raw_read (channel.spec.in_unserialise (black_to_channel channel))
@> fun message ->
Scheduler.push sched (fun () -> loop ());
first_message_treatment channel req_id message
in
loop ()
let reading_loop =
let connections = (Hashtbl.create 53 : (endpoint, unit) Hashtbl.t) in
fun connection ->
if not (Hashtbl.mem connections connection.remote) then (
#<If$minlevel 10> debug "-- Begin reading loop on %s" (connection_to_string connection) #<End>;
Hashtbl.add connections connection.remote ();
reading_loop_aux connection.scheduler connection
(fun () -> Hashtbl.remove connections connection.remote)
)
(* ------------------------------------------------------------ *)
(* Listening functions *)
(* ------------------------------------------------------------ *)
(** Open a listening socket and setup the receiving queue on the given local
endpoint. Does nothing if already listening on that endpoint *)
let listen sched endpoint =
let handler_aux =
fun connection_info ->
let connection = Connection.register sched connection_info in
#<If> debug "Incoming connection %s" (connection_to_string connection) #<End>;
(* duplicate the handler we have set for the specific local endpoint
(for the case we were listening on several addresses at once, eg 0.0.0.0) *)
if connection.local <> endpoint then Option.iter (EP.add connection.local) (EP.find endpoint);
reading_loop connection
in
let tcp_handler _ = handler_aux in
let ssl_handler = function
| SslAS.UnsecuredRes ->
(fun _ -> warning "Ssl: Can not connect in secure mode."; raise Hlnet_ssl)
| SslAS.SecuredRes (is_valid, _secure) ->
if not is_valid then
(fun _ -> warning "Ssl: Invalid certificate."; raise Hlnet_ssl)
else handler_aux in
let encryption, handler =
match endpoint with
| Ssl (_,_, None) -> warning "Ssl: no secure_type specified."; raise Hlnet_ssl
| Ssl (_,_, Some ssl) -> (Network.Secured ssl), ssl_handler
| _ -> Network.Unsecured, tcp_handler in
match endpoint with
| Tcp (addr, port)
| Ssl (addr, port, _) ->
let port_spec = (Network.make_port_spec ~protocol addr port) in
let abort_listen = Network.listen sched port_spec encryption ~socket_flags:[Unix.SO_KEEPALIVE] handler in
EP.add endpoint { chan_handlers = Hashtbl.create 11;
abort_listen = abort_listen };
#<If:TESTING> () #<Else> Logger.debug "Listening on %s" (endpoint_to_string endpoint) #<End>
(* | _ -> assert false *)
let accept ?(safe=false) sched endpoint chan_spec chan_handler =
#<If$minlevel 5>
debug "Accepting local service on endpoint %s/%s"
(endpoint_to_string endpoint) chan_spec.service.name
#<End>;
match EP.find endpoint with
| None ->
#<If$minlevel 5>
debug "Try to listen on endpoint %s"
(endpoint_to_string endpoint)
#<End>;
listen sched endpoint;
Hashtbl.add (Option.get (EP.find endpoint)).chan_handlers chan_spec.service (chan_spec,chan_handler)
| Some connection_handler ->
if safe && Hashtbl.mem connection_handler.chan_handlers chan_spec.service
then failwith ("Hlnet.safe_accept");
Hashtbl.add connection_handler.chan_handlers chan_spec.service (chan_spec,chan_handler)
(* ------------------------------------------------------------ *)
(* Operation handlers *)
(* ------------------------------------------------------------ *)
(* -- Sending -- *)
(* Always inform the other hand about a channel before we can send data through it *)
let send_channel chan cont =
let msg = Serialise.serialise_channel (channel_to_black chan) chan.connection.local in
channel_write chan msg (fun _ -> () |> cont) @> fun _ -> () |> cont
(* Receives, or sets up the receiving function, for one packet on the given channel *)
let receive_aux chan ?(request_id=RequestId.dummy_request_id) errcont inhandler =
#<If>
debug "Receiving a packet on channel %s" (channel_id_to_debug_string chan.id)
#<End>;
let msgs =
try List.rev (IM.find request_id chan.pending)
with Not_found -> []
in
match msgs with
| [] ->
let handl msg = inhandler msg in
#<If$minlevel 10>
debug "-- Receive: adding a waiting handler for %s (%d)"
(request_id_to_debug_string request_id) (IM.size chan.waiting_handler)
#<End>;
let should_register = not (is_channel_listening chan) in
chan.waiting_handler <- IM.add request_id (errcont,handl) chan.waiting_handler;
if should_register then ChanH.add chan;
reading_loop chan.connection
| msg::y ->
(let newreqids =
match y with
| [] -> IM.remove request_id chan.pending
| _ ->
if (RequestId.is_dummy request_id) then
Logger.warning "Waiting for several responses to the same request";
IM.add request_id y chan.pending
in
chan.pending <- newreqids;
let msg : 'in' = msg in
#<If$minlevel 10> debug "-- Receive: found a stored message for %s (%d)" (request_id_to_debug_string request_id) (IM.size chan.pending) #<End>;
inhandler msg)
(* ------------------------------------------------------------ *)
(* Core user functions *)
(* ------------------------------------------------------------ *)
let setup_respond chan inouthandler =
#<If> debug "Setting answering machine on channel %s" (channel_id_to_debug_string chan.id) #<End>;
let should_register = not (is_channel_listening chan) in
chan.handler <- Some inouthandler;
if should_register then ChanH.add chan;
reading_loop chan.connection;
register_channel chan
(** Stop listening on local endpoint. Does nothing if it was not listening there *)
let refuse _scheduler endpoint =
let endpoint = clean_ssl_endpoint endpoint in
Option.iter
(fun connection_handler ->
#<If:TESTING> () #<Else> Logger.debug "Stop listening on %s" (endpoint_to_string endpoint) #<End>;
connection_handler.abort_listen ();
EP.remove endpoint)
(EP.find endpoint)
let send chan value = send_aux chan value
let receive chan inhandler = receive_aux chan (fun _ -> ()) inhandler
let receive' chan errcont inhandler = receive_aux chan errcont inhandler
let sendreceive' chan msg errcont inhandler =
let request_id = RequestId.fresh_request_id () in
#<If$minlevel 10> debug "-- SendReceive with reqid : %s" (request_id_to_debug_string request_id) #<End>;
let cont =
fun _ ->
receive_aux chan ~request_id errcont inhandler in
send_aux chan ~request_id ~errcont ~cont msg
let sendreceive chan msg inhandler = sendreceive' chan msg (fun _ -> ()) inhandler
let multi_sendreceive chan_list inhandlers =
let total = List.length inhandlers in
let receive_handler : ('in' -> unit) -> 'in' -> unit =
let list_response = Queue.create () in
fun inh ->
(fun (msg : 'in') ->
Queue.push (msg, inh) list_response;
if (Queue.length list_response = total) then
Queue.iter (fun (msg,handler) -> handler msg) list_response)
in
let fiter :(('out','in') channel * 'out') -> ('in' -> unit) -> unit =
(fun (chan,msg) inh ->
sendreceive chan msg (receive_handler inh))
in
List.iter2 fiter (chan_list : (('out','in') channel * 'out') list) (inhandlers : ('in' -> unit) list)
let close_channel chan =
#<If> debug "Closing channel %s" (channel_id_to_debug_string chan.id) #<End>;
ChanH.remove chan.id
let panic chan =
#<If> debug "Alert on channel %s" (channel_id_to_debug_string chan.id) #<End>;
Connection.disconnect chan.connection
let dup : ('out','in') channel -> ('out'2,'in2) channel_spec -> ('out'2,'in2) channel =
fun (chan : ('out', 'in') channel) spec ->
let chan = channel_to_black chan in
let new_chan : ('out'2,'in2) channel =
{ (black_to_channel chan) with
id = fresh_channel_id();
spec = spec;
pending = IM.empty;
handler = None;
waiting_handler = IM.empty;
on_disconnect = ref (fun cont -> false |> cont);
propagate_removal = None;
} in
#<If$minlevel 20>
debug "Dup a channel : %s -> %s"
(channel_id_to_debug_string chan.id)
(channel_id_to_debug_string new_chan.id)
#<End>;
new_chan
let open_channel sched remote_endpoint channel_spec ?(on_disconnect=fun () -> `abort) cont =
let remote_endpoint, connection_get =
match remote_endpoint with
| Ssl (a,p,Some ssl) -> let r = Ssl (a,p,None) in r, (fun s -> Connection.get ~ssl s r)
| Ssl (_,_, None) -> warning "Ssl: no secure_type specified."; raise Hlnet_ssl
| _ -> remote_endpoint, (fun s -> Connection.get s remote_endpoint) in
let rec rec_on_disconnect chan =
let rec handler cont =
#<If$minlevel 15> debug "Channel %s disconnected" (channel_id_to_debug_string chan.id) #<End>;
match on_disconnect() with
| `abort -> false |> cont
| `retry delay ->
let _akey =
Scheduler.sleep sched delay
(fun () ->
let _ = Connection.get sched remote_endpoint in
Cps.Lazy.force chan.connection.info
@> function
| Some info when Scheduler.check_connection chan.connection.scheduler info ->
chan.on_disconnect := rec_on_disconnect chan;
send_channel chan
@> fun () ->
chan.waiting_handler <- IM.empty;
true |> cont
| _ -> handler cont)
in ()
in
let rec aux cont =
(* Re-push the handler when it's executed *)
let disco_ref = chan.on_disconnect in
let disco = !disco_ref in
disco_ref := (fun cont -> disco (fun reconnected -> assert (not reconnected); aux @> cont));
handler @> cont
in aux
in
let connection = connection_get sched in
let on_disconnect_ref = ref (fun _ -> ()) in
let chan : ('out', 'in') channel = {
id = fresh_channel_id();
spec = channel_spec;
connection = connection;
pending = IM.empty;
handler = None;
waiting_handler = IM.empty;
on_disconnect = on_disconnect_ref;
propagate_removal = None;
} in
on_disconnect_ref := rec_on_disconnect chan;
#<If>
debug "Open a channel to %s/%s" (endpoint_to_string remote_endpoint) channel_spec.service.name
#<End>;
(send_channel chan @> fun () -> chan |> cont);
register_channel chan
(* Fixme: what does this do in the exported interface ? *)
let channel_is_listening chan =
Option.is_some (ChanH.find chan.id)
let is_open chan =
match Cps.Lazy.get_state chan.connection.info with
| Some (Some _) -> true
| _ -> false
(* Add last in on_disconnect handlers, execute only if not reconnected,
otherwise re-push instead *)
let on_disconnect chan user_on_disconnect =
let rec insert_user_f on_disconnect cont =
on_disconnect @> function
| false -> (* disconnected: f() and continue *)
user_on_disconnect (); false |> cont
| true -> (* reconnected: repush instead *)
chan.on_disconnect := insert_user_f !(chan.on_disconnect);
true |> cont
in
chan.on_disconnect := insert_user_f !(chan.on_disconnect)
let unserialise_remote_channel_secondpass hosting_channel spec (pc: pre_channel) =
if pc.pc_service_name <> spec.service.name then
raise (Invalid_argument (Printf.sprintf "unserialise_remote_channel: bad service %s, expected %s"
pc.pc_service_name spec.service.name));
if pc.pc_service_version <> spec.service.version then
raise (Invalid_argument
(Printf.sprintf "unserialise_remote_channel: version conflict for service %s: got %d, expected %d"
pc.pc_service_name pc.pc_service_version spec.service.version));
let connection =
Connection.get hosting_channel.connection.scheduler pc.pc_remote_endpoint in
let chan = {
id = pc.pc_cid;
spec = spec;
connection = connection;
pending = IM.empty;
handler = None;
waiting_handler = IM.empty;
on_disconnect = ref (fun cont -> false |> cont);
propagate_removal = None;
}
in
#<If$minlevel 5>
debug "- Registered a remote serialised channel (%s)" (channel_id_to_debug_string chan.id)
#<End>;
register_channel chan;
chan
let unserialise_remote_channel spec hosting_channel s offset =
let len = String.length s - offset in
if len < serialised_channel_size
then `needmore (offset + serialised_channel_size)
else
try
`data
(unserialise_remote_channel_secondpass hosting_channel spec
(unserialise_remote_channel_firstpass ~offset s),
offset + serialised_channel_size)
with
Invalid_argument msg -> `failure msg
(*
let flush_waiting_channels sched endpoint connection_handler =
#<If>
let waiting_channels = connection_handler.chan_inbox in
debug "Already listening, %d channel to treat"
(List.length waiting_channels)
#<End>;
connection_handler.chan_inbox <- [];
List.iter (first_channel_treatment sched ~endpoint) connection_handler.chan_inbox
*)
let reverse_channel : ('out','in') channel -> ('in','out') channel = fun chan -> { chan with
spec = {
service = chan.spec.service;
out_serialise = (fun _ -> failwith "Write on reversed channel");
in_unserialise = (fun _ _ -> failwith "Read on reversed channel");
};
(* local_endpoint = chan.local_endpoint; *)
(* connection = chan.connection; *)
(* channel_id = chan.id; *)
pending = IM.empty;
handler = None;
waiting_handler = IM.empty;
(* current_scheduler = chan.current_scheduler; *)
on_disconnect = ref (fun cont -> false |> cont);
propagate_removal = None;
}
(* -- Command-line -- *)
(* Type for options (now it's just an int but you can add any
options...)*)
type options = {
port : int;
(* ... *)
}
(* Command line parser *)
let parse =
ServerArg.make_parser "Hlnet" [
["--hlnet-port"], ServerArg.func ServerArg.int
(fun _ i -> {port = i}), "<int>",
"Set the port used by hlnet. By default it's 1086.";
]
let opt = fst (
ServerArg.filter_functional (ServerArg.extract_prefix "--hlnet-") {
port = 1086;
} parse
)
let default_port = opt.port
let default_endpoint = Tcp (Unix.inet_addr_any, default_port)
let port_of_endpoint = function | Tcp (_, p) | Ssl (_,p,_) (* | Udp (_, p) *) -> p
let define_protocol ~name ~version ~serialise_query ~unserialise_query ~serialise_response ~unserialise_response =
let service = make_service_id ~name ~version in
{
client_spec =
{ service; out_serialise = serialise_query; in_unserialise = unserialise_response; };
server_spec =
{ service; out_serialise = serialise_response; in_unserialise = unserialise_query; };
}
(*
let _tmpdebug_loop =
let _ = Gc.create_alarm (fun () -> prerr_endline "\nGC!") in
Scheduler.timer Scheduler.default (Time.seconds 1)
(fun () ->
(* Gc.full_major(); *)
Printf.eprintf "[live %d] [stored %d]\r%!" (Connection.live_channels()) (ChanH.count()))
*)
(* ------------------------------------------------------------ *)
(* Auxiliary user functions *)
(* ------------------------------------------------------------ *)
module Aux = struct
let magic_unserialise buf ofs =
let len = String.length buf in
if len < ofs + Marshal.header_size then `needmore (ofs + Marshal.header_size)
else
let need = ofs + Marshal.total_size buf ofs in
if len < need then `needmore need
else `data (Marshal.from_string buf ofs, need)
let map_unserialise f unserialiser = fun buf ofs ->
match unserialiser buf ofs with
| `data (x,rest) -> `data (f x, rest)
| `needmore n -> `needmore n
| `failure s -> `failure s
let magic_spec = fun service -> {
service = service;
out_serialise = (fun x -> Marshal.to_string x []);
in_unserialise = (fun _chan -> magic_unserialise);
}
let easy_spec ~name ~version ~serialise ~unserialise =
let service = make_service_id ~name ~version in
let out_serialise x =
(* we need to add a header to know the size of the message (it's a big-endian int32) *)
let s = serialise x in
let len = 4 + String.length s in
let buf = String.create len in
for i = 0 to 3 do buf.[i] <- char_of_int ((len lsr (8*(3 - i))) land 0xFF) done;
String.blit s 0 buf 4 (String.length s);
buf
in
let in_unserialise channel s offset =
let len = String.length s - offset in
if len < 4 then
`needmore (offset + 4)
else
let need =
let i = int_of_char in
(i s.[0] lsl 24) lor (i s.[1] lsl 16) lor (i s.[2] lsl 8) lor (i s.[3])
in
if len < need then `needmore (offset + need)
else
match unserialise channel (String.sub s (offset + 4) (need - 4)) with
| Some x -> `data (x, offset + need)
| None -> `failure "Unserialisation of message failed in user function"
in
{ service; out_serialise; in_unserialise }
let easy_protocol ~name ~version ~serialise_query ~unserialise_query ~serialise_response ~unserialise_response =
{
client_spec = easy_spec ~name ~version ~serialise:serialise_query ~unserialise:unserialise_response;
server_spec = easy_spec ~name ~version ~serialise:serialise_response ~unserialise:unserialise_query;
}
let respond_on_new_channel chan spec handler =
let new_chan = dup chan spec in
let _ = setup_respond new_chan handler in
reverse_channel new_chan
end
Jump to Line
Something went wrong with that request. Please try again.