145
163
mutable exception_handler : exn -> unit;
146
164
mutable unmap_port : (unit -> unit);
147
165
mutable onclose : (connection_id -> unit) list;
148
mutable filter : (Unix.sockaddr -> connection_id -> rule);
166
mutable filter : (Rpc_transport.sockaddr -> connection_id -> rule);
149
167
mutable auth_methods : (string, t pre_auth_method) Hashtbl.t;
150
168
mutable auth_peekers : (auth_peeker * t pre_auth_method) list;
151
169
mutable connections : connection list;
152
170
mutable master_acceptor : server_socket_acceptor option;
153
mutable transport_timeout : float
171
mutable transport_timeout : float;
172
mutable nolog : bool;
173
mutable get_last_proc : unit->string;
174
mutable mstring_factories : Xdr_mstring.named_mstring_factories;
260
286
mplex # peer_user_name
262
method authenticate _ _ _ _ _ _ _ _ f = f(Auth_negative Auth_too_weak)
288
method authenticate _ _ _ f =
289
f(Auth_negative Auth_too_weak)
265
292
let auth_transport = new auth_transport
269
let debug_internals_log = ref None
271
let debug_service_log = ref None
274
let debug_service msg =
275
match !debug_service_log with
279
let debug_servicef msgf =
280
Printf.kprintf debug_service msgf
283
let debug_internals msg =
284
match !debug_internals_log with
288
let debug_internalsf msgf =
289
Printf.kprintf debug_internals msgf
296
module Debug = struct
297
let enable = ref false
298
let enable_ctrace = ref false
299
let enable_ptrace = ref false
300
let ptrace_verbosity = ref `Name_abbrev_args
301
let disable_for_server srv = srv.nolog <- true
304
let dlog0 = Netlog.Debug.mk_dlog "Rpc_server" Debug.enable
305
let dlogr0 = Netlog.Debug.mk_dlogr "Rpc_server" Debug.enable
307
let dlog srv m = if not srv.nolog then dlog0 m
308
let dlogr srv m = if not srv.nolog then dlogr0 m
310
let dlog0_ctrace = Netlog.Debug.mk_dlog "Rpc_server.Ctrace" Debug.enable_ctrace
311
let dlogr0_ctrace = Netlog.Debug.mk_dlogr "Rpc_server.Ctrace" Debug.enable_ctrace
313
let dlog_ctrace srv m = if not srv.nolog then dlog0_ctrace m
314
let dlogr_ctrace srv m = if not srv.nolog then dlogr0_ctrace m
317
let dlog0_ptrace = Netlog.Debug.mk_dlog "Rpc_server.Ptrace" Debug.enable_ptrace
318
let dlogr0_ptrace = Netlog.Debug.mk_dlogr "Rpc_server.Ptrace" Debug.enable_ptrace
320
let dlog_ptrace srv m = if not srv.nolog then dlog0_ptrace m
321
let dlogr_ptrace srv m = if not srv.nolog then dlogr0_ptrace m
325
Netlog.Debug.register_module "Rpc_server" Debug.enable;
326
Netlog.Debug.register_module "Rpc_server.Ctrace" Debug.enable_ctrace;
327
Netlog.Debug.register_module "Rpc_server.Ptrace" Debug.enable_ptrace
331
let connector_of_sockaddr =
333
| Unix.ADDR_INET(ip,p) ->
335
| Unix.ADDR_UNIX s ->
338
let connector_of_socksymbol sym =
339
connector_of_sockaddr
340
(Uq_resolver.sockaddr_of_socksymbol sym)
292
343
let sockaddrname sa =
417
480
let xid = Rpc_packer.peek_xid message in
418
481
let reply = Rpc_packer.pack_accepting_reply xid
419
482
ret_flav ret_data condition in
420
let answer = make_immediate_answer xid "" reply in
421
if !debug_service_log <> None then
422
debug_servicef "Rpc_server (port %s, xid %s): Error %s"
423
(mplexoptname conn.trans) (xidname answer.client_id)
484
make_immediate_answer xid "" reply
485
(fun () -> "Error " ^ errname condition) in
425
486
schedule_answer answer
428
| Xdr.Xdr_format_message_too_long _ -> (* Convert to Garbage *)
489
| Xdr.Xdr_format_message_too_long _ as e
491
(* Convert to Garbage *)
496
sprintf "Emitting Garbage after exception: %s"
431
499
let xid = Rpc_packer.peek_xid message in
432
500
let reply = Rpc_packer.pack_accepting_reply xid
433
501
ret_flav ret_data Garbage in
434
let answer = make_immediate_answer xid "" reply in
435
if !debug_service_log <> None then
436
debug_servicef "Rpc_server (port %s, xid %s): Error Garbage"
437
(mplexoptname conn.trans) (xidname answer.client_id);
502
let answer = make_immediate_answer xid "" reply
503
(fun () -> "Error Garbage") in
438
504
schedule_answer answer
440
506
| Rpc_server condition ->
443
509
let xid = Rpc_packer.peek_xid message in
444
510
let reply = Rpc_packer.pack_rejecting_reply xid condition in
445
let answer = make_immediate_answer xid "" reply in
446
if !debug_service_log <> None then
447
debug_servicef "Rpc_server (port %s, xid %s): Error %s"
448
(mplexoptname conn.trans) (xidname answer.client_id)
511
let answer = make_immediate_answer xid "" reply
512
(fun () -> "Error " ^ errname condition) in
450
513
schedule_answer answer
517
"Dropping response message"
452
518
| Abort(_,_) as x ->
459
525
let xid = Rpc_packer.peek_xid message in
460
526
let reply = Rpc_packer.pack_accepting_reply xid
461
527
ret_flav ret_data System_err in
462
let answer = make_immediate_answer xid "" reply in
463
if !debug_service_log <> None then
464
debug_servicef "Rpc_server (port %s, xid %s): Error System_err"
465
(mplexoptname conn.trans) (xidname answer.client_id);
528
let answer = make_immediate_answer xid "" reply
529
(fun () -> "Error System_err") in
466
530
schedule_answer answer
477
541
= Rpc_packer.unpack_call_frame_l message
547
"Request (sock=%s,peer=%s,xid=%lu) for [0x%lx,0x%lx,0x%lx]"
548
(Rpc_transport.string_of_sockaddr sockaddr)
549
(Rpc_transport.string_of_sockaddr peeraddr)
550
(Rtypes.logical_int32_of_uint4 xid)
551
(Rtypes.logical_int32_of_uint4 prog_nr)
552
(Rtypes.logical_int32_of_uint4 vers_nr)
553
(Rtypes.logical_int32_of_uint4 proc_nr)
480
556
let sess_conn_id =
481
557
if srv.prot = Rpc.Tcp then
484
new connection_id sockaddr peeraddr_lz
560
new connection_id sockaddr_lz peeraddr_lz
487
563
(* First authenticate: *)
581
method server_addr = sockaddr_opt
582
method client_addr = peeraddr_opt
583
method program = prog_nr
584
method version = vers_nr
585
method procedure = proc_nr
587
method credential = (flav_cred, data_cred)
588
method verifier = (flav_verf, data_verf)
589
method frame_len = frame_len
590
method message = message
503
594
(* The [authenticate] method will call the passed function
504
595
* when the authentication is done. This may be at any time
508
srv sess_conn_id sockaddr_opt peeraddr_opt
509
flav_cred data_cred flav_verf data_verf
510
(function Auth_positive(user,ret_flav,ret_data) ->
599
srv sess_conn_id auth_details
601
Auth_positive(user,ret_flav,ret_data,enc_opt,dec_opt) ->
511
602
(* user: the username (method-dependent)
512
603
* ret_flav: flavour of verifier to return
513
604
* ret_data: data of verifier to return
548
639
Rpc_packer.unpack_call_body
640
~mstring_factories:srv.mstring_factories
549
642
prog procname message frame_len in
646
(* no [string_of_request] - we would keep a
647
reference to param forever!
649
"Invoke " ^ procname ^ "()"
552
if !debug_service_log <> None then
553
debug_servicef "Rpc_server (port %s, xid %s): Call for %s"
554
(mplexoptname conn.trans) (xidname xid) procname;
655
"Invoke (sock=%s,peer=%s,xid=%lu): %s"
656
(Rpc_transport.string_of_sockaddr sockaddr)
657
(Rpc_transport.string_of_sockaddr peeraddr)
658
(Rtypes.logical_int32_of_uint4 xid)
659
(Rpc_util.string_of_request
660
!Debug.ptrace_verbosity
556
667
begin match proc with
558
669
let result_value =
559
670
p.sync_proc param
561
let reply = Rpc_packer.pack_successful_reply
563
ret_flav ret_data result_value in
672
(* Exceptions raised by the encoder are
676
Rpc_packer.pack_successful_reply
679
ret_flav ret_data result_value in
564
680
let answer = make_immediate_answer
565
xid procname reply in
566
if !debug_service_log <> None then
567
debug_servicef "Rpc_server (port %s, xid %s): Reply from %s"
568
(mplexoptname conn.trans) (xidname xid)
683
Rpc_util.string_of_response
684
!Debug.ptrace_verbosity
570
690
schedule_answer answer
572
692
let u, m = match conn.peeked_user with
668
801
terminate_connection srv conn;
671
| `Ok(pv,trans_addr) ->
672
if !debug_internals_log <> None then
673
debug_internalsf "Rpc_server: got message";
804
| `Ok(in_rec,trans_addr) ->
805
dlog srv "got message";
675
807
if conn.close_when_empty then (
676
if !debug_internals_log <> None then
677
debug_internalsf "Rpc_server: ignoring msg after shutdown";
808
dlog srv "ignoring msg after shutdown";
680
811
(* First check whether the message matches the filter rule: *)
682
match trans_addr with
684
if !debug_internals_log <> None then
685
debug_internalsf "Rpc_server: No filter 1 (implied address)";
686
`Accept (* Don't have the information to process filters *)
688
if !debug_internals_log <> None then
689
debug_internalsf "Rpc_server: Checking filter 1";
691
unroll_rule (get_rule conn srv peer)
692
(Rpc_packer.length_of_packed_value pv)
696
conn.rule <- None; (* reset rule after usage *)
698
813
let peeraddr = trans_addr in
815
let sockaddr, trans_sockaddr =
701
816
match conn.trans with
702
817
| None -> assert false
704
lazy ( match trans # getsockname with
706
| `Implied -> failwith "Address not available" ) in
710
process_incoming_message
711
srv conn sockaddr peeraddr pv Execute_procedure
819
( lazy ( match trans # getsockname with
821
| `Implied -> failwith "Address not available" ),
713
terminate_connection srv conn
830
"Request (sock=%s,peer=%s): Deny"
831
(Rpc_transport.string_of_sockaddr trans_sockaddr)
832
(Rpc_transport.string_of_sockaddr peeraddr)
834
terminate_connection srv conn (* for safety *)
715
836
(* Simply forget the message *)
840
"Request (sock=%s,peer=%s): Drop"
841
(Rpc_transport.string_of_sockaddr trans_sockaddr)
842
(Rpc_transport.string_of_sockaddr peeraddr)
846
process_incoming_message
847
srv conn sockaddr peeraddr pv Execute_procedure
718
849
process_incoming_message
719
850
srv conn sockaddr peeraddr pv
720
851
(Reject_procedure Auth_too_weak)
721
| `Accept_limit_length(_,_) -> assert false
852
| `Reject_with(pv,code) ->
853
process_incoming_message
854
srv conn sockaddr peeraddr pv
855
(Reject_procedure code)
723
857
next_incoming_message srv conn (* if still connected *)
726
860
| `End_of_file ->
727
if !debug_internals_log <> None then
728
debug_internalsf "Rpc_server: End of file";
861
dlog srv "End of file";
729
862
terminate_connection srv conn
735
868
| Some trans -> next_incoming_message' srv conn trans
737
870
and next_incoming_message' srv conn trans =
871
let filter_var = ref None in
738
872
trans # start_reading
739
873
~peek:(fun () -> peek_credentials srv conn)
874
~before_record:(handle_before_record srv conn filter_var)
740
875
~when_done:(fun r -> handle_incoming_message srv conn r)
743
and handle_before_record srv conn n trans_addr =
744
match trans_addr with
746
if !debug_internals_log <> None then
747
debug_internalsf "Rpc_server: No filter 2 (implied address)";
748
() (* Don't have the information to process filters *)
750
if !debug_internals_log <> None then
751
debug_internalsf "Rpc_server: Checking filter 2";
752
( match unroll_rule (get_rule conn srv peer) n with
754
| `Deny -> terminate_connection srv conn
756
( match conn.trans with
760
trans # skip_message()
763
| `Accept_limit_length(_,_) -> assert false
878
and handle_before_record srv conn filter_var n trans_addr =
879
dlog srv "Checking filter before_record";
882
match !filter_var with
887
let filter = srv.filter trans_addr conn.conn_id in
889
filter_var := Some filter;
892
( match unroll_rule filter n with
894
| `Deny -> terminate_connection srv conn; `Deny
897
| `Reject_with code -> `Reject_with code
766
900
and peek_credentials srv conn =
767
901
if not conn.peeked && srv.prot = Tcp && srv.auth_peekers <> [] then begin
841
973
match reply_opt with
843
if !debug_internals_log <> None then
844
debug_internalsf "Rpc_server: next reply";
978
try `Sockaddr (Lazy.force reply.sockaddr)
979
with _ -> `Implied in
981
"Response (sock=%s,peer=%s,cid=%d,xid=%ld): %s"
982
(Rpc_transport.string_of_sockaddr sockaddr)
983
(Rpc_transport.string_of_sockaddr reply.peeraddr)
985
(Rtypes.logical_int32_of_uint4 reply.client_id)
989
dlog srv "next reply";
845
990
trans # start_writing
846
991
~when_done:(fun r ->
847
992
handle_outgoing_message srv conn r)
871
1015
[ `Socket_endpoint of protocol * Unix.file_descr
872
1016
| `Multiplexer_endpoint of Rpc_transport.rpc_multiplex_controller
873
1017
| `Socket of protocol * connector * socket_config
1018
| `Dummy of protocol
877
1022
let create2_srv prot esys =
878
1023
let default_exception_handler ex =
879
prerr_endline ("RPC server exception handler: Exception " ^ Printexc.to_string ex ^ " caught")
1026
("Rpc_server exception handler: Exception " ^ Netexn.to_string ex)
882
1029
let none = Hashtbl.create 3 in
883
1030
Hashtbl.add none "AUTH_NONE" auth_none;
1032
let mf = Hashtbl.create 1 in
1033
Hashtbl.add mf "*" Xdr_mstring.string_based_mstrings;
885
1035
{ main_socket_name = `Implied;
886
1037
service = Uint4Map.empty;
887
1038
portmapped = None;
943
1112
(* Try to peek credentials. This can be too early, however. *)
944
1113
if conn.trans <> None then (
945
if !debug_service_log <> None then
946
debug_servicef "Rpc_server (port %s): Serving connection"
1116
sprintf "(sock=%s,peer=%s): Serving connection"
1117
(Rpc_transport.string_of_sockaddr mplex#getsockname)
948
1119
if srv.transport_timeout >= 0.0 then
949
1120
mplex # set_timeout
950
1121
~notify:(on_trans_timeout srv conn) srv.transport_timeout;
1055
1233
(Unix.ADDR_INET (addr, port));
1058
any -> Unix.close s; raise any
1237
Unix.close s; raise any
1061
1240
let bind_to_localhost port =
1062
1241
bind_to_internet (Unix.inet_addr_of_string "127.0.0.1") port
1065
let (fd, close_inactive_descr) =
1068
let s = bind_to_localhost port in
1070
| Internet (addr,port) ->
1071
let s = bind_to_internet addr port in
1074
let s = bind_to_internet Unix.inet_addr_any 0 in
1077
match Unix.getsockname s with
1078
| Unix.ADDR_INET(_,port) -> port
1079
| _ -> assert false in
1080
if !debug_internals_log <> None then
1081
debug_internalsf "Rpc_server: Using anonymous port %d" port;
1082
srv.portmapped <- Some port;
1085
any -> Unix.close s; raise any
1091
(if prot = Tcp then Unix.SOCK_STREAM else Unix.SOCK_DGRAM)
1095
Unix.bind s (Unix.ADDR_UNIX path);
1098
any -> Unix.close s; raise any
1102
| Dynamic_descriptor f ->
1106
srv.main_socket_name <- `Sockaddr (Unix.getsockname fd);
1244
let bind_to_w32_pipe name mode =
1245
let psrv = Netsys_win32.create_local_pipe_server name mode max_int in
1246
let s = Netsys_win32.pipe_server_descr psrv in
1250
let get_descriptor() =
1251
let (fd, close_inactive_descr) =
1254
let s = bind_to_localhost port in
1256
| Internet (addr,port) ->
1257
let s = bind_to_internet addr port in
1260
let s = bind_to_internet Unix.inet_addr_any 0 in
1263
match Unix.getsockname s with
1264
| Unix.ADDR_INET(_,port) -> port
1265
| _ -> assert false in
1268
sprintf "Using anonymous port %d" port);
1269
srv.portmapped <- Some port;
1272
any -> Unix.close s; raise any
1275
( match Sys.os_type with
1278
Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
1279
Unix.bind s (Unix.ADDR_INET(Unix.inet_addr_loopback, 0));
1280
( match Unix.getsockname s with
1281
| Unix.ADDR_INET(_, port) ->
1282
let f = open_out path in
1283
output_string f (string_of_int port ^ "\n");
1292
(if prot = Tcp then Unix.SOCK_STREAM else Unix.SOCK_DGRAM)
1296
Unix.bind s (Unix.ADDR_UNIX path);
1299
any -> Unix.close s; raise any
1303
let s = bind_to_w32_pipe path Netsys_win32.Pipe_duplex in
1307
| Dynamic_descriptor f ->
1311
srv.main_socket_name <- ( try
1312
`Sockaddr (Unix.getsockname fd)
1316
(fd, close_inactive_descr)
1108
1319
match prot with
1110
let mplex_eng = create_multiplexer_eng fd prot in
1321
let (fd, close_inactive_descr) = get_descriptor() in
1322
let mplex_eng = create_multiplexer_eng ~close_inactive_descr fd prot in
1112
1324
~is_done:(fun mplex ->
1113
1325
let conn = connection srv mplex in
1114
1326
conn.fd <- Some fd;
1115
if !debug_service_log <> None then
1116
debug_servicef "Rpc_server (port %s): Accepting datagrams"
1329
sprintf "(sock=%s,peer=%s): Accepting datagrams"
1330
(Rpc_transport.string_of_sockaddr
1118
1333
if srv.transport_timeout >= 0.0 then
1119
1334
mplex # set_timeout
1120
1335
~notify:(on_trans_timeout srv conn)
1135
if !debug_service_log <> None then
1136
debug_servicef "Rpc_server (port %s): Listening"
1350
let (fd, close_inactive_descr) = get_descriptor() in
1354
sprintf "(sock=%s): Listening"
1139
1357
match override_listen_backlog with
1141
1359
| None -> config#listen_options.lstn_backlog in
1142
Unix.listen fd backlog;
1143
let acc = new direct_socket_acceptor fd esys in
1362
let psrv = Netsys_win32.lookup_pipe_server fd in
1363
Netsys_win32.pipe_listen psrv backlog
1365
Unix.listen fd backlog
1367
if close_inactive_descr then track_server fd;
1369
new Uq_engines.direct_acceptor
1370
~close_on_shutdown: close_inactive_descr
1371
~preclose:(fun () -> Netlog.Debug.release_fd fd)
1144
1373
srv.master_acceptor <- Some acc;
1145
1374
accept_connections acc;
1153
1382
create2_socket_endpoint prot fd esys
1154
1383
| `Multiplexer_endpoint mplex ->
1155
1384
if mplex#event_system != esys then
1156
failwith "Rpc_server.create2: Multiplexer is attached to the wrong event system";
1385
failwith "Rpc_server.create2: Multiplexer is attached \
1386
to the wrong event system";
1157
1387
create2_multiplexer_endpoint mplex
1158
1388
| `Socket(prot,conn,config) ->
1159
1389
create2_socket_server ~config prot conn esys
1391
let srv = create2_srv prot esys in
1397
let is_dummy srv = srv.dummy
1163
1400
let bind ?program_number ?version_number prog0 procs srv =
1164
1401
let prog = Rpc_program.update ?program_number ?version_number prog0 in
1165
1402
let prog_nr = Rpc_program.program_number prog in
1220
1457
let pm_unset_old_port pm old_port f =
1221
if !debug_internals_log <> None then
1222
debug_internalsf "Rpc_server: unregistering port: %d" old_port;
1460
sprintf "unregistering port: %d" old_port);
1223
1461
Rpc_portmapper_clnt.PMAP.V2.pmapproc_unset'async pm (pm_mapping old_port)
1224
1462
(fun get_result ->
1226
1464
let success = get_result() in
1227
if !debug_internals_log <> None then
1228
debug_internalsf "Rpc_server: portmapper reports %s"
1229
(if success then "success" else "failure");
1467
sprintf "portmapper reports %s"
1468
(if success then "success" else "failure"));
1230
1469
if not success then
1231
1470
failwith "Rpc_server.bind: Cannot unregister old port";
1237
1476
let pm_set_new_port pm new_port f =
1238
if !debug_internals_log <> None then
1239
debug_internalsf "Rpc_server: registering port: %d" new_port;
1479
sprintf "registering port: %d" new_port);
1240
1480
Rpc_portmapper_clnt.PMAP.V2.pmapproc_set'async pm (pm_mapping new_port)
1241
1481
(fun get_result ->
1243
1483
let success = get_result() in
1244
if !debug_internals_log <> None then
1245
debug_internalsf "Rpc_server: portmapper reports %s"
1246
(if success then "success" else "failure");
1486
sprintf "portmapper reports %s"
1487
(if success then "success" else "failure"));
1247
1488
if not success then
1248
1489
failwith "Rpc_server.bind: Cannot register port";
1323
1564
(try srv.exception_handler error with _ -> ()) in
1325
1566
let pm_unset_port pm port f =
1326
if !debug_internals_log <> None then
1327
debug_internalsf "Rpc_server: unregistering port: %d" port;
1569
sprintf "unregistering port: %d" port);
1328
1570
Rpc_portmapper_clnt.PMAP.V2.pmapproc_unset'async pm (pm_mapping port)
1329
1571
(fun get_result ->
1331
1573
let success = get_result() in
1332
if !debug_internals_log <> None then
1333
debug_internalsf "Rpc_server: portmapper reports %s"
1334
(if success then "success" else "failure");
1576
sprintf "portmapper reports %s"
1577
(if success then "success" else "failure"));
1335
1578
if not success then
1336
1579
failwith "Rpc_server.unbind: Cannot unregister port";
1470
1713
let get_auth_method sess = sess.auth_method
1715
let get_last_proc_info srv = srv.get_last_proc()
1474
let reply a_session result_value =
1475
let conn = a_session.server in
1476
let srv = conn.whole_server in
1477
if conn.trans = None then raise Connection_lost;
1480
match a_session.prog with
1481
| None -> assert false
1484
let reply = Rpc_packer.pack_successful_reply
1485
prog a_session.procname a_session.client_id
1486
a_session.auth_ret_flav a_session.auth_ret_data
1492
parameter = XV_void;
1497
if !debug_service_log <> None then
1498
debug_servicef "Rpc_server (port %s, xid %s): Reply from %s"
1499
(mplexoptname conn.trans) (xidname a_session.client_id)
1502
Queue.add reply_session conn.replies;
1504
next_outgoing_message srv conn
1507
1719
let reply_error a_session condition =
1508
1720
let conn = a_session.server in
1509
1721
let srv = conn.whole_server in
1528
1740
let reply_session =
1529
1741
{ a_session with
1530
1742
parameter = XV_void;
1744
ptrace_result = (if !Debug.enable_ptrace then
1745
"Error " ^ errname condition
1535
if !debug_service_log <> None then
1536
debug_servicef "Rpc_server (port %s, xid %s): Error %s"
1537
(mplexoptname conn.trans) (xidname a_session.client_id)
1538
(errname condition);
1540
1752
Queue.add reply_session conn.replies;
1542
1754
next_outgoing_message srv conn
1757
let reply a_session result_value =
1758
let conn = a_session.server in
1759
let srv = conn.whole_server in
1763
sprintf "reply xid=%Ld have_encoder=%B"
1764
(Rtypes.int64_of_uint4 a_session.client_id)
1765
(a_session.encoder <> None)
1768
if conn.trans = None then raise Connection_lost;
1771
match a_session.prog with
1772
| None -> assert false
1777
let reply = Rpc_packer.pack_successful_reply
1778
?encoder:a_session.encoder
1779
prog a_session.procname a_session.client_id
1780
a_session.auth_ret_flav a_session.auth_ret_data
1786
parameter = XV_void;
1788
ptrace_result = (if !Debug.enable_ptrace then
1789
Rpc_util.string_of_response
1790
!Debug.ptrace_verbosity
1799
Queue.add reply_session conn.replies;
1800
next_outgoing_message srv conn
1802
with (* exceptions raised by the encoder *)
1805
"Dropping response message";
1807
| Rpc_server condition ->
1808
reply_error a_session condition;
1545
1814
let set_exception_handler srv eh =
1546
1815
srv.exception_handler <- eh
1571
1840
let set_timeout srv tmo =
1572
1841
srv.transport_timeout <- tmo
1843
let set_mstring_factories srv fac =
1844
srv.mstring_factories <- fac
1574
1846
let stop_server ?(graceful = false) srv =
1575
if !debug_internals_log <> None then
1576
debug_internalsf "Rpc_server: Stopping %s"
1577
(if graceful then " gracefully" else "");
1849
sprintf "Stopping %s" (if graceful then " gracefully" else ""));
1578
1850
(* Close TCP server socket, if present: *)
1579
1851
( match srv.master_acceptor with
added
removed
src/rpc/rpc_server.ml
