(* Cgi *)
(* $Id: cgi.ml,v 1.3 2001/02/26 20:07:07 berke Exp $ *)

let sf = Printf.sprintf;;

let hexadecimal c =
  match c with
  | '0' .. '9' -> (Char.code c) - (Char.code '0')
  | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10
  | 'A' .. 'F' -> (Char.code c) - (Char.code 'A') + 10
  | _ -> raise (Invalid_argument (sf "Character %C is not hexadecimal" c))
;;

let read_hex_encoded_char =
  parser
    | [< 'c1; 'c2 >] -> (Char.chr (16 * (hexadecimal c1) + (hexadecimal c2)))
;;

let rec read_chunk s =
  let b = Buffer.create 16 in
  let rec boucle =
  parser
    | [< 'c; s >] ->
	begin
	  match c with
	  | '%' ->
	      Buffer.add_char b (read_hex_encoded_char s);
	      boucle s
	  | '+' ->
	      Buffer.add_char b ' ';
	      boucle s
	  | '=' -> (Buffer.contents b, `Equal)
	  | '&' -> (Buffer.contents b, `Ampersand)
	  | _ ->
	      Buffer.add_char b c;
	      boucle s
	end
    | [< >] ->
	(Buffer.contents b, `EOS)
  in
  boucle s
;;

module SM = Map.Make (struct type t = string let compare = compare end);;
module SS = Set.Make (struct type t = string let compare = compare end);;

let parse_form_from_stream t =
  let add n v f =
    if SM.mem n f then
      let x = SM.find n f in
      SM.add n (SS.add v x) f
    else
      SM.add n (SS.singleton v) f
  in
  let rec loop f =
    let (name,x) = read_chunk t in
    match x with
    |	`EOS ->
        if name <> "" then
          raise (Invalid_argument (sf "Bad form: EOS in name %S" name))
        else
          f
    |	`Ampersand ->
	raise (Invalid_argument (sf "Bad form: ampersand in name %S" name))
    |	`Equal -> 
	begin
	  if String.length name = 0 then
	    raise (Invalid_argument (sf "Bad form: empty name"));
	  let (value,x) = read_chunk t in
	  let f = add name value f in
	  match x with
	  | `EOS -> f
	  | `Ampersand -> loop f
	  | `Equal ->
	      raise (Invalid_argument (sf "Bad form: '=' in value"))
	end
  in
  loop SM.empty
;;

let parse_form_from_string s =
  let t = Stream.of_string s in
  parse_form_from_stream t
;;

let display_stringmapstring f =
  SM.iter (fun k d -> Printf.printf "\"%s\" -> \"%s\"\n" k d) f
;;

let display_stringsetstringmap f =
  SM.iter (fun k d ->
    Printf.printf "\"%s\" -> {" k;
    SS.iter (fun s -> Printf.printf " \"%s\"" s) d;
    Printf.printf " }\n") f
;;

let encode_string b x =
  let hex = "0123456789ABCDEF" in
  for i = 0 to String.length x - 1 do
    let c = x.[i] in
    let d = Char.code c in
    if c = ' ' then Buffer.add_char b '+'
    else if d < 32 or d > 126 or c = '&' or c = '=' or c = '"' or c = '%' then
      begin
	Buffer.add_char b '%';
	Buffer.add_char b hex.[d lsr 4];
	Buffer.add_char b hex.[d land 15];
      end
    else Buffer.add_char b c
  done
;;

let encode_form f =
  let b = Buffer.create 16 in
  SM.iter
    (fun n s ->
      (SS.iter
	 (fun v ->
	   if Buffer.length b > 0 then Buffer.add_char b '&';
	   encode_string b n;
	   Buffer.add_char b '=';
	   encode_string b v) s)) f;
  Buffer.contents b
;;

let encode_form_from_list f =
  let b = Buffer.create 16 in
  List.iter
    (fun (n,s) ->
      (List.iter
	 (fun v ->
	   if Buffer.length b > 0 then Buffer.add_char b '&';
	   encode_string b n;
	   Buffer.add_char b '=';
	   encode_string b v) s)) f;
  Buffer.contents b
;;
