1
(* $Id: netsys_win32.ml 1505 2010-12-15 19:15:22Z gerd $ *)
3
(* Security of named pipes:
5
- http://www.blakewatts.com/namedpipepaper.html
6
- impersonation: http://msdn.microsoft.com/en-us/library/aa378832(VS.85).aspx
11
external fill_random : string -> unit = "netsys_fill_random"
17
(* How the proxy table works:
19
The i_* records are the values in the proxy table. The keys are the
20
proxy descriptors (which must be open all the time). When the last
21
reference to the proxy descriptor is released, the GC will call the
22
finalizer, and (with some trickery) the entry is removed from the
23
proxy table. Of course, the i_* records must not contain the proxy
24
descriptor - otherwise there would be a self-reference in the table,
25
and the entry is never released.
27
Because of this we define w_* types as a pair of the i_* records and
28
the proxy descriptors. The w_* types are the public types. As no
29
i_* can escape from its w_* value outside this module, it is ensured
30
that all public references of i_* also imply public references of the
31
proxy descriptor. So as long as there are w_* values the i_* values
34
When the proxy descriptor is accessed from outside the module, the
35
caller becomes responsible for closing it. Therefore we track whether
36
this is the case. The proxy descriptor is also stored in the c_* values
37
(i.e. in the values handled by the C part of this module), and so
38
the C-written finalizer can close the proxy descriptor if required.
39
There is a flag whether to do so (auto_close_*_proxy), and this flag
40
is cleared when the caller takes over the ownership of the descriptor.
43
type i_event = c_event
44
type w32_event = i_event * Unix.file_descr
45
(* The descriptor is the proxy descriptor *)
47
type pipe_mode = Pipe_in | Pipe_out | Pipe_duplex
51
pipe_mode : pipe_mode;
52
pipe_helper : c_pipe_helper;
53
(* mutable pipe_signal : w32_event option; *)
54
pipe_rd_event : w32_event;
55
pipe_wr_event : w32_event;
58
type w32_pipe = i_pipe * Unix.file_descr
59
(* The descriptor is the proxy descriptor *)
63
psrv_mode : pipe_mode;
65
mutable psrv_first : bool;
66
mutable psrv_queue : c_pipe_helper list;
67
(* The queue of pipes waiting for an incoming connection *)
68
mutable psrv_listen : int;
69
(* The backlog parameter of [listen] (target length of psrv_queue) *)
70
psrv_ready : c_pipe_helper Queue.t;
71
(* The already accepted but not yet reported connections *)
72
psrv_cn_event : w32_event;
73
psrv_proxy_handle : c_event;
74
psrv_mutex : Netsys_oothr.mutex;
76
(* As there is no C counterpart for the pipe server (no c_pipe_server),
77
the question is how to ensure that the proxy descriptor is closed.
78
For that reason we allocate an event (psrv_proxy_handle) and use
79
this event as proxy descriptor. For events there is the possibility
80
to let the C part of the module close the descriptor.
83
type w32_pipe_server = i_pipe_server * Unix.file_descr
84
(* The descriptor is the proxy descriptor *)
87
type pipe_conn_state = Pipe_deaf | Pipe_listening | Pipe_connected | Pipe_down
90
type i_process = c_process
92
type w32_process = i_process * Unix.file_descr
93
(* The descriptor is the proxy descriptor *)
96
{ ithr_descr : Unix.file_descr;
97
(* One can send command to the thread by setting ithr_cmd, and signaling
100
ithr_cmd_cond : Netsys_oothr.condition;
101
ithr_cmd_mutex : Netsys_oothr.mutex;
102
mutable ithr_cmd : [ `Read | `Cancel ] option;
103
mutable ithr_cancel_cmd : bool; (* similar to ithr_cmd = Some `Cancel *)
104
ithr_event : w32_event; (* The event is set when there is something to read *)
105
ithr_buffer : string;
106
mutable ithr_buffer_start : int;
107
mutable ithr_buffer_len : int;
108
mutable ithr_buffer_cond : [ `Cancelled | `EOF | `Exception of exn | `Data ];
109
mutable ithr_thread : int32; (* The Win32 thread ID *)
110
ithr_read_mutex : Netsys_oothr.mutex; (* to serialize user read accesses *)
111
mutable ithr_running : bool;
112
ithr_proxy_handle : c_event; (* the proxy - same pattern as in pipe servers *)
115
type w32_input_thread = i_input_thread * Unix.file_descr * < >
116
(* The descriptor is the proxy descriptor *)
119
type i_output_thread =
120
{ othr_descr : Unix.file_descr;
121
othr_cmd_cond : Netsys_oothr.condition;
122
othr_cmd_mutex : Netsys_oothr.mutex;
123
mutable othr_cmd : [ `Write | `Close | `Cancel ] option;
124
mutable othr_cancel_cmd : bool;
125
othr_event : w32_event;
126
othr_buffer : string;
127
mutable othr_buffer_len : int;
128
mutable othr_write_cond : [ `Cancelled | `Exception of exn ] option;
129
mutable othr_thread : int32; (* The Win32 thread ID *)
130
othr_write_mutex : Netsys_oothr.mutex;
131
mutable othr_running : bool;
132
othr_proxy_handle : c_event;
135
type w32_output_thread = i_output_thread * Unix.file_descr * < >
136
(* The descriptor is the proxy descriptor *)
142
| I_pipe_server of i_pipe_server
143
| I_process of i_process
144
| I_input_thread of i_input_thread * < >
145
| I_output_thread of i_output_thread * < >
148
| W32_event of w32_event
149
| W32_pipe of w32_pipe
150
| W32_pipe_server of w32_pipe_server
151
| W32_process of w32_process
152
| W32_input_thread of w32_input_thread
153
| W32_output_thread of w32_output_thread
156
type create_process_option =
157
| CP_change_directory of string
158
| CP_set_env of string
159
| CP_std_handles of Unix.file_descr * Unix.file_descr * Unix.file_descr
161
| CP_detach_from_console
163
| CP_inherit_or_create_console
164
| CP_unicode_environment
165
| CP_ansi_environment
166
| CP_new_process_group
167
| CP_inherit_process_group
171
module Int64Map = Map.Make(Int64)
174
external int64_of_file_descr : Unix.file_descr -> int64
175
= "netsys_int64_of_file_descr"
176
(* Also occurs in netsys.ml! *)
178
external netsys_win32_set_debug : bool -> unit
179
= "netsys_win32_set_debug"
181
module Debug = struct
182
let enable = ref false
184
let debug_c_wrapper = netsys_win32_set_debug
187
let dlog = Netlog.Debug.mk_dlog "Netsys_win32" Debug.enable
188
let dlogr = Netlog.Debug.mk_dlogr "Netsys_win32" Debug.enable
191
Netlog.Debug.register_module "Netsys_win32" Debug.enable
196
let equal (fd1) (fd2) =
202
module H = Hashtbl.Make(FD)
203
(* Hash table mapping
204
proxy file descriptors to the w32_object referenced by the descriptors.
205
The keys are the handle values contained in the fd values. As we allow
206
that proxies are [Unix.close]d it can happen that several fd's exist
207
that have the same handle values. In this case, the address of the
208
fd itself is used to distinguish between these same-looking fd's.
211
let proxies = ref (H.create 41)
212
let proxies_mutex = !Netsys_oothr.provider # create_mutex()
213
let proxies_gc_flag = ref false
214
let proxies_unreg_count = ref 0
218
let w = Weak.create 1 in
219
Weak.set w 0 (Some x);
226
let finalise_proxy cell _ =
227
(* the GC finaliser *)
228
proxies_unreg_count := !proxies_unreg_count + 1;
233
(* Walk through the table and check. We have to take care that the
234
order of the bindings for the same key is preserved, i.e. the most
235
recent use of a descriptor number needs to be the visible binding
238
let proxies' = H.create 41 in
242
(fun fd_num entries ->
247
let (_, cell) = entry in
248
if !cell <> None then (
254
H.add proxies' fd_num (List.rev !m)
258
proxies_unreg_count := 0;
259
proxies_gc_flag := false;
262
sprintf "register_proxy: keeping %d/%d entries in proxy tbl"
267
let b = Buffer.create 500 in
268
Buffer.add_string b "\n";
270
(fun fd_num entries ->
273
bprintf b " - proxy tbl %Ld -> %s\n"
277
| Some(I_event _) -> "I_event"
278
| Some(I_pipe _) -> "I_pipe"
279
| Some(I_pipe_server _) -> "I_pipe_server"
280
| Some(I_process _) -> "I_process"
281
| Some(I_input_thread _) -> "I_input_thread"
282
| Some(I_output_thread _) -> "I_output_thread"
292
let register_proxy fd i_obj =
293
let fd_num = int64_of_file_descr fd in
294
(* Note that it is possible that we register several i_obj for the same
295
fd_num. This can happen when fd is first closed, and then collected
296
by the GC. So after the close the OS can reuse the fd_num for something
297
else, but the old fd_num is still in the table.
299
Netsys_oothr.serialize
302
if (!proxies_gc_flag &&
303
2 * !proxies_unreg_count > H.length !proxies)
304
then ( (* do a GC pass *)
307
let cell = ref (Some i_obj) in
308
let fd_weak = mk_weak fd in
309
let l = try H.find !proxies fd_num with Not_found -> [] in
310
H.replace !proxies fd_num ((fd_weak, cell) :: l);
311
Gc.finalise (finalise_proxy cell) fd
317
(* called from user code *)
318
let fd_num = int64_of_file_descr fd in
319
Netsys_oothr.serialize
322
let l = try H.find !proxies fd_num with Not_found -> [] in
325
(fun (fd'_weak,cell) ->
326
match get_weak fd'_weak with
329
!cell <> None && fd != fd' (* phys. cmp! *)
332
H.replace !proxies fd_num l'
339
proxies_gc_flag := true
344
let fd_num = int64_of_file_descr fd in
345
Netsys_oothr.serialize
348
let l = H.find !proxies fd_num in
351
(fun (fd'_weak,cell) ->
352
match get_weak fd'_weak with
355
!cell <> None && fd == fd' (* phys. cmp! *)
367
| I_pipe_server i_psrv ->
368
W32_pipe_server(i_psrv, fd)
369
| I_process i_proc ->
370
W32_process(i_proc, fd)
371
| I_input_thread(i_thr, keep_alive) ->
372
W32_input_thread(i_thr, fd, keep_alive)
373
| I_output_thread(o_thr, keep_alive) ->
374
W32_output_thread(o_thr, fd, keep_alive)
384
| _ -> raise Not_found
386
failwith "Netsys_win32.lookup_pipe: not found"
388
let lookup_pipe_server fd =
391
| W32_pipe_server ph -> ph
392
| _ -> raise Not_found
394
failwith "Netsys_win32.lookup_pipe_server: not found"
396
let lookup_event fd =
400
| _ -> raise Not_found
402
failwith "Netsys_win32.lookup_event: not found"
404
let lookup_process fd =
408
| _ -> raise Not_found
410
failwith "Netsys_win32.lookup_process: not found"
412
let lookup_input_thread fd =
415
| W32_input_thread e -> e
416
| _ -> raise Not_found
418
failwith "Netsys_win32.lookup_input_thread: not found"
420
let lookup_output_thread fd =
423
| W32_output_thread e -> e
424
| _ -> raise Not_found
426
failwith "Netsys_win32.lookup_output_thread: not found"
429
external get_active_code_page : unit -> int
432
external netsys_real_select :
433
Unix.file_descr list ->
434
Unix.file_descr list ->
435
Unix.file_descr list ->
437
(Unix.file_descr list * Unix.file_descr list * Unix.file_descr list)
438
= "netsys_real_select"
440
let real_select = netsys_real_select
443
external netsys_test_close_on_exec : Unix.file_descr -> bool
444
= "netsys_test_close_on_exec"
446
let test_close_on_exec = netsys_test_close_on_exec
448
external netsys_modify_close_on_exec : Unix.file_descr -> bool -> unit
449
= "netsys_modify_close_on_exec"
451
let modify_close_on_exec = netsys_modify_close_on_exec
453
external netsys_is_crt_fd : Unix.file_descr -> int -> bool
456
let is_crt_fd = netsys_is_crt_fd
460
external netsys_create_event : unit -> c_event
461
= "netsys_create_event"
463
external netsys_event_descr : c_event -> Unix.file_descr
464
= "netsys_event_descr"
466
external netsys_close_event : c_event -> unit
467
= "netsys_close_event"
469
external netsys_set_auto_close_event_proxy : c_event -> bool -> unit
470
= "netsys_set_auto_close_event_proxy"
472
let decorate_event e =
473
let e_proxy = netsys_event_descr e in
474
let ev = (e, e_proxy) in
475
Gc.finalise netsys_close_event e;
476
register_proxy e_proxy (I_event e);
480
let ev = decorate_event(netsys_create_event()) in
482
sprintf "create_event: descr=%Ld"
483
(int64_of_file_descr (snd ev)));
487
let event_descr (e,e_proxy) =
488
netsys_set_auto_close_event_proxy e false;
491
external netsys_set_event : c_event -> unit
494
external netsys_reset_event : c_event -> unit
495
= "netsys_reset_event"
497
external netsys_test_event : c_event -> bool
498
= "netsys_test_event"
500
external netsys_event_wait : c_event -> int -> bool
501
= "netsys_event_wait"
503
let set_event (e,e_proxy) =
505
sprintf "set_event: descr=%Ld"
506
(int64_of_file_descr e_proxy));
509
let reset_event (e,e_proxy) =
511
sprintf "reset_event: descr=%Ld"
512
(int64_of_file_descr e_proxy));
515
let test_event (e,_) = netsys_test_event e
517
let event_wait (e,e_proxy) tmo =
519
sprintf "event_wait: descr=%Ld tmo=%f"
520
(int64_of_file_descr e_proxy) tmo);
522
Netsys_impl_util.slice_time_ms
524
if netsys_event_wait e tmo_ms then Some () else None
529
sprintf "event_wait: descr=%Ld returning %b"
530
(int64_of_file_descr e_proxy) flag);
535
external netsys_wsa_event_select :
536
c_event -> Unix.file_descr -> Netsys_posix.poll_req_events -> unit
537
= "netsys_wsa_event_select"
539
external wsa_maximum_wait_events : unit -> int
540
= "netsys_wsa_maximum_wait_events"
542
external netsys_wsa_wait_for_multiple_events :
543
c_event array -> int -> int option
544
= "netsys_wsa_wait_for_multiple_events"
546
external netsys_wsa_enum_network_events :
547
Unix.file_descr -> c_event -> Netsys_posix.poll_act_events
548
= "netsys_wsa_enum_network_events"
550
let wsa_event_select (e,e_proxy) fd pie =
552
sprintf "wsa_event_select: evdescr=%Ld sockdescr=%Ld bits=%d"
553
(int64_of_file_descr e_proxy)
554
(int64_of_file_descr fd)
555
(Netsys_posix.int_of_req_events pie)
557
netsys_wsa_event_select e fd pie
559
let wsa_wait_for_multiple_events ea n =
561
sprintf "wsa_wait_for_multiple_events: descrs=%s tmo=%d"
566
Int64.to_string(int64_of_file_descr e_proxy))
571
netsys_wsa_wait_for_multiple_events (Array.map fst ea) n in
573
sprintf "wsa_wait_for_multiple_events: returning %s"
577
let e_proxy = snd(ea.(k)) in
578
sprintf "Some %d (descr %Ld)"
579
k (int64_of_file_descr e_proxy)
583
let wsa_enum_network_events fd (e,e_proxy) =
584
let r = netsys_wsa_enum_network_events fd e in
586
sprintf "wsa_enum_network_events: sockdescr=%Ld evdescr=%Ld bits=%d"
587
(int64_of_file_descr fd)
588
(int64_of_file_descr e_proxy)
589
(Netsys_posix.int_of_act_events r)
595
external netsys_pipe_free :
596
c_pipe_helper -> unit
599
external netsys_create_local_named_pipe :
600
string -> pipe_mode -> int -> c_event -> bool -> c_pipe_helper
601
= "netsys_create_local_named_pipe"
603
external netsys_pipe_listen :
604
c_pipe_helper -> unit
605
= "netsys_pipe_listen"
607
external netsys_pipe_deafen :
608
c_pipe_helper -> unit
609
= "netsys_pipe_deafen"
611
external netsys_pipe_connect :
612
string -> pipe_mode -> c_pipe_helper
613
= "netsys_pipe_connect"
615
external netsys_pipe_read :
616
c_pipe_helper -> string -> int -> int -> int
619
external netsys_pipe_write :
620
c_pipe_helper -> string -> int -> int -> int
621
= "netsys_pipe_write"
623
external netsys_pipe_shutdown :
624
c_pipe_helper -> unit
625
= "netsys_pipe_shutdown"
627
external netsys_pipe_rd_event :
628
c_pipe_helper -> c_event
629
= "netsys_pipe_rd_event"
631
external netsys_pipe_wr_event :
632
c_pipe_helper -> c_event
633
= "netsys_pipe_wr_event"
635
external netsys_pipe_descr :
636
c_pipe_helper -> Unix.file_descr
637
= "netsys_pipe_descr"
639
external netsys_pipe_conn_state :
640
c_pipe_helper -> pipe_conn_state
641
= "netsys_pipe_conn_state"
643
external netsys_pipe_signal :
644
c_pipe_helper -> c_event -> unit
645
= "netsys_pipe_signal"
647
external netsys_set_auto_close_pipe_proxy : c_pipe_helper -> bool -> unit
648
= "netsys_set_auto_close_pipe_proxy"
653
| Pipe_in -> Pipe_out
654
| Pipe_out -> Pipe_in
655
| Pipe_duplex -> Pipe_duplex
657
let create_local_pipe_server name mode n =
658
let cn_event = create_event() in
659
let p_event = netsys_create_event() in
660
let proxy = netsys_event_descr p_event in
668
psrv_ready = Queue.create();
669
psrv_cn_event = cn_event;
670
psrv_proxy_handle = p_event;
671
psrv_mutex = !Netsys_oothr.provider # create_mutex();
673
Gc.finalise netsys_close_event p_event;
674
register_proxy proxy (I_pipe_server psrv);
676
sprintf "create_local_pipe_server: \
677
name=%s proxydescr=%Ld cnevdescr=%Ld"
679
(int64_of_file_descr proxy)
680
(int64_of_file_descr (snd cn_event))
686
let decorate_pipe_nogc ph name mode =
687
let fd = netsys_pipe_descr ph in
692
(* pipe_signal = None; *)
693
pipe_rd_event = decorate_event(netsys_pipe_rd_event ph);
694
pipe_wr_event = decorate_event(netsys_pipe_wr_event ph);
696
register_proxy fd (I_pipe pipe);
700
let decorate_pipe ph name mode =
701
Gc.finalise netsys_pipe_free ph;
702
decorate_pipe_nogc ph name mode
704
let prefix = "\\\\.\\pipe\\"
705
let prefix_len = String.length prefix
707
let pipe_connect name mode =
708
(* Check that name starts with the right prefix, to prevent security
711
if String.length name < prefix_len ||
712
(String.sub name 0 prefix_len <> prefix)
714
raise(Unix.Unix_error(Unix.EPERM, "pipe_connect", name));
716
dlogr (fun () -> sprintf "pipe_connect: name=%s" name);
717
let pipe = decorate_pipe(netsys_pipe_connect name mode) name mode in
718
dlogr (fun () -> sprintf "pipe_connect: name=%s returning %Ld"
719
name (int64_of_file_descr (snd pipe)));
722
let pipe_server_descr (psrv, psrv_proxy) =
723
netsys_set_auto_close_event_proxy psrv.psrv_proxy_handle false;
726
let pipe_descr (pipe, pipe_proxy) =
727
netsys_set_auto_close_pipe_proxy pipe.pipe_helper false;
730
let pipe_server_endpoint psrv =
732
netsys_create_local_named_pipe
733
psrv.psrv_name psrv.psrv_mode psrv.psrv_max
734
(fst psrv.psrv_cn_event) psrv.psrv_first in
735
Gc.finalise netsys_pipe_free ph;
736
netsys_pipe_listen ph;
737
psrv.psrv_first <- false;
740
let pipe_listen_lck psrv n =
741
if psrv.psrv_listen < n then (
742
let d = n - psrv.psrv_listen in
744
let ph = pipe_server_endpoint psrv in
745
psrv.psrv_queue <- ph :: psrv.psrv_queue
748
(* else: we do nothing. You may consider this as a bug, but it is simply
749
too risky to shut down server pipes because of race conditions
751
psrv.psrv_listen <- n
754
let pipe_listen (psrv, psrv_proxy) n =
755
dlogr (fun () -> sprintf "pipe_listen: name=%s proxydescr=%Ld n=%d"
756
psrv.psrv_name (int64_of_file_descr psrv_proxy) n);
757
Netsys_oothr.serialize
759
(fun () -> pipe_listen_lck psrv n)
763
let check_for_connections psrv =
764
let rec find_delete l =
769
let s = netsys_pipe_conn_state ph in
770
if s = Pipe_connected then (
771
Queue.push ph psrv.psrv_ready;
778
let queue' = find_delete psrv.psrv_queue in
779
let old_listen = psrv.psrv_listen in
780
psrv.psrv_listen <- List.length queue';
781
psrv.psrv_queue <- queue';
782
pipe_listen_lck psrv old_listen
784
(* In rare cases it may happen that cn_event is reset for a short
785
period of time, and then set again.
788
let rec pipe_accept_1 psrv =
789
match Queue.length psrv.psrv_ready with
791
ignore(event_wait psrv.psrv_cn_event (-1.0));
792
reset_event psrv.psrv_cn_event;
793
check_for_connections psrv;
794
if not(Queue.is_empty psrv.psrv_ready) then
795
set_event psrv.psrv_cn_event;
798
let ph = Queue.take psrv.psrv_ready in
799
reset_event psrv.psrv_cn_event;
800
check_for_connections psrv;
801
if not(Queue.is_empty psrv.psrv_ready) then
802
set_event psrv.psrv_cn_event;
803
ignore(netsys_pipe_read ph "" 0 0); (* check for errors *)
804
decorate_pipe_nogc ph psrv.psrv_name psrv.psrv_mode
806
let ph = Queue.take psrv.psrv_ready in
807
ignore(netsys_pipe_read ph "" 0 0); (* check for errors *)
808
decorate_pipe_nogc ph psrv.psrv_name psrv.psrv_mode
811
let pipe_accept (psrv, psrv_proxy) =
812
dlogr (fun () -> sprintf "pipe_accept: name=%s proxydescr=%Ld"
813
psrv.psrv_name (int64_of_file_descr psrv_proxy));
815
Netsys_oothr.serialize
817
(fun () -> pipe_accept_1 psrv)
819
dlogr (fun () -> sprintf "pipe_accept: name=%s proxydescr=%Ld returning %Ld"
820
psrv.psrv_name (int64_of_file_descr psrv_proxy)
821
(int64_of_file_descr (snd pipe))
826
let pipe_rd_event (pipe,_) =
829
let pipe_wr_event (pipe,_) =
832
let pipe_connect_event (psrv,_) =
836
let pipe_read (pipe,pipe_proxy) s pos len =
837
if pos < 0 || len < 0 || pos > String.length s - len then
838
invalid_arg "Netsys_win32.pipe_read";
839
dlogr (fun () -> sprintf "pipe_read: name=%s proxydescr=%Ld len=%d"
840
pipe.pipe_name (int64_of_file_descr pipe_proxy) len);
842
let n = netsys_pipe_read pipe.pipe_helper s pos len in
843
dlogr (fun () -> sprintf "pipe_read: name=%s proxydescr=%Ld returning %d"
844
pipe.pipe_name (int64_of_file_descr pipe_proxy) n);
847
| error when !Debug.enable ->
849
sprintf "pipe_read: name=%s proxydescr=%Ld exception %s"
850
pipe.pipe_name (int64_of_file_descr pipe_proxy)
851
(Netexn.to_string error)
856
let pipe_write (pipe,pipe_proxy) s pos len =
857
if pos < 0 || len < 0 || pos > String.length s - len then
858
invalid_arg "Netsys_win32.pipe_write";
859
dlogr (fun () -> sprintf "pipe_write: name=%s proxydescr=%Ld len=%d"
860
pipe.pipe_name (int64_of_file_descr pipe_proxy) len);
862
let n = netsys_pipe_write pipe.pipe_helper s pos len in
863
dlogr (fun () -> sprintf "pipe_write: name=%s proxydescr=%Ld returning %d"
864
pipe.pipe_name (int64_of_file_descr pipe_proxy) n);
867
| error when !Debug.enable ->
869
sprintf "pipe_write: name=%s proxydescr=%Ld exception %s"
870
pipe.pipe_name (int64_of_file_descr pipe_proxy)
871
(Netexn.to_string error)
876
let pipe_shutdown (pipe,pipe_proxy) =
877
dlogr (fun () -> sprintf "pipe_shutdown: name=%s proxydescr=%Ld"
878
pipe.pipe_name (int64_of_file_descr pipe_proxy));
879
netsys_pipe_shutdown pipe.pipe_helper
881
let pipe_shutdown_server (psrv,psrv_proxy) =
882
dlogr (fun () -> sprintf "pipe_shutdown_server: name=%s proxydescr=%Ld"
883
psrv.psrv_name (int64_of_file_descr psrv_proxy));
884
Netsys_oothr.serialize
889
netsys_pipe_shutdown ph
892
psrv.psrv_queue <- [];
893
psrv.psrv_listen <- 0
898
let pipe_wait_rd (pipe,pipe_proxy) tmo =
899
dlogr (fun () -> sprintf "pipe_wait_rd: name=%s proxydescr=%Ld"
900
pipe.pipe_name (int64_of_file_descr pipe_proxy));
901
event_wait pipe.pipe_rd_event tmo
903
let pipe_wait_wr (pipe,pipe_proxy) tmo =
904
dlogr (fun () -> sprintf "pipe_wait_wr: name=%s proxydescr=%Ld"
905
pipe.pipe_name (int64_of_file_descr pipe_proxy));
906
event_wait pipe.pipe_wr_event tmo
908
let pipe_wait_connect (psrv,psrv_proxy) tmo =
909
dlogr (fun () -> sprintf "pipe_wait_connect: name=%s proxydescr=%Ld"
910
psrv.psrv_name (int64_of_file_descr psrv_proxy));
911
event_wait psrv.psrv_cn_event tmo
913
let pipe_name (pipe,_) =
916
let pipe_server_name (psrv,_) =
919
let pipe_mode (pipe,_) =
922
let pipe_server_mode (psrv,_) =
927
let counter_mutex = !Netsys_oothr.provider # create_mutex()
929
let unpredictable_pipe_name() =
931
counter_mutex # lock();
934
counter_mutex # unlock();
937
let random = String.make 16 ' ' in
940
"\\\\.\\pipe\\ocamlnet" ^
941
string_of_int (Unix.getpid()) ^ "_" ^ string_of_int n ^ "_" ^
942
Digest.to_hex random in
946
(* FIXME: If somebody guesses the pipe name (which is hard),
947
it is possible to connect from the outside to lph. We detect
948
this problem, and give up on the pipe pair, but external code can
949
make our programs unreliable.
954
| Pipe_in -> Pipe_out
955
| Pipe_out -> Pipe_in
956
| Pipe_duplex -> Pipe_duplex in
957
let name = unpredictable_pipe_name() in
958
let psrv = create_local_pipe_server name mode 1 in
960
let rph = pipe_connect name mode' in
963
let lph = pipe_accept psrv in
965
let s = String.create 0 in
966
ignore(pipe_write lph s 0 0);
969
sprintf "pipe_pair: returning \
970
name=%s proxydescr1=%Ld proxydescr2=%Ld"
972
(int64_of_file_descr (snd lph))
973
(int64_of_file_descr (snd rph))
986
external netsys_create_process : string -> string ->
987
create_process_option list -> c_process
988
= "netsys_create_process"
990
external netsys_close_process : c_process -> unit
991
= "netsys_close_process"
993
external netsys_get_process_status : c_process -> int
994
= "netsys_get_process_status"
996
external netsys_as_process_event : c_process -> c_event
997
= "netsys_as_process_event"
999
external netsys_emulated_pid : c_process -> int
1000
= "netsys_emulated_pid"
1002
external netsys_win_pid : c_process -> int
1005
external netsys_process_free : c_process -> unit
1006
= "netsys_process_free"
1008
external netsys_process_descr : c_process -> Unix.file_descr
1009
= "netsys_process_descr"
1011
external netsys_set_auto_close_process_proxy : c_process -> bool -> unit
1012
= "netsys_set_auto_close_process_proxy"
1014
external netsys_terminate_process : c_process -> unit
1015
= "netsys_terminate_process"
1017
let close_process (c_proc, _) =
1018
netsys_process_free c_proc
1020
let get_process_status (c_proc,_) =
1022
let code = netsys_get_process_status c_proc in
1023
Some(Unix.WEXITED code)
1028
[ CP_inherit_or_create_console;
1029
CP_ansi_environment;
1030
CP_inherit_process_group
1033
let create_process cmd cmdline opts =
1034
let opts = (* prepend defaults: *)
1035
default_opts @ opts in
1036
let c_proc = netsys_create_process cmd cmdline opts in
1037
let proxy = netsys_process_descr c_proc in
1038
register_proxy proxy (I_process c_proc);
1039
Gc.finalise netsys_process_free c_proc;
1040
ignore(get_process_status (c_proc,proxy));
1041
(* The new process seems to remain suspended until the caller waits
1042
for the process handle. So we do this here.
1046
let terminate_process (c_proc,_) =
1047
netsys_terminate_process c_proc
1049
let as_process_event (c_proc,_) =
1050
let ev = netsys_as_process_event c_proc in
1053
let emulated_pid (c_proc,_) =
1054
netsys_emulated_pid c_proc
1056
let win_pid (c_proc, _) =
1057
netsys_win_pid c_proc
1059
let process_descr (c_proc, fd) =
1060
netsys_set_auto_close_process_proxy c_proc false;
1063
let cp_set_env env =
1064
CP_set_env(String.concat "\000" (Array.to_list env) ^ "\000")
1065
(* another null byte is implicitly added by the ocaml runtime! *)
1067
external search_path : string option -> string -> string option -> string
1068
= "netsys_search_path"
1071
type w32_console_attr =
1072
{ mutable cursor_x : int;
1073
mutable cursor_y : int;
1074
mutable cursor_size : int;
1075
mutable cursor_visible : bool;
1076
mutable text_attr : int;
1079
type w32_console_info =
1081
mutable width : int;
1082
mutable height : int;
1085
type w32_console_mode =
1086
{ mutable enable_echo_input : bool;
1087
mutable enable_insert_mode : bool;
1088
mutable enable_line_input : bool;
1089
mutable enable_processed_input : bool;
1090
mutable enable_quick_edit_mode : bool;
1091
mutable enable_processed_output : bool;
1092
mutable enable_wrap_at_eol_output : bool;
1095
external has_console : unit -> bool
1096
= "netsys_has_console"
1098
external is_console : Unix.file_descr -> bool
1099
= "netsys_is_console"
1101
external alloc_console : unit -> unit
1102
= "netsys_alloc_console"
1104
let get_console_input() =
1105
if not(has_console()) then
1107
Unix.openfile "CONIN$" [Unix.O_RDWR] 0
1108
(* O_RDONLY is insufficient for certain console ops *)
1111
let get_console_output() =
1112
if not(has_console()) then
1114
Unix.openfile "CONOUT$" [Unix.O_RDWR] 0
1115
(* O_WRONLY is insufficient for certain console ops *)
1117
external get_console_attr : unit -> w32_console_attr
1118
= "netsys_get_console_attr"
1120
external set_console_attr : w32_console_attr -> unit
1121
= "netsys_set_console_attr"
1123
external get_console_info : unit -> w32_console_info
1124
= "netsys_get_console_info"
1129
let fg_intensity = 8
1133
let bg_intensity = 128
1135
external get_console_mode : unit -> w32_console_mode
1136
= "netsys_get_console_mode"
1138
external set_console_mode : w32_console_mode -> unit
1139
= "netsys_set_console_mode"
1141
external init_console_codepage : unit -> unit
1142
= "netsys_init_console_codepage"
1147
external clear_console : clear_mode -> unit
1148
= "netsys_clear_console"
1150
let clear_until_end_of_line() = clear_console EOL
1152
let clear_until_end_of_screen() = clear_console EOS
1154
let clear_console() = clear_console All
1157
external get_current_thread_id : unit -> int32
1158
= "netsys_get_current_thread_id"
1160
external cancel_synchronous_io : int32 -> unit
1161
= "netsys_cancel_synchronous_io"
1162
(* Only implemented on Vista (and newer). *)
1166
module InputThread = struct
1167
let rec thread_body (ithr : i_input_thread) =
1168
(* Check for new commands: *)
1170
sprintf "input_thread_body: descr=%Ld waiting"
1171
(int64_of_file_descr ithr.ithr_descr));
1172
ithr.ithr_cmd_mutex # lock();
1173
while ithr.ithr_cmd = None && not ithr.ithr_cancel_cmd do
1174
ithr.ithr_cmd_cond # wait ithr.ithr_cmd_mutex
1177
if ithr.ithr_cancel_cmd then
1180
match ithr.ithr_cmd with
1184
ithr.ithr_cmd <- None;
1190
sprintf "input_thread_body: descr=%Ld got `Cancel"
1191
(int64_of_file_descr ithr.ithr_descr));
1192
ithr.ithr_buffer_cond <- `Cancelled;
1196
sprintf "input_thread_body: descr=%Ld got `Read"
1197
(int64_of_file_descr ithr.ithr_descr));
1204
(String.length ithr.ithr_buffer) in
1206
ithr.ithr_buffer_cond <- `EOF;
1207
ithr.ithr_buffer_start <- 0;
1208
ithr.ithr_buffer_len <- 0;
1212
ithr.ithr_buffer_cond <- `Data;
1213
ithr.ithr_buffer_start <- 0;
1214
ithr.ithr_buffer_len <- n;
1218
| Unix.Unix_error(Unix.EPIPE,_,_) -> (* same as EOF *)
1219
ithr.ithr_buffer_cond <- `EOF;
1220
ithr.ithr_buffer_start <- 0;
1221
ithr.ithr_buffer_len <- 0;
1224
ithr.ithr_buffer_cond <- `Exception error;
1225
ithr.ithr_buffer_start <- 0;
1226
ithr.ithr_buffer_len <- 0;
1231
sprintf "input_thread_body: descr=%Ld unblocking"
1232
(int64_of_file_descr ithr.ithr_descr));
1233
set_event ithr.ithr_event;
1234
ithr.ithr_cmd_mutex # unlock();
1240
sprintf "input_thread_body: descr=%Ld terminating"
1241
(int64_of_file_descr ithr.ithr_descr));
1242
Unix.close ithr.ithr_descr;
1243
ithr.ithr_running <- false
1247
let i_cancel_input_thread ithr =
1249
sprintf "cancel_input_thread: descr=%Ld"
1250
(int64_of_file_descr ithr.ithr_descr));
1251
ithr.ithr_cancel_cmd <- true; (* don't mess with locks here *)
1252
ithr.ithr_cmd_cond # signal();
1253
(* This is clearly a race condition... The thread may terminate
1254
right now, and cancel_io_thread is called with an invalid thread
1257
if ithr.ithr_running then (
1259
cancel_synchronous_io ithr.ithr_thread
1263
let f_cancel_input_thread ithr _ =
1264
i_cancel_input_thread ithr
1266
let cancel_input_thread (ithr,_,_) =
1267
i_cancel_input_thread ithr
1269
let create_input_thread fd =
1270
let oothr = !Netsys_oothr.provider in
1271
let init_cond = oothr#create_condition() in
1272
let init_mutex = oothr#create_mutex() in
1273
let p_event = netsys_create_event() in
1274
let proxy = netsys_event_descr p_event in
1277
ithr_cmd_cond = oothr#create_condition();
1278
ithr_cmd_mutex = oothr#create_mutex();
1279
ithr_cmd = Some `Read;
1280
ithr_cancel_cmd = false;
1281
ithr_event = create_event();
1282
ithr_buffer = String.create 4096;
1283
ithr_buffer_start = 0;
1284
ithr_buffer_len = 0;
1285
ithr_buffer_cond = `Data;
1286
ithr_thread = 0l; (* initialized below *)
1287
ithr_read_mutex = oothr#create_mutex();
1288
ithr_running = true;
1289
ithr_proxy_handle = p_event;
1292
oothr # create_thread
1294
ithr.ithr_thread <- get_current_thread_id();
1295
init_cond # signal();
1299
init_cond # wait init_mutex;
1300
let f = f_cancel_input_thread ithr in
1301
let keep_alive = (object end) in
1302
Gc.finalise f keep_alive;
1303
Gc.finalise netsys_close_event p_event;
1304
register_proxy proxy (I_input_thread(ithr, keep_alive));
1305
(ithr, proxy, keep_alive)
1308
let input_thread_read (ithr,_,_) s pos len =
1309
if pos < 0 || len < 0 || pos > String.length s - len then
1310
invalid_arg "Netsys_win32.input_thread_read";
1315
Netsys_oothr.serialize
1316
ithr.ithr_read_mutex (* only one reader at a time *)
1318
let b = test_event ithr.ithr_event in
1320
ithr.ithr_cmd_mutex # lock();
1321
(* Look at what we have: *)
1322
match ithr.ithr_buffer_cond with
1324
ithr.ithr_cmd_mutex # unlock();
1327
ithr.ithr_cmd_mutex # unlock();
1330
ithr.ithr_cmd_mutex # unlock();
1331
raise(Unix.Unix_error(Unix.EPERM,
1332
"Netsys_win32.input_thread_read", ""))
1334
let n = min len ithr.ithr_buffer_len in
1336
ithr.ithr_buffer ithr.ithr_buffer_start
1339
ithr.ithr_buffer_start <- ithr.ithr_buffer_start + n;
1340
ithr.ithr_buffer_len <- ithr.ithr_buffer_len - n;
1341
if ithr.ithr_buffer_len = 0 then (
1342
ithr.ithr_cmd <- Some `Read;
1343
ithr.ithr_cmd_cond # signal();
1344
reset_event ithr.ithr_event;
1346
ithr.ithr_cmd_mutex # unlock();
1350
raise(Unix.Unix_error(Unix.EAGAIN,
1351
"Netsys_win32.input_thread_read", ""))
1356
let input_thread_event (ithr,_,_) =
1359
let input_thread_proxy_descr (ithr, proxy, _) =
1360
netsys_set_auto_close_event_proxy ithr.ithr_proxy_handle false;
1365
let create_input_thread = InputThread.create_input_thread
1366
let input_thread_event = InputThread.input_thread_event
1367
let input_thread_read = InputThread.input_thread_read
1368
let cancel_input_thread = InputThread.cancel_input_thread
1369
let input_thread_proxy_descr = InputThread.input_thread_proxy_descr
1370
let input_thread_descr (ithr,_,_) = ithr.ithr_descr
1373
module OutputThread = struct
1374
let rec write_string othr pos len =
1375
if len = 0 || othr.othr_cancel_cmd then
1378
let n = Unix.single_write othr.othr_descr othr.othr_buffer pos len in
1379
write_string othr (pos+n) (len-n)
1382
let rec thread_body (othr : i_output_thread) =
1383
(* Check for new commands: *)
1385
sprintf "output_thread_body: descr=%Ld waiting"
1386
(int64_of_file_descr othr.othr_descr));
1387
othr.othr_cmd_mutex # lock();
1388
while othr.othr_cmd = None && not othr.othr_cancel_cmd do
1389
othr.othr_cmd_cond # wait othr.othr_cmd_mutex
1392
if othr.othr_cancel_cmd then
1395
match othr.othr_cmd with
1399
othr.othr_cmd <- None;
1405
sprintf "output_thread_body: descr=%Ld got `Cancel"
1406
(int64_of_file_descr othr.othr_descr));
1407
othr.othr_buffer_len <- 0;
1408
othr.othr_write_cond <- Some `Cancelled;
1412
sprintf "output_thread_body: descr=%Ld got `Close"
1413
(int64_of_file_descr othr.othr_descr));
1414
othr.othr_write_cond <- Some `Cancelled;
1418
sprintf "output_thread_body: descr=%Ld got `Write"
1419
(int64_of_file_descr othr.othr_descr));
1421
write_string othr 0 othr.othr_buffer_len;
1422
othr.othr_buffer_len <- 0;
1426
othr.othr_write_cond <- Some (`Exception error);
1431
sprintf "output_thread_body: descr=%Ld unblocking"
1432
(int64_of_file_descr othr.othr_descr));
1433
set_event othr.othr_event;
1434
othr.othr_cmd_mutex # unlock();
1440
sprintf "output_thread_body: descr=%Ld terminating"
1441
(int64_of_file_descr othr.othr_descr));
1442
Unix.close othr.othr_descr;
1443
othr.othr_running <- false
1447
let i_cancel_output_thread othr =
1449
sprintf "cancel_output_thread: descr=%Ld"
1450
(int64_of_file_descr othr.othr_descr));
1451
othr.othr_cancel_cmd <- true; (* don't mess with locks here *)
1452
othr.othr_cmd_cond # signal();
1453
(* This is clearly a race condition... The thread may terminate
1454
right now, and cancel_io_thread is called with an invalid thread
1457
if othr.othr_running then (
1459
cancel_synchronous_io othr.othr_thread
1463
let f_cancel_output_thread othr _ =
1464
i_cancel_output_thread othr
1466
let cancel_output_thread (othr,_,_) =
1467
i_cancel_output_thread othr
1469
let create_output_thread fd =
1470
let oothr = !Netsys_oothr.provider in
1471
let init_cond = oothr#create_condition() in
1472
let init_mutex = oothr#create_mutex() in
1473
let p_event = netsys_create_event() in
1474
let proxy = netsys_event_descr p_event in
1477
othr_cmd_cond = oothr#create_condition();
1478
othr_cmd_mutex = oothr#create_mutex();
1480
othr_cancel_cmd = false;
1481
othr_event = create_event();
1482
othr_buffer = String.create 4096;
1483
othr_buffer_len = 0;
1484
othr_write_cond = None;
1485
othr_thread = 0l; (* initialized below *)
1486
othr_write_mutex = oothr#create_mutex();
1487
othr_running = true;
1488
othr_proxy_handle = p_event;
1490
set_event othr.othr_event;
1492
oothr # create_thread
1494
othr.othr_thread <- get_current_thread_id();
1495
init_cond # signal();
1499
init_cond # wait init_mutex;
1500
let f = f_cancel_output_thread othr in
1501
let keep_alive = (object end) in
1502
Gc.finalise f keep_alive;
1503
Gc.finalise netsys_close_event p_event;
1504
register_proxy proxy (I_output_thread(othr, keep_alive));
1505
(othr, proxy, keep_alive)
1508
let output_thread_write (othr,_,_) s pos len =
1509
if pos < 0 || len < 0 || pos > String.length s - len then
1510
invalid_arg "Netsys_win32.output_thread_write";
1515
Netsys_oothr.serialize
1516
othr.othr_write_mutex (* only one writer at a time *)
1518
let b = test_event othr.othr_event in
1520
othr.othr_cmd_mutex # lock();
1521
(* Look at what we have: *)
1522
match othr.othr_write_cond with
1523
| Some(`Exception e) ->
1524
othr.othr_cmd_mutex # unlock();
1526
| Some `Cancelled ->
1527
othr.othr_cmd_mutex # unlock();
1528
raise(Unix.Unix_error(Unix.EPERM,
1529
"Netsys_win32.output_thread_write",
1532
assert(othr.othr_buffer_len = 0);
1533
let n = min len (String.length othr.othr_buffer) in
1538
othr.othr_buffer_len <- n;
1539
othr.othr_cmd <- Some `Write;
1540
othr.othr_cmd_cond # signal();
1541
reset_event othr.othr_event;
1542
othr.othr_cmd_mutex # unlock();
1546
raise(Unix.Unix_error(Unix.EAGAIN,
1547
"Netsys_win32.output_thread_write", ""))
1552
let close_output_thread (othr,_,_) =
1553
Netsys_oothr.serialize
1554
othr.othr_write_mutex (* only one writer at a time *)
1556
let b = test_event othr.othr_event in
1558
othr.othr_cmd_mutex # lock();
1559
(* Look at what we have: *)
1560
match othr.othr_write_cond with
1561
| Some(`Exception e) ->
1562
othr.othr_cmd_mutex # unlock();
1564
| Some `Cancelled ->
1565
othr.othr_cmd_mutex # unlock();
1566
raise(Unix.Unix_error(Unix.EPERM,
1567
"Netsys_win32.close_output_thread",
1570
assert(othr.othr_buffer_len = 0);
1571
othr.othr_cmd <- Some `Close;
1572
othr.othr_cmd_cond # signal();
1573
reset_event othr.othr_event;
1574
othr.othr_cmd_mutex # unlock();
1577
raise(Unix.Unix_error(Unix.EAGAIN,
1578
"Netsys_win32.close_output_thread", ""))
1584
let output_thread_event (othr,_,_) =
1587
let output_thread_proxy_descr (othr, proxy, _) =
1588
netsys_set_auto_close_event_proxy othr.othr_proxy_handle false;
1593
let create_output_thread = OutputThread.create_output_thread
1594
let output_thread_event = OutputThread.output_thread_event
1595
let output_thread_write = OutputThread.output_thread_write
1596
let cancel_output_thread = OutputThread.cancel_output_thread
1597
let close_output_thread = OutputThread.close_output_thread
1598
let output_thread_proxy_descr = OutputThread.output_thread_proxy_descr
1599
let output_thread_descr (othr,_,_) = othr.othr_descr
added
removed
src/netsys/netsys_win32.ml
