X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Fpxp%2Fnetstring%2Fcgi.ml;fp=helm%2FDEVEL%2Fpxp%2Fnetstring%2Fcgi.ml;h=48412be291b9e04a3669f6d25bfec45c75434e97;hb=c03d2c1fdab8d228cb88aaba5ca0f556318bebc5;hp=0000000000000000000000000000000000000000;hpb=758057e85325f94cd88583feb1fdf6b038e35055;p=helm.git

diff --git a/helm/DEVEL/pxp/netstring/cgi.ml b/helm/DEVEL/pxp/netstring/cgi.ml
new file mode 100644
index 000000000..48412be29
--- /dev/null
+++ b/helm/DEVEL/pxp/netstring/cgi.ml
@@ -0,0 +1,645 @@
+(* $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.
+ *
+ *
+ *)