-
Notifications
You must be signed in to change notification settings - Fork 125
/
hlnet.ml
1877 lines (1606 loc) · 69.7 KB
/
hlnet.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
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; last_channels: black_channel Weak.t; mutable last_channels_ptr: 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 *)
last_channels: black_channel Weak.t; mutable last_channels_ptr: int;
(* Keep track of the last channels registered that are listening; this is
only an optimisation for the is_listening function (avoids going
through all reg. channels) *)
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(); last_channels = Obj.magic();
last_channels_ptr = 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 ("[32m[hlnet][0m "^^fmt^^"\n%!")
#<Else> Printf.ifprintf stderr fmt
#<End>
let warning fmt = Logger.warning ("[hlnet] " ^^ fmt)
let hexprint ?(chars_per_line=32) s =
let pfx0 = "[22m" and pfx1 = "[01m" in
let pfxlen = String.length pfx0 in
let sfx = "[0m" 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[39m" color ld
let int_to_debug_string i =
let color = 31 + i mod 6 in
Printf.sprintf "[%dm%016x[39m" color i
let print_marshalled str beg =
let s = ref "[35m" 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^"[0m"
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, [1m%s[22m)"
(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 "[7m%s[27m" (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;
last_channels = Weak.create 7; last_channels_ptr = 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;
last_channels = Weak.create 7; last_channels_ptr = 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 push_last_channel ch =
let conn = ch.connection in
let last_chans = conn.last_channels in
let ptr = conn.last_channels_ptr in
Weak.set last_chans ptr (Some ch);
conn.last_channels_ptr <- succ ptr mod Weak.length last_chans
let register_channel channel =
let channel = channel_to_black channel in
Wchannels.add channel.connection.channels channel;
if is_channel_listening channel then push_last_channel channel
let get_channel connection id =
Wchannels.get_opt connection.channels id
let is_listening connection =
try
let last_channels = connection.last_channels in
for i = 0 to Weak.length last_channels - 1 do
Option.iter (fun ch -> if is_channel_listening ch then raise Exit) (Weak.get last_channels i)
done;
Wchannels.iter
(fun ch ->
if is_channel_listening ch then (push_last_channel ch; raise Exit))
connection.channels;
false
with Exit -> true
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