2 * ----------------------------------------------------------------------
6 exception Resources_exceeded
8 type argument_processing = Memory | File | Automatic;;
11 { mutable arg_name : string;
12 mutable arg_processing : argument_processing;
13 mutable arg_buf_value : Buffer.t;
14 mutable arg_mem_value : string option;
15 (* Here, the value is stored if it must be kept in memory *)
16 mutable arg_disk_value : string Weak.t;
17 (* This component is used iff arg_mem_value = None. The
18 * weak array has a length of 1, and the single element stores
21 mutable arg_file : string option;
22 (* The filename of the temporary file storing the value *)
23 mutable arg_fd : out_channel option;
24 (* The file descriptor of the temp file (if open) *)
25 mutable arg_mimetype : string;
26 mutable arg_filename : string option;
27 mutable arg_header : (string * string) list;
28 (* For the last three components, see the description of the
29 * corresponding functions in the mli file.
35 Work_around_MSIE_Content_type_bug
36 | Work_around_backslash_bug
40 { maximum_content_length : int;
41 how_to_process_arguments : argument -> argument_processing;
42 tmp_directory : string;
44 workarounds : workaround list;
49 let print_argument arg =
51 "<CGIARG name=%s filename=%s mimetype=%s store=%s>"
53 (match arg.arg_filename with None -> "*" | Some n -> n)
55 (match arg.arg_file with None -> "Memory" | Some n -> n)
59 let encode = Netencoding.Url.encode ;;
60 let decode = Netencoding.Url.decode ;;
68 let mk_url_encoded_parameters nv_pairs =
72 let name_encoded = Netencoding.Url.encode name in
73 let value_encoded = Netencoding.Url.encode value in
74 name_encoded ^ "=" ^ value_encoded
81 let dest_url_encoded_parameters parstr =
83 let rec parse_after_amp tl =
85 Str.Text name :: Str.Delim "=" :: Str.Text value :: tl' ->
86 (Netencoding.Url.decode name,
87 Netencoding.Url.decode value) :: parse_next tl'
88 | Str.Text name :: Str.Delim "=" :: Str.Delim "&" :: tl' ->
89 (Netencoding.Url.decode name, "") :: parse_after_amp tl'
90 | Str.Text name :: Str.Delim "=" :: [] ->
91 [Netencoding.Url.decode name, ""]
93 failwith "Cgi.dest_url_encoded_parameters"
97 | Str.Delim "&" :: tl' ->
100 failwith "Cgi.dest_url_encoded_parameters"
102 let toklist = Str.full_split url_split_re parstr in
105 | _ -> parse_after_amp toklist
109 let mk_form_encoded_parameters ntv_triples =
110 failwith "Cgi.mk_form_encoded_parameters: not implemented";;
113 let dest_parameter_header header options =
115 (* s is: form-data; ... name="fieldname" ...
116 * Extract "fieldname"
119 let tok, params = Mimestring.scan_value_with_parameters s options in
120 List.assoc "name" params
123 failwith "Cgi.dest_form_encoded_parameters"
124 | Failure "Mimestring.scan_value_with_parameters" ->
125 failwith "Cgi.dest_form_encoded_parameters"
129 (* s is: form-data; ... filename="fieldname" ...
130 * Extract "fieldname"
133 let tok, params = Mimestring.scan_value_with_parameters s options in
134 Some(List.assoc "filename" params)
138 | Failure "Mimestring.scan_value_with_parameters" ->
139 failwith "Cgi.dest_form_encoded_parameters"
143 try List.assoc "content-type" header
144 with Not_found -> "text/plain" in (* the default *)
146 let content_disposition =
147 try List.assoc "content-disposition" header
150 failwith "Cgi.dest_form_encoded_parameters: no content-disposition"
153 let name = get_name content_disposition in
154 let filename = get_filename content_disposition in
156 name, mime_type, filename
160 let dest_form_encoded_parameters parstr ~boundary config =
162 if List.mem Work_around_backslash_bug config.workarounds then
163 [ Mimestring.No_backslash_escaping ]
168 Mimestring.scan_multipart_body_and_decode
169 parstr 0 (String.length parstr) boundary in
171 (fun (params, value) ->
173 let name, mime_type, filename = dest_parameter_header params options in
175 arg_processing = Memory;
176 arg_buf_value = Buffer.create 1;
177 arg_mem_value = Some value;
178 arg_disk_value = Weak.create 1;
181 arg_mimetype = mime_type;
182 arg_filename = filename;
191 let make_temporary_file config =
192 (* Returns (filename, out_channel). *)
193 let rec try_creation n =
198 (config.tmp_prefix ^ "-" ^ (string_of_int n))
202 [ Open_wronly; Open_creat; Open_excl; Open_binary ]
209 (* This does not look very intelligent, but it is the only chance
210 * to limit the number of trials.
213 failwith ("Cgi: Cannot create temporary file: " ^ m);
220 let dest_form_encoded_parameters_from_netstream s ~boundary config =
221 let parts = ref [] in
223 if List.mem Work_around_backslash_bug config.workarounds then
224 [ Mimestring.No_backslash_escaping ]
230 (* CALLBACK for scan_multipart_body_from_netstream *)
231 let name, mime_type, filename = dest_parameter_header header options in
234 arg_processing = Memory;
235 arg_buf_value = Buffer.create 80;
236 arg_mem_value = None;
237 arg_disk_value = Weak.create 1;
240 arg_mimetype = mime_type;
241 arg_filename = filename;
245 let pr = config.how_to_process_arguments p0 in
246 let p = { p0 with arg_processing = pr } in
247 if pr = File then begin
248 let fn, fd = make_temporary_file config in
249 p.arg_file <- Some fn;
251 p.arg_mem_value <- None;
257 (* CALLBACK for scan_multipart_body_from_netstream *)
258 if (p.arg_processing = Automatic) &&
259 (Buffer.length (p.arg_buf_value) >= Netstream.block_size s) then begin
260 (* This is a LARGE argument *)
261 p.arg_processing <- File;
262 let fn, fd = make_temporary_file config in
263 p.arg_file <- Some fn;
265 p.arg_mem_value <- None;
266 output_string fd (Buffer.contents p.arg_buf_value);
267 p.arg_buf_value <- Buffer.create 1;
270 match p.arg_processing with
271 (Memory|Automatic) ->
274 (Netbuffer.unsafe_buffer (Netstream.window s))
278 let fd = match p.arg_fd with Some fd -> fd | None -> assert false in
281 (Netbuffer.unsafe_buffer (Netstream.window s))
287 (* CALLBACK for scan_multipart_body_from_netstream *)
288 begin match p.arg_processing with
289 (Memory|Automatic) ->
290 p.arg_mem_value <- Some (Buffer.contents p.arg_buf_value);
291 p.arg_buf_value <- Buffer.create 1;
293 let fd = match p.arg_fd with Some fd -> fd | None -> assert false in
295 p.arg_mem_value <- None
300 Mimestring.scan_multipart_body_from_netstream
312 try Sys.getenv name with Not_found -> "";;
315 * We use this getenv instead of Sys.getenv. The CGI specification does not
316 * say anything about what should happen if a certain environment variable
318 * Some servers initialize the environment variable to the empty string if
319 * it is not applicable, some servers do not set the variable at all. Because
320 * of this, unset variables are always reported as empty variables.
322 * This is especially a problem with QUERY_STRING.
325 let mk_simple_arg ~name v =
327 arg_processing = Memory;
328 arg_buf_value = Buffer.create 1;
329 arg_mem_value = Some v;
330 arg_disk_value = Weak.create 0;
333 arg_mimetype = "text/plain";
339 let mk_memory_arg ~name ?(mime = "text/plain") ?filename ?(header = []) v =
341 arg_processing = Memory;
342 arg_buf_value = Buffer.create 1;
343 arg_mem_value = Some v;
344 arg_disk_value = Weak.create 0;
348 arg_filename = filename;
354 ~name ?(mime = "text/plain") ?filename ?(header = []) v_filename =
356 if Filename.is_relative v_filename then
357 Filename.concat (Sys.getcwd()) v_filename
362 arg_processing = File;
363 arg_buf_value = Buffer.create 1;
364 arg_mem_value = None;
365 arg_disk_value = Weak.create 0;
366 arg_file = Some v_abs_filename;
369 arg_filename = filename;
375 let get_content_type config =
376 (* Get the environment variable CONTENT_TYPE; if necessary apply
377 * workarounds for browser bugs.
379 let content_type = getenv "CONTENT_TYPE" in
380 let user_agent = getenv "HTTP_USER_AGENT" in
381 let eff_content_type =
382 if Str.string_match (Str.regexp ".*MSIE") user_agent 0 &&
383 List.mem Work_around_MSIE_Content_type_bug config.workarounds
385 (* Microsoft Internet Explorer: When used with SSL connections,
386 * this browser sometimes produces CONTENT_TYPEs like
387 * "multipart/form-data; boundary=..., multipart/form-data; boundary=..."
388 * Workaround: Throw away everything after ", ".
390 if Str.string_match (Str.regexp "\\([^,]*boundary[^,]*\\), .*boundary")
393 Str.matched_group 1 content_type
404 let really_parse_args config =
405 let make_simple_arg (n,v) = mk_simple_arg n v in
407 match getenv "REQUEST_METHOD" with
411 (dest_url_encoded_parameters(getenv "QUERY_STRING"))
416 int_of_string (getenv "CONTENT_LENGTH")
418 _ -> failwith "Cgi.parse_arguments"
420 if n > config.maximum_content_length then
421 raise Resources_exceeded;
423 let mime_type, params =
424 Mimestring.scan_mime_type(get_content_type config) [] in
426 "application/x-www-form-urlencoded" ->
427 let buf = String.create n in
428 really_input stdin buf 0 n;
431 (dest_url_encoded_parameters buf)
432 | "multipart/form-data" ->
435 List.assoc "boundary" params
438 failwith "Cgi.parse_arguments"
440 (* -------------------------------------------------- DEBUG
441 let f = open_out "/tmp/cgiout" in
444 * --------------------------------------------------
446 dest_form_encoded_parameters_from_netstream
447 (Netstream.create_from_channel stdin (Some n) 4096)
451 failwith ("Cgi.parse_arguments: unknown content-type " ^ mime_type)
454 failwith "Cgi.parse_arguments: unknown method"
456 let parsed = ref None;; (* protected by lock/unlock *)
458 let lock = ref (fun () -> ());;
459 let unlock = ref (fun () -> ());;
461 let init_mt new_lock new_unlock =
478 let parse_arguments config =
484 parsed := Some (List.map
485 (fun arg -> arg.arg_name, arg)
486 (really_parse_args config))
496 failwith "Cgi.arguments"
500 let set_arguments arglist =
503 parsed := Some (List.map
504 (fun arg -> arg.arg_name, arg)
510 { maximum_content_length = max_int;
511 how_to_process_arguments = (fun _ -> Memory);
512 tmp_directory = "/var/tmp";
514 workarounds = [ Work_around_MSIE_Content_type_bug;
515 Work_around_backslash_bug;
521 match arg.arg_mem_value with
524 match Weak.get arg.arg_disk_value 0 with
527 match arg.arg_file with
529 failwith "Cgi.arg_value: no value present"
531 let fd = open_in_bin filename in
533 let len = in_channel_length fd in
534 let s = String.create len in
535 really_input fd s 0 len;
536 Weak.set arg.arg_disk_value 0 (Some s);
540 any -> close_in fd; raise any
548 let arg_name arg = arg.arg_name;;
549 let arg_file arg = arg.arg_file;;
550 let arg_mimetype arg = arg.arg_mimetype;;
551 let arg_filename arg = arg.arg_filename;;
552 let arg_header arg = arg.arg_header;;
562 match arg.arg_file with
565 (* We do not complain if the file does not exist anymore. *)
566 if Sys.file_exists filename then
574 let argument name = List.assoc name (arguments());;
575 let argument_value name = arg_value (argument name);;
577 module Operators = struct
578 let ( !% ) = argument
579 let ( !$ ) = argument_value
584 parse_arguments default_config;
586 (fun (name, arg) -> name, arg_value arg)
590 let parse_args_with_mimetypes() =
591 parse_arguments default_config;
593 (fun (name, arg) -> name, arg_mimetype arg, arg_value arg)
603 print_string ("Content-type: " ^ t ^ "\n\n");
609 "http://" ^ (getenv "SERVER_NAME") ^ (getenv "SCRIPT_NAME")
613 (* ======================================================================
617 * Revision 1.1 2000/11/17 09:57:27 lpadovan
620 * Revision 1.8 2000/06/25 22:34:43 gerd
621 * Added labels to arguments.
623 * Revision 1.7 2000/06/25 21:40:36 gerd
626 * Revision 1.6 2000/06/25 21:15:48 gerd
627 * Checked thread-safety.
629 * Revision 1.5 2000/05/16 22:29:36 gerd
630 * Added support for two common file upload bugs.
632 * Revision 1.4 2000/04/15 16:47:27 gerd
633 * Last minor changes before releasing 0.6.
635 * Revision 1.3 2000/04/15 13:09:01 gerd
636 * Implemented uploads to temporary files.
638 * Revision 1.2 2000/03/02 01:15:30 gerd
641 * Revision 1.1 2000/02/25 15:21:12 gerd