1
(* $Id: nethttpd_reactor.ml 1101 2007-04-09 11:02:10Z gerd $
6
* Copyright 2005 Baretta s.r.l. and Gerd Stolpmann
8
* This file is part of Nethttpd.
10
* Nethttpd is free software; you can redistribute it and/or modify
11
* it under the terms of the GNU General Public License as published by
12
* the Free Software Foundation; either version 2 of the License, or
13
* (at your option) any later version.
15
* Nethttpd is distributed in the hope that it will be useful,
16
* but WITHOUT ANY WARRANTY; without even the implied warranty of
17
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18
* GNU General Public License for more details.
20
* You should have received a copy of the GNU General Public License
21
* along with WDialog; if not, write to the Free Software
22
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
31
class type http_processor_config =
33
inherit Nethttpd_kernel.http_protocol_config
34
method config_timeout_next_request : float
35
method config_timeout : float
36
method config_cgi : Netcgi1_compat.Netcgi_env.cgi_config
37
method config_error_response : int -> string
38
method config_log_error :
39
Unix.sockaddr option -> Unix.sockaddr option -> http_method option -> http_header option -> string -> unit
42
class type http_reactor_config =
44
inherit http_processor_config
45
method config_reactor_synch : [ `Connection | `Close | `Flush | `Write ]
49
class type internal_environment =
51
inherit extended_environment
53
method unlock : unit -> unit
54
method req_method : http_method
55
method response : http_response
59
class type http_reactive_request =
61
method environment : extended_environment
62
method accept_body : unit -> unit
63
method reject_body : unit -> unit
64
method finish : unit -> unit
65
method finish_request : unit -> unit
69
let get_this_host addr =
71
| Unix.ADDR_UNIX path ->
72
("", None) (* questionable *)
73
| Unix.ADDR_INET(ia,port) ->
74
(Unix.string_of_inet_addr ia, Some port)
78
class http_environment (proc_config : #http_processor_config)
79
req_meth req_uri req_version req_hdr
81
in_ch out_ch resp close_after_send_file
82
: internal_environment =
84
(* Decode important input header fields: *)
85
let (in_host, in_port_opt) =
86
(* Host and port of the [Host] header *)
90
(* For HTTP/1.1 and later this is not allowed. For earlier protocols, we
91
* just fill in the IP address that accepted the request.
93
( match req_version with
94
| `Http((1,n),_) when n>= 1 ->
95
raise(Standard_response(`Bad_request,
97
Some "Nethttpd: Bad request: [Host] header is missing"))
101
| Bad_header_field _ ->
102
raise(Standard_response(`Bad_request,
104
Some "Nethttpd: Bad request: Cannot decode [Host] header")) in
106
let (script_name, query_string) = decode_query req_uri in
110
"http://" ^ in_host ^
111
(match in_port with Some n -> ":" ^ string_of_int n | None -> "") ^
116
inherit empty_environment
118
val mutable locked = true
121
config <- proc_config # config_cgi;
122
in_state <- `Received_header;
124
in_header <- req_hdr;
126
out_channel <- out_ch;
127
protocol <- req_version;
128
properties <- [ "GATEWAY_INTERFACE", "Nethttpd/0.0";
129
"SERVER_SOFTWARE", "Nethttpd/0.0";
130
"SERVER_NAME", in_host;
131
"SERVER_PROTOCOL", string_of_protocol req_version;
132
"REQUEST_METHOD", req_meth;
133
"SCRIPT_NAME", script_name;
134
(* "PATH_INFO", ""; *)
135
(* "PATH_TRANSLATED", ""; *)
136
"QUERY_STRING", query_string;
137
(* "REMOTE_HOST", ""; *)
138
"REMOTE_ADDR", fst(get_this_host peer_addr);
139
(* "AUTH_TYPE", ""; *)
140
(* "REMOTE_USER", ""; *)
141
(* "REMOTE_IDENT", ""; *)
143
"REQUEST_URI", req_uri;
145
( match in_port_opt with
146
| Some p -> [ "SERVER_PORT", string_of_int p ]
153
method server_socket_addr = fd_addr
154
method remote_socket_addr = peer_addr
156
method response = resp
157
method req_method = (req_meth, req_uri)
159
method send_output_header() =
160
if locked then failwith "Nethttpd_reactor: channel is locked";
161
if out_state <> `Start then
162
failwith "send_output_header";
163
(* The response status is encoded in the [Status] pseudo header *)
164
let (code, phrase) = status_of_cgi_header out_header in
165
resp # send (`Resp_status_line(code, phrase));
166
(* Create a copy of the header without [Status]: *)
167
let h = new Netmime.basic_mime_header out_header#fields in
168
h # delete_field "Status";
169
resp # send (`Resp_header h);
170
out_state <- `Sent_header
172
method send_file fd length =
173
if locked then failwith "Nethttpd_reactor: channel is locked";
174
if out_state <> `Start then
175
failwith "send_file";
176
(* The response status is encoded in the [Status] pseudo header *)
177
let (code, phrase) = status_of_cgi_header out_header in
178
let status = http_status_of_int code in
179
(* Create a copy of the header without [Status]: *)
180
let h = new Netmime.basic_mime_header out_header#fields in
181
h # delete_field "Status";
182
send_file_response resp status (Some h) fd length;
183
out_state <- `Sending_body; (* best approximation *)
184
close_after_send_file()
187
proc_config # config_log_error
188
(Some fd_addr) (Some peer_addr) (Some(req_meth,req_uri)) (Some req_hdr) s
193
class http_reactor_input next_token = (* an extension of rec_in_channel *)
195
val mutable current_chunk = None
196
val mutable eof = false
197
val mutable closed = false
198
val mutable locked = true
200
method private refill() =
201
match next_token() with
202
| `Req_body(s,pos,len) ->
204
current_chunk <- Some(s,pos,len)
206
self # refill () (* ignore *)
208
current_chunk <- None;
212
(* Something else... Handle this as `Req_end! *)
213
current_chunk <- None;
218
method input s spos slen =
219
if closed then raise Closed_channel;
220
if locked then failwith "Nethttpd_reactor: channel is locked";
221
if eof then raise End_of_file;
222
if current_chunk = None then self#refill();
223
match current_chunk with
224
| Some(u,upos,ulen) ->
225
(* We have [ulen] data, copy that to [s] *)
226
let len = min slen ulen in
227
String.blit u upos s spos len;
228
let ulen' = ulen - len in
230
current_chunk <- None
232
current_chunk <- Some(u,upos+len,ulen');
235
(* After [refill] this is not possible *)
239
if closed then raise Closed_channel;
240
if locked then failwith "Nethttpd_reactor: channel is locked";
241
(* It is no problem to ignore further arriving tokens. These will be "eaten" by
242
* [finish_request] later. (Of course, we could call [finish_request] here,
243
* but that would probably defer the generation of responses.)
257
class http_reactor_output config resp synch = (* an extension of rec_in_channel *)
259
val mutable closed = false
260
val mutable locked = true
262
method output s spos slen =
263
if closed then raise Closed_channel;
264
if locked then failwith "Nethttpd_reactor: channel is locked";
265
let u = String.sub s spos slen in
266
resp # send (`Resp_body(u, 0, String.length u));
267
( match config#config_reactor_synch with
276
if closed then raise Closed_channel;
277
if locked then failwith "Nethttpd_reactor: channel is locked";
278
match config#config_reactor_synch with
286
if closed then raise Closed_channel;
287
if locked then failwith "Nethttpd_reactor: channel is locked";
289
resp # send `Resp_end;
290
match config#config_reactor_synch with
298
method close_after_send_file() =
300
match config#config_reactor_synch with
314
class http_reactive_request_impl config env inch outch resp expect_100_continue
316
: http_reactive_request =
319
(env : internal_environment :> extended_environment)
321
method accept_body() =
322
if expect_100_continue then
323
resp # send resp_100_continue;
324
(* We need not to synch here! The attempt to read the body will synchronize
326
* We should keep in mind, however, that when the existing body isn't read
327
* the "100 Continue" might be transmitted very late. This is no disadvantage,
334
method reject_body() =
339
val mutable fin_req = false
341
method finish_request() =
342
if not fin_req then ( (* Do this only once *)
347
finish_request(); (* Read the rest of the request until `Req_end *)
351
self # finish_request();
352
match env # output_state with
354
(* The whole response is missing! Generate a "Server Error": *)
355
output_std_response config env `Internal_server_error None
356
(Some "Nethttpd: Missing response, replying 'Server Error'");
357
env # set_output_state `End;
360
(* The response body is probably incomplete or missing. Try to close
363
( try env # output_ch # close_out() with Closed_channel -> () );
364
env # set_output_state `End;
367
(* Everything ok, just to be sure... *)
368
( try env # output_ch # close_out() with Closed_channel -> () );
369
env # set_output_state `End;
371
(* These states must not happen! *)
378
class http_reactor (config : #http_reactor_config) fd =
380
val proto = new http_protocol config fd
381
val fd_addr = Unix.getsockname fd
382
val peer_addr = Unix.getpeername fd
384
method private cycle() =
386
if proto # waiting_for_next_message then
387
config#config_timeout_next_request
389
config#config_timeout in
390
proto # cycle ~block ();
392
method private next_token() =
393
if proto # recv_queue_len = 0 then (
400
method private peek_token() =
401
if proto # recv_queue_len = 0 then (
408
method private finish_request() =
409
(* Read the rest of the previous request, ignoring it *)
410
match self # peek_token() with
414
| `Bad_request_error _
416
(* Everything ok, do nothing *)
419
(* Just drop this token, the next token starts the new request *)
420
ignore(proto # receive ())
421
| `Req_expect_100_continue
424
(* Continue to read this request until its end *)
426
match self # peek_token () with
430
| `Bad_request_error _
432
false (* Do not read further *)
434
ignore(self # next_token());
441
method private synch() =
442
(* Ensure that all written data are actually transmitted: *)
443
while proto # do_output do
446
(* CHECK: Maybe we have to throw away the remaining tokens of the current request! *)
449
method next_request () =
450
let tok = self # next_token() in
452
| `Req_header (req, req_hdr, resp) ->
453
(* Ok, we have a new request. Initialize the new environment processing
456
let expect_100_continue =
458
proto # peek_recv() = `Req_expect_100_continue
460
Recv_queue_empty -> false in
461
if expect_100_continue then
462
ignore(proto # receive());
464
let ((req_meth, req_uri), req_version) = req in
466
let input_ch = new http_reactor_input self#next_token in
467
let output_ch = new http_reactor_output config resp self#synch in
468
let lifted_input_ch =
469
lift_in ~buffered:false (`Rec (input_ch :> rec_in_channel)) in
470
let lifted_output_ch =
471
lift_out (`Rec (output_ch :> rec_out_channel)) in
472
(* The input channel needs no additional buffer here. The httpd kernel
473
* already implements a good buffer.
475
* The output channel profits from a buffer. The effect is that the
476
* kernel is driven with output chunks of uniform size. Furthermore,
477
* `Write synchronization is only performed after every of these chunks,
478
* and not after every output method invocation.
482
let env = new http_environment
484
req_meth req_uri req_version req_hdr
486
lifted_input_ch lifted_output_ch resp
487
output_ch#close_after_send_file
489
let req_obj = new http_reactive_request_impl
490
config env input_ch output_ch resp expect_100_continue
495
Standard_response(status, hdr_opt, msg_opt) ->
496
(* Probably a problem when decoding a header field! *)
499
config # config_log_error
500
(Some fd_addr) (Some peer_addr) (Some(req_meth,req_uri))
504
(* CHECK: Also log to access log? *)
505
let code = int_of_http_status status in
506
let body = config # config_error_response code in
507
Nethttpd_kernel.send_static_response resp status hdr_opt body;
509
self # finish_request();
510
self # next_request()
518
(* The connection is already down. Just log the incident: *)
519
let msg = Nethttpd_kernel.string_of_fatal_error e in
520
config # config_log_error
521
(Some fd_addr) (Some peer_addr) None None msg;
524
| `Bad_request_error (e, resp) ->
525
(* Log the incident, and reply with a 400 response: *)
526
let msg = string_of_bad_request_error e in
527
let status = status_of_bad_request_error e in
528
config # config_log_error
529
(Some fd_addr) (Some peer_addr) None None msg;
530
let body = config # config_error_response (int_of_http_status status) in
531
Nethttpd_kernel.send_static_response resp status None body;
532
self # next_request()
535
(* Just ignore. The next token will be `Eof *)
536
self # next_request()
539
(* Everything else means that we lost synchronization, and this is a
542
config # config_log_error
543
(Some fd_addr) (Some peer_addr) None None
544
"Nethttpd: Reactor out of synchronization";
545
proto # abort `Server_error;
546
self # next_request()
552
| err -> Unix.close fd; raise err
554
if proto # need_linger then (
555
let lc = new Nethttpd_kernel.lingering_close fd in
556
while lc # lingering do
557
lc # cycle ~block:true ()
566
exception Redirect_response_legal of string * http_header
569
[ http_service_reaction
570
| `Redirect_request of string * http_header
574
let process_connection config fd (stage1 : 'a http_service) =
576
let _fd_addr = Unix.getsockname fd in
577
let _peer_addr = Unix.getpeername fd in
579
let protect env f arg =
583
| Redirect_response_legal(_,_) as e -> raise e
585
| Standard_response(status, hdr_opt, errmsg_opt) when env#output_state = `Start ->
586
output_std_response config env status hdr_opt errmsg_opt;
588
| err when env#output_state = `Start ->
589
output_std_response config env `Internal_server_error None
590
(Some("Nethttpd: Uncaught exception: " ^ Printexc.to_string err));
593
let do_stage3 env stage3 =
595
stage3 # generate_response env
597
| Redirect_request(_,_) ->
598
failwith "Caught Redirect_request in stage 3, but it is only allowed in stage 1"
599
| Redirect_response(uri,hdr) ->
600
if env#output_state <> `Start then
601
failwith "Caught Redirect_response, but it is too late for redirections";
602
raise (Redirect_response_legal(uri,hdr))
605
let do_stage2 req env stage2 =
608
stage2 # process_body env
610
| Redirect_request(_,_) ->
611
failwith "Caught Redirect_request in stage 2, but it is only allowed in stage 1"
612
| Redirect_response(_,_) ->
613
failwith "Caught Redirect_response in stage 2, but it is only allowed in stage 3"
615
req # finish_request();
619
let rec process_request req redir_env redir_count =
620
(* [redir_env]: The environment of the request, possibly rewritten by redirects.
621
* [redir_count]: The number of already performed redirections
622
* [req]: Contains always the original environment
624
if redir_count > 10 then
625
failwith "Too many redirections";
627
try (stage1 # process_header redir_env :> x_reaction)
629
| Redirect_request(new_uri, new_hdr) ->
630
`Redirect_request(new_uri, new_hdr)
631
| Redirect_response(_,_) ->
632
failwith "Caught Redirect_response in stage 1, but it is only allowed in stage 3"
635
( match reaction with
636
| `Accept_body stage2 ->
638
protect redir_env (do_stage2 req redir_env) stage2
639
| `Reject_body stage3 ->
641
protect redir_env (do_stage3 redir_env) stage3
642
| `Static(status, resp_hdr_opt, resp_str) ->
644
output_static_response redir_env status resp_hdr_opt resp_str
645
| `File(status, resp_hdr_opt, resp_filename, pos, length) ->
649
(output_file_response redir_env status resp_hdr_opt resp_filename pos)
651
| `Std_response(status, resp_hdr_opt, errlog_opt) ->
653
output_std_response config redir_env status resp_hdr_opt errlog_opt
654
| `Redirect_request(new_uri, new_hdr) ->
655
let (new_script_name, new_query_string) = decode_query new_uri in
656
new_hdr # update_multiple_field
657
"Content-length" (redir_env # multiple_input_header_field "Content-length");
660
[ "REQUEST_URI", new_uri;
661
"SCRIPT_NAME", new_script_name;
662
"QUERY_STRING", new_query_string ]
663
redir_env#cgi_properties in
665
new redirected_environment
666
~properties:new_properties
668
~in_channel:(redir_env # input_ch) redir_env in
669
process_request req new_env (redir_count+1)
672
| Redirect_response_legal(new_uri, new_hdr) ->
673
if redir_env # output_state <> `Start then
674
failwith "Redirect_response is not allowed after output has started";
675
let (new_script_name, new_query_string) = decode_query new_uri in
676
new_hdr # update_field "Content-length" "0";
679
[ "REQUEST_URI", new_uri;
680
"SCRIPT_NAME", new_script_name;
681
"QUERY_STRING", new_query_string;
682
"REQUEST_METHOD", "GET"
684
redir_env#cgi_properties in
686
new redirected_environment
687
~properties:new_properties
690
process_request req new_env (redir_count+1)
696
let rec fetch_requests reactor =
697
match reactor # next_request() with
701
process_request req req#environment 0;
702
fetch_requests reactor
707
new http_reactor config fd
710
(* An exception means here that getsockname or getpeername failed.
711
We can only close the descriptor!
717
fetch_requests reactor
720
config # config_log_error None None None None
721
("Nethttpd: Uncaught exception: " ^ Printexc.to_string err);
727
config # config_log_error None None None None
728
("Nethttpd: Uncaught exception: " ^ Printexc.to_string err);
added
removed
src/nethttpd-for-netcgi1/nethttpd_reactor.ml
