--- /dev/null
+(* $Id$
+ * ----------------------------------------------------------------------
+ *
+ *)
+
+exception Resources_exceeded
+
+type argument_processing = Memory | File | Automatic;;
+
+type argument =
+ { mutable arg_name : string;
+ mutable arg_processing : argument_processing;
+ mutable arg_buf_value : Buffer.t;
+ mutable arg_mem_value : string option;
+ (* Here, the value is stored if it must be kept in memory *)
+ mutable arg_disk_value : string Weak.t;
+ (* This component is used iff arg_mem_value = None. The
+ * weak array has a length of 1, and the single element stores
+ * the value (if any).
+ *)
+ mutable arg_file : string option;
+ (* The filename of the temporary file storing the value *)
+ mutable arg_fd : out_channel option;
+ (* The file descriptor of the temp file (if open) *)
+ mutable arg_mimetype : string;
+ mutable arg_filename : string option;
+ mutable arg_header : (string * string) list;
+ (* For the last three components, see the description of the
+ * corresponding functions in the mli file.
+ *)
+ }
+;;
+
+type workaround =
+ Work_around_MSIE_Content_type_bug
+ | Work_around_backslash_bug
+;;
+
+type config =
+ { maximum_content_length : int;
+ how_to_process_arguments : argument -> argument_processing;
+ tmp_directory : string;
+ tmp_prefix : string;
+ workarounds : workaround list;
+ }
+;;
+
+
+let print_argument arg =
+ Format.printf
+ "<CGIARG name=%s filename=%s mimetype=%s store=%s>"
+ arg.arg_name
+ (match arg.arg_filename with None -> "*" | Some n -> n)
+ arg.arg_mimetype
+ (match arg.arg_file with None -> "Memory" | Some n -> n)
+;;
+
+
+let encode = Netencoding.Url.encode ;;
+let decode = Netencoding.Url.decode ;;
+
+
+
+let url_split_re =
+ Str.regexp "[&=]";;
+
+
+let mk_url_encoded_parameters nv_pairs =
+ String.concat "&"
+ (List.map
+ (fun (name,value) ->
+ let name_encoded = Netencoding.Url.encode name in
+ let value_encoded = Netencoding.Url.encode value in
+ name_encoded ^ "=" ^ value_encoded
+ )
+ nv_pairs
+ )
+;;
+
+
+let dest_url_encoded_parameters parstr =
+
+ let rec parse_after_amp tl =
+ match tl with
+ Str.Text name :: Str.Delim "=" :: Str.Text value :: tl' ->
+ (Netencoding.Url.decode name,
+ Netencoding.Url.decode value) :: parse_next tl'
+ | Str.Text name :: Str.Delim "=" :: Str.Delim "&" :: tl' ->
+ (Netencoding.Url.decode name, "") :: parse_after_amp tl'
+ | Str.Text name :: Str.Delim "=" :: [] ->
+ [Netencoding.Url.decode name, ""]
+ | _ ->
+ failwith "Cgi.dest_url_encoded_parameters"
+ and parse_next tl =
+ match tl with
+ [] -> []
+ | Str.Delim "&" :: tl' ->
+ parse_after_amp tl'
+ | _ ->
+ failwith "Cgi.dest_url_encoded_parameters"
+ in
+ let toklist = Str.full_split url_split_re parstr in
+ match toklist with
+ [] -> []
+ | _ -> parse_after_amp toklist
+;;
+
+
+let mk_form_encoded_parameters ntv_triples =
+ failwith "Cgi.mk_form_encoded_parameters: not implemented";;
+
+
+let dest_parameter_header header options =
+ let get_name s =
+ (* s is: form-data; ... name="fieldname" ...
+ * Extract "fieldname"
+ *)
+ try
+ let tok, params = Mimestring.scan_value_with_parameters s options in
+ List.assoc "name" params
+ with
+ Not_found ->
+ failwith "Cgi.dest_form_encoded_parameters"
+ | Failure "Mimestring.scan_value_with_parameters" ->
+ failwith "Cgi.dest_form_encoded_parameters"
+ in
+
+ let get_filename s =
+ (* s is: form-data; ... filename="fieldname" ...
+ * Extract "fieldname"
+ *)
+ try
+ let tok, params = Mimestring.scan_value_with_parameters s options in
+ Some(List.assoc "filename" params)
+ with
+ Not_found ->
+ None
+ | Failure "Mimestring.scan_value_with_parameters" ->
+ failwith "Cgi.dest_form_encoded_parameters"
+ in
+
+ let mime_type =
+ try List.assoc "content-type" header
+ with Not_found -> "text/plain" in (* the default *)
+
+ let content_disposition =
+ try List.assoc "content-disposition" header
+ with
+ Not_found ->
+ failwith "Cgi.dest_form_encoded_parameters: no content-disposition"
+ in
+
+ let name = get_name content_disposition in
+ let filename = get_filename content_disposition in
+
+ name, mime_type, filename
+;;
+
+
+let dest_form_encoded_parameters parstr ~boundary config =
+ let options =
+ if List.mem Work_around_backslash_bug config.workarounds then
+ [ Mimestring.No_backslash_escaping ]
+ else
+ []
+ in
+ let parts =
+ Mimestring.scan_multipart_body_and_decode
+ parstr 0 (String.length parstr) boundary in
+ List.map
+ (fun (params, value) ->
+
+ let name, mime_type, filename = dest_parameter_header params options in
+ { arg_name = name;
+ arg_processing = Memory;
+ arg_buf_value = Buffer.create 1;
+ arg_mem_value = Some value;
+ arg_disk_value = Weak.create 1;
+ arg_file = None;
+ arg_fd = None;
+ arg_mimetype = mime_type;
+ arg_filename = filename;
+ arg_header = params;
+ }
+
+ )
+ parts
+;;
+
+
+let make_temporary_file config =
+ (* Returns (filename, out_channel). *)
+ let rec try_creation n =
+ try
+ let fn =
+ Filename.concat
+ config.tmp_directory
+ (config.tmp_prefix ^ "-" ^ (string_of_int n))
+ in
+ let fd =
+ open_out_gen
+ [ Open_wronly; Open_creat; Open_excl; Open_binary ]
+ 0o666
+ fn
+ in
+ fn, fd
+ with
+ Sys_error m ->
+ (* This does not look very intelligent, but it is the only chance
+ * to limit the number of trials.
+ *)
+ if n > 1000 then
+ failwith ("Cgi: Cannot create temporary file: " ^ m);
+ try_creation (n+1)
+ in
+ try_creation 0
+;;
+
+
+let dest_form_encoded_parameters_from_netstream s ~boundary config =
+ let parts = ref [] in
+ let options =
+ if List.mem Work_around_backslash_bug config.workarounds then
+ [ Mimestring.No_backslash_escaping ]
+ else
+ []
+ in
+
+ let create header =
+ (* CALLBACK for scan_multipart_body_from_netstream *)
+ let name, mime_type, filename = dest_parameter_header header options in
+ let p0 =
+ { arg_name = name;
+ arg_processing = Memory;
+ arg_buf_value = Buffer.create 80;
+ arg_mem_value = None;
+ arg_disk_value = Weak.create 1;
+ arg_file = None;
+ arg_fd = None;
+ arg_mimetype = mime_type;
+ arg_filename = filename;
+ arg_header = header;
+ }
+ in
+ let pr = config.how_to_process_arguments p0 in
+ let p = { p0 with arg_processing = pr } in
+ if pr = File then begin
+ let fn, fd = make_temporary_file config in
+ p.arg_file <- Some fn;
+ p.arg_fd <- Some fd;
+ p.arg_mem_value <- None;
+ end;
+ p
+ in
+
+ let add p s k n =
+ (* CALLBACK for scan_multipart_body_from_netstream *)
+ if (p.arg_processing = Automatic) &&
+ (Buffer.length (p.arg_buf_value) >= Netstream.block_size s) then begin
+ (* This is a LARGE argument *)
+ p.arg_processing <- File;
+ let fn, fd = make_temporary_file config in
+ p.arg_file <- Some fn;
+ p.arg_fd <- Some fd;
+ p.arg_mem_value <- None;
+ output_string fd (Buffer.contents p.arg_buf_value);
+ p.arg_buf_value <- Buffer.create 1;
+ end;
+
+ match p.arg_processing with
+ (Memory|Automatic) ->
+ Buffer.add_substring
+ p.arg_buf_value
+ (Netbuffer.unsafe_buffer (Netstream.window s))
+ k
+ n
+ | File ->
+ let fd = match p.arg_fd with Some fd -> fd | None -> assert false in
+ output
+ fd
+ (Netbuffer.unsafe_buffer (Netstream.window s))
+ k
+ n;
+ in
+
+ let stop p =
+ (* CALLBACK for scan_multipart_body_from_netstream *)
+ begin match p.arg_processing with
+ (Memory|Automatic) ->
+ p.arg_mem_value <- Some (Buffer.contents p.arg_buf_value);
+ p.arg_buf_value <- Buffer.create 1;
+ | File ->
+ let fd = match p.arg_fd with Some fd -> fd | None -> assert false in
+ close_out fd;
+ p.arg_mem_value <- None
+ end;
+ parts := p :: !parts
+ in
+
+ Mimestring.scan_multipart_body_from_netstream
+ s
+ boundary
+ create
+ add
+ stop;
+
+ List.rev !parts
+;;
+
+
+let getenv name =
+ try Sys.getenv name with Not_found -> "";;
+
+(* getenv:
+ * We use this getenv instead of Sys.getenv. The CGI specification does not
+ * say anything about what should happen if a certain environment variable
+ * is not set.
+ * Some servers initialize the environment variable to the empty string if
+ * it is not applicable, some servers do not set the variable at all. Because
+ * of this, unset variables are always reported as empty variables.
+ *
+ * This is especially a problem with QUERY_STRING.
+ *)
+
+let mk_simple_arg ~name v =
+ { arg_name = name;
+ arg_processing = Memory;
+ arg_buf_value = Buffer.create 1;
+ arg_mem_value = Some v;
+ arg_disk_value = Weak.create 0;
+ arg_file = None;
+ arg_fd = None;
+ arg_mimetype = "text/plain";
+ arg_filename = None;
+ arg_header = [];
+ }
+;;
+
+let mk_memory_arg ~name ?(mime = "text/plain") ?filename ?(header = []) v =
+ { arg_name = name;
+ arg_processing = Memory;
+ arg_buf_value = Buffer.create 1;
+ arg_mem_value = Some v;
+ arg_disk_value = Weak.create 0;
+ arg_file = None;
+ arg_fd = None;
+ arg_mimetype = mime;
+ arg_filename = filename;
+ arg_header = header;
+ }
+;;
+
+let mk_file_arg
+ ~name ?(mime = "text/plain") ?filename ?(header = []) v_filename =
+ let v_abs_filename =
+ if Filename.is_relative v_filename then
+ Filename.concat (Sys.getcwd()) v_filename
+ else
+ v_filename
+ in
+ { arg_name = name;
+ arg_processing = File;
+ arg_buf_value = Buffer.create 1;
+ arg_mem_value = None;
+ arg_disk_value = Weak.create 0;
+ arg_file = Some v_abs_filename;
+ arg_fd = None;
+ arg_mimetype = mime;
+ arg_filename = filename;
+ arg_header = header;
+ }
+;;
+
+
+let get_content_type config =
+ (* Get the environment variable CONTENT_TYPE; if necessary apply
+ * workarounds for browser bugs.
+ *)
+ let content_type = getenv "CONTENT_TYPE" in
+ let user_agent = getenv "HTTP_USER_AGENT" in
+ let eff_content_type =
+ if Str.string_match (Str.regexp ".*MSIE") user_agent 0 &&
+ List.mem Work_around_MSIE_Content_type_bug config.workarounds
+ then begin
+ (* Microsoft Internet Explorer: When used with SSL connections,
+ * this browser sometimes produces CONTENT_TYPEs like
+ * "multipart/form-data; boundary=..., multipart/form-data; boundary=..."
+ * Workaround: Throw away everything after ", ".
+ *)
+ if Str.string_match (Str.regexp "\\([^,]*boundary[^,]*\\), .*boundary")
+ content_type 0
+ then
+ Str.matched_group 1 content_type
+ else
+ content_type
+ end
+ else
+ content_type
+ in
+ eff_content_type
+;;
+
+
+let really_parse_args config =
+ let make_simple_arg (n,v) = mk_simple_arg n v in
+
+ match getenv "REQUEST_METHOD" with
+ ("GET"|"HEAD") ->
+ List.map
+ make_simple_arg
+ (dest_url_encoded_parameters(getenv "QUERY_STRING"))
+
+ | "POST" ->
+ let n =
+ try
+ int_of_string (getenv "CONTENT_LENGTH")
+ with
+ _ -> failwith "Cgi.parse_arguments"
+ in
+ if n > config.maximum_content_length then
+ raise Resources_exceeded;
+ begin
+ let mime_type, params =
+ Mimestring.scan_mime_type(get_content_type config) [] in
+ match mime_type with
+ "application/x-www-form-urlencoded" ->
+ let buf = String.create n in
+ really_input stdin buf 0 n;
+ List.map
+ make_simple_arg
+ (dest_url_encoded_parameters buf)
+ | "multipart/form-data" ->
+ let boundary =
+ try
+ List.assoc "boundary" params
+ with
+ Not_found ->
+ failwith "Cgi.parse_arguments"
+ in
+ (* -------------------------------------------------- DEBUG
+ let f = open_out "/tmp/cgiout" in
+ output_string f buf;
+ close_out f;
+ * --------------------------------------------------
+ *)
+ dest_form_encoded_parameters_from_netstream
+ (Netstream.create_from_channel stdin (Some n) 4096)
+ boundary
+ config
+ | _ ->
+ failwith ("Cgi.parse_arguments: unknown content-type " ^ mime_type)
+ end
+ | _ ->
+ failwith "Cgi.parse_arguments: unknown method"
+
+let parsed = ref None;; (* protected by lock/unlock *)
+
+let lock = ref (fun () -> ());;
+let unlock = ref (fun () -> ());;
+
+let init_mt new_lock new_unlock =
+ lock := new_lock;
+ unlock := new_unlock
+;;
+
+let protect f =
+ !lock();
+ try
+ let r = f() in
+ !unlock();
+ r
+ with
+ x ->
+ !unlock();
+ raise x
+;;
+
+let parse_arguments config =
+ protect
+ (fun () ->
+ match !parsed with
+ Some _ -> ()
+ | None ->
+ parsed := Some (List.map
+ (fun arg -> arg.arg_name, arg)
+ (really_parse_args config))
+ )
+;;
+
+let arguments () =
+ protect
+ (fun () ->
+ match !parsed with
+ Some plist -> plist
+ | None ->
+ failwith "Cgi.arguments"
+ )
+;;
+
+let set_arguments arglist =
+ protect
+ (fun () ->
+ parsed := Some (List.map
+ (fun arg -> arg.arg_name, arg)
+ arglist)
+ )
+;;
+
+let default_config =
+ { maximum_content_length = max_int;
+ how_to_process_arguments = (fun _ -> Memory);
+ tmp_directory = "/var/tmp";
+ tmp_prefix = "cgi-";
+ workarounds = [ Work_around_MSIE_Content_type_bug;
+ Work_around_backslash_bug;
+ ]
+ }
+;;
+
+let arg_value arg =
+ match arg.arg_mem_value with
+ None ->
+ begin
+ match Weak.get arg.arg_disk_value 0 with
+ None ->
+ begin
+ match arg.arg_file with
+ None ->
+ failwith "Cgi.arg_value: no value present"
+ | Some filename ->
+ let fd = open_in_bin filename in
+ try
+ let len = in_channel_length fd in
+ let s = String.create len in
+ really_input fd s 0 len;
+ Weak.set arg.arg_disk_value 0 (Some s);
+ close_in fd;
+ s
+ with
+ any -> close_in fd; raise any
+ end
+ | Some v -> v
+ end
+ | Some s ->
+ s
+;;
+
+let arg_name arg = arg.arg_name;;
+let arg_file arg = arg.arg_file;;
+let arg_mimetype arg = arg.arg_mimetype;;
+let arg_filename arg = arg.arg_filename;;
+let arg_header arg = arg.arg_header;;
+
+let cleanup () =
+ protect
+ (fun () ->
+ match !parsed with
+ None -> ()
+ | Some plist ->
+ List.iter
+ (fun (name, arg) ->
+ match arg.arg_file with
+ None -> ()
+ | Some filename ->
+ (* We do not complain if the file does not exist anymore. *)
+ if Sys.file_exists filename then
+ Sys.remove filename;
+ arg.arg_file <- None
+ )
+ plist
+ )
+;;
+
+let argument name = List.assoc name (arguments());;
+let argument_value name = arg_value (argument name);;
+
+module Operators = struct
+ let ( !% ) = argument
+ let ( !$ ) = argument_value
+end;;
+
+
+let parse_args() =
+ parse_arguments default_config;
+ List.map
+ (fun (name, arg) -> name, arg_value arg)
+ (arguments())
+;;
+
+let parse_args_with_mimetypes() =
+ parse_arguments default_config;
+ List.map
+ (fun (name, arg) -> name, arg_mimetype arg, arg_value arg)
+ (arguments())
+;;
+
+let header s =
+ let t =
+ match s with
+ "" -> "text/html"
+ | _ -> s
+ in
+ print_string ("Content-type: " ^ t ^ "\n\n");
+ flush stdout
+;;
+
+
+let this_url() =
+ "http://" ^ (getenv "SERVER_NAME") ^ (getenv "SCRIPT_NAME")
+;;
+
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1 2000/11/17 09:57:27 lpadovan
+ * Initial revision
+ *
+ * Revision 1.8 2000/06/25 22:34:43 gerd
+ * Added labels to arguments.
+ *
+ * Revision 1.7 2000/06/25 21:40:36 gerd
+ * Added printer.
+ *
+ * Revision 1.6 2000/06/25 21:15:48 gerd
+ * Checked thread-safety.
+ *
+ * Revision 1.5 2000/05/16 22:29:36 gerd
+ * Added support for two common file upload bugs.
+ *
+ * Revision 1.4 2000/04/15 16:47:27 gerd
+ * Last minor changes before releasing 0.6.
+ *
+ * Revision 1.3 2000/04/15 13:09:01 gerd
+ * Implemented uploads to temporary files.
+ *
+ * Revision 1.2 2000/03/02 01:15:30 gerd
+ * Updated.
+ *
+ * Revision 1.1 2000/02/25 15:21:12 gerd
+ * Initial revision.
+ *
+ *
+ *)
projects / helm.git / blobdiff