exception No_request_method
exception Unsupported_request_method
exception No_content_length
exception No_content_type
exception Unsupported_content_type
exception Not_a_hexdigit of char
exception Not_an_integer of string
exception Unexpected_CGI_input
exception Invalid

(* This is some of my earliest ML code.  I think there are easier ways
   of doing all this. *)

let url_decode string =

  let int_of_hexdigit c =
    match c with
      '0' -> 0 | '1' -> 1 | '2' -> 2 | '3' -> 3 | '4' -> 4 
    | '5' -> 5 | '6' -> 6 | '7' -> 7 | '8' -> 8 | '9' -> 9 
    | 'A' -> 10 | 'B' -> 11 | 'C' -> 12 | 'D' -> 13 | 'E' -> 14 | 'F' -> 15
    | 'a' -> 10 | 'b' -> 11 | 'c' -> 12 | 'd' -> 13 | 'e' -> 14 | 'f' -> 15
    | _ -> raise (Not_a_hexdigit c) in

  let rec loop pos result =
    if pos < String.length string then
      match string.[pos] with
	'+' -> loop (pos+1) (" " :: result)
      | '%' -> begin
	  try
	    let chr = (char_of_int
			 ((int_of_hexdigit string.[pos+1]) * 16 +
			    (int_of_hexdigit string.[pos+2]))) in
	    loop (pos+3) ((String.make 1 chr) :: result)
	  with
	    (Not_a_hexdigit c) -> loop (pos+1) ("%" :: result)
      end
      | _ -> loop (pos+1) ((String.make 1 string.[pos]) :: result)
    else
      String.concat "" (List.rev result)
  in loop 0 []

let url_encode s =

  let string_of_char_list l =
    let s = String.create (List.length l) in
    let rec loop i l =
      match l with
	[] -> s
      | a::b -> begin s.[i] <- a; loop (i+1) b end
    in loop 0 l 

  and list_from_string s =
    let rec loop i l =
      if (i < 0) then
	l
      else
	loop (i-1) (s.[i] :: l) in
    loop ((String.length s) - 1) []      

  and hex_from_int i =

    let hexdigit_from_int i =
      if (i < 10) then
	char_of_int (i + (int_of_char '0'))
      else
	char_of_int ((i - 10) + (int_of_char 'A')) in

    let rec loop i l =
      if (i = 0) then
	l
      else
	let m = i mod 16
	and r = i / 16 in
	loop r ((hexdigit_from_int m) :: l) in

    loop i [] in

  let escape_char c = '%' :: hex_from_int (int_of_char c)
  and encode_list = ['"';'%';'&';' '] in
  (* let escape_char c = Printf.sprintf "%%%02X" (Char.code c) *)
  (* match c with '"' | '%' | '&' | ' ' -> escape_char c | _ -> [c] *)
  let encode_char c =
    if (List.memq c encode_list) then escape_char c else [c] in
  string_of_char_list
    (List.flatten (List.map encode_char (list_from_string s)))

let cgivars = Hashtbl.create 100

(* If we see -query on the command line set things up so the program 
   can run in a non-cgi environment. *) 

let status = 
  let rec loop i status =
    if i < (Array.length Sys.argv) - 1 then
      if Sys.argv.(i) = "-query" then begin
	let query = Sys.argv.(i+1) in
	Unix.putenv "QUERY_STRING" query;
	match Str.split (Str.regexp "?") query with
	  [script_name; parameters] ->
	    Unix.putenv "HTTP_HOST" "localhost";
	    Unix.putenv "SCRIPT_NAME" script_name;
	    Unix.putenv "REQUEST_URI" query;
	    loop (i+2) false
	| _ ->
	    prerr_endline ("Expected <scriptname>?parameters after -query\n" ^
			   "  saw '" ^ query ^ "'");
	    assert false;
(*	    
	  (try
	     (Unix.getenv "QUERY_STRING") ^ "&" ^ Sys.argv.(i+1)
	   with
	     Not_found -> Sys.argv.(i+1));
*)
      end
      else loop (i+1) status
    else status in
  loop 1 true

let _ =
  if not status then begin
    Unix.putenv "REQUEST_METHOD" "GET"
  end

let cgiinit () =

  let string_replace string old nu =
    let rec loop pos =
      if pos < String.length string then begin
	if string.[pos] = old then string.[pos] <- nu;
	loop (pos+1)
      end
    in loop 0

  and amp_regexp = Str.regexp "&"
  and eq_regexp = Str.regexp "="

  and cgiinput =
    try
      match Unix.getenv "REQUEST_METHOD" with
       (* If this is a GET or HEAD request the cgi variables are
          appended to the url, and therefore appear here in the
          environment variable QUERY_STRING. *)
	"GET" -> (Unix.getenv "QUERY_STRING")
      |	"HEAD" -> (Unix.getenv "QUERY_STRING")

       (* In a POST request the cgi variables are received via
	  standard input. *)
      |	"POST" -> begin
	  match
	    try Unix.getenv "CONTENT_TYPE" 
	    with Not_found -> raise No_content_type
	  with
	    "application/x-www-form-urlencoded" -> begin
	      let n =
		try int_of_string (Unix.getenv "CONTENT_LENGTH")
		with Not_found -> raise No_content_length
	      in
	      let result = String.create n in
	      (* Read n characters from standard input *)
	      ignore (Unix.read (Unix.descr_of_in_channel stdin) result 0 n);
	      result
	    end
	  | _ -> raise Unsupported_content_type
      end
      |	_ -> raise Unsupported_request_method;
    with
      Not_found -> raise No_request_method

  (* Depending on the request method, read all CGI input into cgiinput
     (really should produce HTML error messages, instead of exit()ing) *)

  and pairlist =
    try
      [ "remote_addr=" ^ (Unix.getenv "REMOTE_ADDR") ]
    with
      Not_found -> []

  in

  (* Now split on '&' to extract the name-value pairs into pairlist *)
  let vars = Str.split_delim amp_regexp cgiinput in
  let pairs = List.map (Str.split_delim eq_regexp) vars in

  List.iter
    (fun pr ->
      match pr with
	[lhs;rhs] -> Hashtbl.add cgivars lhs (url_decode rhs)
      | _ -> raise Unexpected_CGI_input)
    pairs

let cgivar_present key =
  try ignore(Hashtbl.find cgivars key); true with _ -> false

let list_of_cgivar key = Hashtbl.find_all cgivars key

let string_of_cgivar key =
  Hashtbl.find cgivars key

let int_of_cgivar key =
  try
    int_of_string (string_of_cgivar key)
  with
    Failure("int_of_string") -> raise (Not_an_integer (string_of_cgivar key))

let float_of_cgivar key = float_of_string (string_of_cgivar key)

let date_of_cgivar key =
  Time.date_of_string (string_of_cgivar key)

let arguments () =
  Hashtbl.fold (fun a v l -> (a, v) :: l) cgivars []