1
(* $Id: netcgi_env.ml 1062 2006-12-17 20:17:36Z gerd $
2
* ----------------------------------------------------------------------
10
[ `Standard (* | `Direct *) ] ;;
13
`Receiving_header | `Received_header |
14
`Receiving_body | `Received_body
17
[ `Standard (* | `Direct *) ] ;;
20
`Sending_header | `Sent_header |
21
`Sending_body | `Sent_body |
22
`Sending_part_header | `Sent_part_header |
23
`Sending_part_body | `Sent_part_body |
26
type protocol_version = Nethttp.protocol_version
27
type protocol_attribute = Nethttp.protocol_attribute
28
type protocol = Nethttp.protocol
31
[ `Work_around_MSIE_Content_type_bug
32
| `Work_around_backslash_bug
36
{ tmp_directory : string;
38
permitted_http_methods : string list;
39
permitted_input_content_types : string list;
40
input_content_length_limit : int;
41
workarounds : workaround list;
44
class type cgi_environment =
46
method config : cgi_config
48
method cgi_gateway_interface : string
49
method cgi_server_software : string
50
method cgi_server_name : string
51
method cgi_server_protocol : string
52
method cgi_server_port : int option
53
method cgi_request_method : string
54
method cgi_path_info : string
55
method cgi_path_translated : string
56
method cgi_script_name : string
57
method cgi_query_string : string
58
method cgi_remote_host : string
59
method cgi_remote_addr : string
60
method cgi_auth_type : string
61
method cgi_remote_user : string
62
method cgi_remote_ident : string
64
method cgi_property : ?default:string -> string -> string
65
method cgi_properties : (string * string) list
66
method cgi_https : bool
67
method cgi_request_uri : string
69
method protocol : protocol
71
method input_header : Netmime.mime_header
72
method input_header_field : ?default:string -> string -> string
73
method multiple_input_header_field : string -> string list
74
method input_header_fields : (string * string) list
76
method user_agent : string
77
method cookies : (string * string) list
79
method input_ch : in_obj_channel
81
method input_content_length : int
83
method input_content_type_string : string
84
method input_content_type : (string * (string * Mimestring.s_param) list)
86
method input_state : input_state
87
method set_input_state : input_state -> unit
89
method output_ch : out_obj_channel
91
method output_header : Netmime.mime_header
92
method output_header_field : ?default:string -> string -> string
93
method multiple_output_header_field : string -> string list
94
method output_header_fields : (string * string) list
95
method set_status : http_status -> unit
97
method set_output_header_field : string -> string -> unit
98
method set_multiple_output_header_field : string -> string list -> unit
99
method set_output_header_fields : (string * string) list -> unit
100
method send_output_header : unit -> unit
102
method output_state : output_state
103
method set_output_state : output_state -> unit
105
method log_error : string -> unit
109
exception Std_environment_not_found ;;
111
let default_tmp_directory() =
113
match Sys.os_type with
114
"Unix" | "Cygwin" -> [ "/var/tmp"; "/tmp"; "." ]
115
| "Win32" -> [ "C:\\TEMP"; "." ]
116
| "MacOS" -> [ Filename.current_dir_name ]
119
List.find Sys.file_exists candidates
124
{ tmp_directory = default_tmp_directory();
125
tmp_prefix = "netcgi";
126
permitted_http_methods = [ "POST"; "GET"; "HEAD" ];
127
permitted_input_content_types = [ "multipart/form-data";
128
"application/x-www-form-urlencoded" ];
129
input_content_length_limit = max_int;
130
workarounds = [ `Work_around_MSIE_Content_type_bug;
131
`Work_around_backslash_bug
136
let minus_re = Pcre.regexp "-";;
138
let server_name_with_port_re = Pcre.regexp "^([^:]+):([0-9]+)$";;
141
class base_environment ?(config = default_config) () =
144
val mutable in_ch = new input_channel stdin
145
val mutable out_ch = new output_null ()
146
val mutable in_state = (`Start : input_state)
147
val mutable out_state = (`Start : output_state)
148
val mutable property = ([] : (string * string) list)
149
val mutable in_header = new Netmime.basic_mime_header []
150
val mutable out_header = new Netmime.basic_mime_header []
153
out_ch <- new output_channel
154
(* ~onclose:(fun() -> out_state <- `End) *)
157
(* Note: The onclose handler is commented out because it is difficult
158
* to add the same functionality for the jserv stuff.
162
method private fixup_server_name() =
163
(* Fixup SERVER_NAME/SERVER_PORT: *)
164
( let server_name = List.assoc "SERVER_NAME" property in
165
match Netstring_pcre.string_match server_name_with_port_re server_name 0
168
let new_server_name =
169
Netstring_pcre.matched_group m 1 server_name in
170
let new_server_port =
171
Netstring_pcre.matched_group m 2 server_name in
174
("SERVER_NAME", new_server_name) ::
175
(List.filter (fun (n,_) -> n <> "SERVER_NAME") property);
177
let cur_server_port =
178
try List.assoc "SERVER_PORT" property with Not_found -> "" in
180
if cur_server_port = "" then (
182
("SERVER_PORT", new_server_port) ::
183
(List.filter (fun (n,_) -> n <> "SERVER_PORT") property);
190
(* This class works already, but lacks a complete initializer! *)
194
method cgi_gateway_interface = self # cgi_property ~default:""
196
method cgi_server_software = self # cgi_property ~default:""
198
method cgi_server_name = self # cgi_property ~default:""
200
method cgi_server_protocol = self # cgi_property ~default:""
202
method cgi_request_method = self # cgi_property ~default:""
204
method cgi_path_info = self # cgi_property ~default:""
206
method cgi_path_translated = self # cgi_property ~default:""
208
method cgi_script_name = self # cgi_property ~default:""
210
method cgi_query_string = self # cgi_property ~default:""
212
method cgi_remote_host = self # cgi_property ~default:""
214
method cgi_remote_addr = self # cgi_property ~default:""
216
method cgi_auth_type = self # cgi_property ~default:""
218
method cgi_remote_user = self # cgi_property ~default:""
220
method cgi_remote_ident = self # cgi_property ~default:""
222
method cgi_server_port =
223
try Some(int_of_string(self # cgi_property "SERVER_PORT"))
224
with Not_found -> None
226
method cgi_property ?default name =
228
None -> List.assoc name property
229
| Some d -> try List.assoc name property with Not_found -> d
231
method cgi_properties = property
234
match String.lowercase(self # cgi_property ~default:"" "HTTPS") with
238
| _ -> failwith "Cannot interpret HTTPS property"
240
method cgi_request_uri =
241
self # cgi_property ~default:"" "REQUEST_URI"
242
(* Apache has this usually *)
244
method protocol : protocol =
246
let groups = Pcre.extract ~rex:(Pcre.regexp "^([^/]+)/(\\d+)\\.(\\d+)$")
247
(self # cgi_server_protocol) in
248
if groups.(1) = "HTTP" then
250
if self # cgi_https then [ `Secure_https ] else [] in
251
`Http ((int_of_string groups.(2), int_of_string groups.(3)), atts)
257
method input_header =
260
method input_header_field ?default name =
261
try in_header # field name
262
with Not_found as nf ->
267
method multiple_input_header_field name =
268
in_header # multiple_field name
270
method input_header_fields =
274
self # input_header_field ~default:"" "USER-AGENT"
277
Nethttp.Header.get_cookie self#input_header
279
method input_ch = in_ch
281
method input_content_length =
282
int_of_string (self # input_header_field "CONTENT-LENGTH")
284
method input_content_type_string =
285
self # input_header_field ~default:"" "CONTENT-TYPE"
287
method input_content_type =
288
Mimestring.scan_mime_type_ep (self # input_header_field "CONTENT-TYPE") []
290
method input_state = in_state
291
method set_input_state s = in_state <- s
293
method output_header =
296
method output_header_field ?default name =
297
try out_header # field name
298
with Not_found as nf ->
303
method multiple_output_header_field name =
304
out_header # multiple_field name
306
method output_header_fields =
312
method set_output_header_field name value =
313
out_header # update_field name value
315
method set_multiple_output_header_field name values =
316
out_header # update_multiple_field name values
318
method set_output_header_fields h =
319
out_header # set_fields h
321
method set_status st =
322
out_header # update_field "Status" (string_of_int (int_of_http_status st))
324
method send_output_header () =
325
if out_state <> `Start then
326
failwith "send_output_header";
327
out_state <- `Sending_header;
328
(* Note: ~soft_eol:"" because linear whitespace is illegal in CGI
331
Mimestring.write_header ~soft_eol:"" ~eol:"\r\n" out_ch out_header#fields;
332
out_state <- `Sent_header;
334
method output_state = out_state
335
method set_output_state s =
338
( try out_ch # close_out() with Closed_channel -> () )
342
(* This usually works for command-line and CGI *)
347
exception Std_environment_not_found ;;
349
let equation_re = Pcre.regexp "^([^=]*)=(.*)$" ;;
350
let http_re = Pcre.regexp "^HTTP_(.*)" ;;
351
let uscore_re = Pcre.regexp "_" ;;
353
class std_environment ?config () =
355
inherit base_environment ?config ()
358
(* Check whether the environment is CGI: *)
360
ignore(Sys.getenv "SERVER_SOFTWARE");
361
ignore(Sys.getenv "SERVER_NAME");
362
ignore(Sys.getenv "GATEWAY_INTERFACE");
365
Not_found -> raise Std_environment_not_found
367
(* Do we need to normalize CONTENT-TYPE? *)
368
let user_agent = try Sys.getenv "HTTP_USER_AGENT" with Not_found -> "" in
369
let norm_content_type s =
370
if Pcre.pmatch ~pat:"MSIE" user_agent &&
371
List.mem `Work_around_MSIE_Content_type_bug cfg.workarounds
373
(* Microsoft Internet Explorer: When used with SSL connections,
374
* this browser sometimes produces CONTENT_TYPEs like
375
* "multipart/form-data; boundary=..., multipart/form-data; boundary=..."
376
* Workaround: Throw away everything after ", ".
380
Pcre.extract ~rex:(Pcre.regexp "([^,]*boundary[^,]*), .*boundary")
389
(* Read the environment and initialize [property] and [in_header]: *)
395
match Pcre.extract ~rex:equation_re s with
396
| [|_; name; value|] -> (name, value)
397
| _ -> assert false in
398
(* or raise Not_found *)
401
(* Add to in_header, not property: *)
402
ih := ("CONTENT-TYPE", norm_content_type value) :: !ih
403
| "CONTENT_LENGTH" ->
404
(* Add to in_header, not property: *)
405
ih := ("CONTENT-LENGTH", value) :: !ih
409
match Pcre.extract ~rex:http_re name with
410
| [|_; hname|] -> hname
411
| _ -> assert false in
412
(* or raise Not_found *)
413
(* No Not_found: The variable begins with HTTP_ and
416
let hname' = Pcre.qreplace ~rex:uscore_re ~templ:"-" hname in
417
let hname'' = String.uppercase hname' in
418
ih := (hname'',value) :: !ih
421
(* The variable is a property *)
422
property <- (name, value) :: property;
425
(* The variable is malformed. Ignore it. *)
428
(Unix.environment());
429
(* Maybe the order of fields counts, so repair the order: *)
430
in_header <- new Netmime.basic_mime_header ~ro:true (List.rev !ih);
431
property <- List.rev property;
432
self # fixup_server_name();
433
(* Update the input state: *)
434
in_state <- `Received_header;
439
(* Is stdin connected to a tty? *)
440
match Sys.os_type with
443
( try ignore(Unix.tcgetattr Unix.stdin); true
444
with Unix.Unix_error(Unix.ENOTTY,_,_) -> false
448
(* Don't know how to do this. So assume it's a tty anyway. *)
454
exception No_equation of string
456
let split_name_is_value s =
457
(* Recognizes a string "name=value" and returns the pair (name,value).
458
* If the string has the wrong format, the function will raise
459
* No_equation, and the argument of the exception is the unparseable
463
let p = String.index s '=' in
464
(String.sub s 0 p, String.sub s (p+1) (String.length s - p - 1))
469
class test_environment ?config () =
471
inherit base_environment ?config ()
473
method private init_from_cmd_line () =
474
let usage = ref (fun () -> ()) in
475
let mimetype = ref "text/plain" in
476
let filename = ref None in
478
let fileargs = ref [] in
479
let putarg = ref "" in
480
let cgi_method = ref "GET" in
482
let props = ref [] in
483
let header = ref [] in
487
Arg.Unit (fun _ -> cgi_method := "GET"),
488
" Set the method to GET (the default)";
490
Arg.Unit (fun _ -> cgi_method := "HEAD"),
491
" Set the method to HEAD";
493
Arg.Unit (fun _ -> cgi_method := "POST"),
494
" Set the method to POST enctype multipart/form-data";
496
Arg.String (fun s -> cgi_method := "PUT"; putarg := s),
497
"file Set the method to PUT and read this file";
499
Arg.Unit (fun _ -> cgi_method := "DELETE"),
500
" Set the method to DELETE";
502
Arg.String (fun s -> mimetype := s),
503
"type Set the MIME type for the next file argument(s) (default: text/plain)";
505
Arg.String (fun s -> if s = "" then filename := None
506
else filename := Some s),
507
"path Set the filename property for the next file argument(s)";
511
let (name,file) = split_name_is_value s in
512
fileargs := !fileargs @ [name, (!mimetype,!filename,file)];
514
"name=file Specify a file argument whose contents are in the file";
516
Arg.String (fun s -> user := s),
517
"name Set REMOTE_USER to this name";
519
Arg.String (fun s -> props := !props @ [split_name_is_value s]),
520
"name=value Set the environment property";
522
Arg.String (fun s -> header := !header @ [split_name_is_value s]),
523
"name=value Set the request header field";
525
Arg.Unit (fun () -> !usage()),
529
let usage_string = "This program expects a CGI environment. You can simulate such an environment\n\
530
by name=value command-line arguments. Furthermore, the following options\n\
532
usage := (fun () -> Arg.usage keywords usage_string; flush stderr; exit 0);
538
let (name,value) = split_name_is_value s in
539
args := !args @ [name, value];
544
failwith ("CGI command-line parameter: Cannot parse: " ^ s)
547
let qs_methods = ["GET";"HEAD";"PUT";"DELETE"] in
548
(* methods requiring QUERY_STRING *)
550
let mk_query_string() =
551
if !fileargs <> [] then
552
prerr_endline "Warning: Ignoring -filearg arguments (would need -post)";
553
Netencoding.Url.mk_url_encoded_parameters !args
556
let ch, ch_len, ch_type =
557
match !cgi_method with
562
(new input_string "", 0, "")
564
(* Input is the specified file *)
565
let f = open_in_bin !putarg in
566
(new input_channel f, in_channel_length f, "application/octet-stream")
568
(* For simplicity, use a pipe to keep the generated POST data: *)
569
let post_ch = new pipe() in
570
(* Use Netmime to create the POSTed MIME message: *)
574
let cdisp = Buffer.create 80 in
575
let cdisp_ch = new output_buffer cdisp in
576
cdisp_ch # output_string "form-data";
577
Mimestring.write_value cdisp_ch
578
(Mimestring.param_tokens
579
[ "name", Mimestring.mk_param n ]);
580
let hdr = new Netmime.basic_mime_header
581
[ "content-disposition", Buffer.contents cdisp ] in
582
let body = new Netmime.memory_mime_body v in
588
(fun (n,(mt,fn,fl)) ->
589
let cdisp = Buffer.create 80 in
590
let cdisp_ch = new output_buffer cdisp in
591
cdisp_ch # output_string "form-data";
592
Mimestring.write_value cdisp_ch
593
(Mimestring.param_tokens
594
( ("name", Mimestring.mk_param n) ::
597
| Some x -> ["filename", Mimestring.mk_param x];
599
let hdr = new Netmime.basic_mime_header
600
[ "content-disposition", Buffer.contents cdisp;
603
let body = new Netmime.file_mime_body fl in
608
( new Netmime.basic_mime_header
609
[ "Content-type", "multipart/form-data"],
610
`Parts (simple_msgs @ file_msgs)
613
(* Write the MIME message to the pipe: *)
614
let post_boundary = ref "" in
615
Netmime.write_mime_message
616
~wr_header:false ~ret_boundary:post_boundary
617
(post_ch :> out_obj_channel)
619
(* Close the pipe, so we can read from it and detect EOF: *)
620
let post_length = post_ch # pos_out in
621
post_ch # close_out();
623
"multipart/form-data;boundary=\"" ^ !post_boundary ^ "\"" in
624
(* Pass everything back: *)
625
((post_ch :> in_obj_channel), post_length, post_type)
632
property <- [ "GATEWAY_INTERFACE", "CGI/1.1";
633
"SERVER_SOFTWARE", "Netcgi_env/test_environment";
634
"SERVER_NAME", "localhost";
635
"SERVER_PROTOCOL", "HTTP/1.0";
636
"REQUEST_METHOD", !cgi_method;
637
"SCRIPT_NAME", "/[SCRIPTNAME]";
638
"QUERY_STRING", if List.mem !cgi_method qs_methods
639
then mk_query_string()
641
"REMOTE_HOST", "localhost";
642
"REMOTE_ADDR", "127.0.0.1";
645
[ "REMOTE_USER", !user;
646
"AUTH_TYPE", "basic";
652
let ih = ref [ "CONTENT-LENGTH", string_of_int ch_len;
653
"CONTENT-TYPE", ch_type;
654
"USER-AGENT", "Netcgi_env/test_environment";
659
property <- (n, v) :: List.remove_assoc n property)
664
ih := (n, v) :: List.remove_assoc n !ih)
667
in_header <- new Netmime.basic_mime_header ~ro:true !ih;
669
in_state <- `Received_header
672
method private init_interactively() =
673
prerr_endline "This is a CGI program. You can now input arguments, every argument on a new";
674
prerr_endline "line in the format name=value. The request method is fixed to GET, and cannot";
675
prerr_endline "be changed in this mode. Consider using the command-line for more options.";
676
let continue = ref true in
682
let line = read_line () in
685
let n,v = split_name_is_value line in
686
args := !args @ [n, v];
689
prerr_string "Error. Do you want to enter more arguments? (y/n) ";
691
let answer = read_line () in
692
continue := (answer = "y") || (answer = "Y") ||
693
(answer = "yes") || (answer = "YES")
699
prerr_endline "(Got EOF)";
701
prerr_endline "(Continuing the program)";
704
in_ch <- new input_string "";
706
property <- [ "GATEWAY_INTERFACE", "CGI/1.1";
707
"SERVER_SOFTWARE", "Netcgi_env/test_environment";
708
"SERVER_NAME", "localhost";
709
"SERVER_PROTOCOL", "HTTP/1.0";
710
"REQUEST_METHOD", "GET";
711
"SCRIPT_NAME", "/[SCRIPTNAME]";
712
"QUERY_STRING", Netencoding.Url.mk_url_encoded_parameters !args;
713
"REMOTE_HOST", "localhost";
714
"REMOTE_ADDR", "127.0.0.1";
717
in_header <- new Netmime.basic_mime_header ~ro:true
718
[ "CONTENT-LENGTH", "0";
719
"USER-AGENT", "Netcgi_env/test_environment";
722
in_state <- `Received_header;
725
let have_command_line_options = !Arg.current+1 < Array.length Sys.argv in
726
if have_command_line_options then
727
self # init_from_cmd_line()
730
self # init_interactively()
732
failwith "test_environment: Neither command line options nor tty to ask user"
736
class custom_environment ?config () =
738
inherit base_environment ?config ()
740
val mutable setup_phase = true
741
val mutable error_log = prerr_endline
744
method set_input_ch ch =
745
if not setup_phase then failwith "custom_environment: setup already over";
748
method set_output_ch ch =
749
if not setup_phase then failwith "custom_environment: setup already over";
752
method set_input_content_length n =
753
self # set_input_header_field "CONTENT-LENGTH" (string_of_int n)
755
method set_input_content_type t =
756
self # set_input_header_field "CONTENT-TYPE" t
758
method set_input_header_field name value =
759
in_header # update_field name value
761
method set_multiple_input_header_field name values =
762
in_header # update_multiple_field name values
764
method set_input_header_fields h =
765
in_header # set_fields h
767
method set_error_log f =
789
let set name value_opt =
793
property <- (name,v) :: (List.remove_assoc name property)
796
if not setup_phase then failwith "custom_environment: setup already over";
798
set "GATEWAY_INTERFACE" gateway_interface;
799
set "SERVER_SOFTWARE" server_software;
800
set "SERVER_NAME" server_name;
801
set "SERVER_PROTOCOL" server_protocol;
803
(match server_port with
805
| Some None -> Some ""
806
| Some (Some n) -> Some (string_of_int n));
807
set "REQUEST_METHOD" request_method;
808
set "PATH_INFO" path_info;
809
set "PATH_TRANSLATED" path_translated;
810
set "SCRIPT_NAME" script_name;
811
set "QUERY_STRING" query_string;
812
set "REMOTE_HOST" remote_host;
813
set "REMOTE_ADDR" remote_addr;
814
set "AUTH_TYPE" auth_type;
815
set "REMOTE_USER" remote_user;
816
set "REMOTE_IDENT" remote_ident;
820
| Some false -> Some "off"
821
| Some true -> Some "on");
825
| Some (n,v) -> set n (Some v)
828
self # fixup_server_name();
830
method setup_finished() =
831
setup_phase <- false;
832
in_header <- new Netmime.basic_mime_header ~ro:true in_header#fields
added
removed
src/netcgi1/netcgi_env.ml
