(*

 Mosmlcgi.sml

 (c) Jonas Barklund, Computing Science Dept., Uppsala University, 1996.

 Support for form-based file upload via multipart/form-data,
 by Peter Sestoft (sestoft@dina.kvl.dk) December 1996.

 Anyone is granted the right to copy and/or use this code, provided
 that this note is retained, also in modified versions.  The code is
 provided as is with no guarantee about any functionality.  I take no
 responsibility for its proper function.

 --------
 Ported to SML/NJ by Dave MacQueen (7 Apr 1998).
 Tweaked to work with a saved heap image by Adam Chlipala (2003).

*)

structure Cgi : CGI =
struct

val cgi_server_software = ref (NONE : string option)
val cgi_server_name = ref (NONE : string option)
val cgi_gateway_interface = ref (NONE : string option)
val cgi_server_protocol = ref (NONE : string option)
val cgi_server_port = ref (NONE : string option)
val cgi_request_method = ref (NONE : string option)
val cgi_http_accept = ref (NONE : string option)
val cgi_http_user_agent = ref (NONE : string option)
val cgi_http_referer = ref (NONE : string option)
val cgi_path_info = ref (NONE : string option)
val cgi_path_translated = ref (NONE : string option)
val cgi_script_name = ref (NONE : string option)
val cgi_query_string = ref (NONE : string option)
val cgi_remote_host = ref (NONE : string option)
val cgi_remote_addr = ref (NONE : string option)
val cgi_remote_user = ref (NONE : string option)
val cgi_remote_ident = ref (NONE : string option)
val cgi_auth_type = ref (NONE : string option)
val cgi_content_type = ref (NONE : string option)
val cgi_content_length = ref (NONE : string option)
val cgi_annotation_server = ref (NONE : string option)

structure Splaymap = SplayMapFn(struct type ord_key = string
				       val compare = String.compare
				end)

local
    open Option TextIO

    fun intOf NONE     = NONE
      | intOf (SOME s) = Int.fromString s

    val query_string = ref ""

    fun isn't c1 c2 = c1 <> c2
    fun is    c1 c2 = c1 = c2

    (* For debugging, one may log to the httpd error_log: *)

    fun err s = TextIO.output(TextIO.stdErr, s);

    (* val _ = err query_string;
       val _ = err (Int.toString  (getOpt(intOf cgi_content_length, 0)));
     *)

    (* Get the line starting with string s *)

    fun line s sus = 
	let open Substring
	    val (_, fullline) = position s sus
	    val after = triml (String.size s) fullline
	in takel (fn c => c <> #"\r" andalso c <> #"\n") after end

    (* Get the value of boundary *)

    fun getboundary line = 
	let open Substring
	    val (_, bndeqn) = position "boundary=" line
	in 
	    if isEmpty bndeqn then NONE
	    else SOME (string (triml 1 (dropl (isn't #"=") bndeqn)))
	end
        handle Option => NONE

    (* If CGI request type is multipart/form-data, then SOME(boundary):  *)

    val multipart_boundary = ref (NONE : string option)

    val the_fields = ref ([] : substring list)

    val dict_with_codes = ref ([] : substring list list)

    (* Decode CGI parameters: *)

    fun decode(sus) =
        let
            val sz = Substring.size(sus);
            exception Dehex;
            fun dehex(ch) =
                if #"0" <= ch andalso ch <= #"9"
                    then Char.ord(ch) - Char.ord(#"0")
                else if #"A" <= ch andalso ch <= #"F"
                         then (Char.ord(ch) - Char.ord(#"A")) + 10
                     else if #"a" <= ch andalso ch <= #"f"
                              then (Char.ord(ch) - Char.ord(#"a")) + 10
                          else raise Dehex;
            fun decode_one(i) =
                Char.chr(16*dehex(Substring.sub(sus,i+1))+
		         dehex(Substring.sub(sus,i+2)));
            fun dec(i) =
                if i>=sz then []
                else case Substring.sub(sus,i)
                       of #"+" => #" "::dec(i+1)
                        | #"%" => decode_one(i)::dec(i+3)
                        | ch => ch::dec(i+1);
        in
            String.implode(dec(0))
        end handle exn => 
	    (err ("decode failed on " ^ Substring.string sus ^ "\n"); "")

    fun 'a addItem ((key, value: 'a), dict: 'a list Splaymap.map) =
	Splaymap.insert(dict, key, case Splaymap.find(dict, key) of
			                SOME vs => value :: vs 
				      | NONE    => [value])

    fun addField ([keysrc, valsrc], dict) =
	addItem ((decode keysrc, decode valsrc), dict)
      | addField (_, dict) = dict

    val cgi_dict = ref (Splaymap.empty : string list Splaymap.map)

    fun keys dict : string list =
	Splaymap.foldri (fn (key,_,res) => key :: res) [] dict

    (* Decode multipart messages: *)

    fun part_fields dict name = 
	case Splaymap.find (dict, name) of
	    NONE      => []
	  | SOME vals => vals

    fun part_field dict name =
	case Splaymap.find (dict, name) of
	    SOME (v :: _) => SOME v
	  | _             => NONE

    fun getint NONE       default = default
      | getint (SOME str) default =
	case Int.scan StringCvt.DEC Substring.getc (Substring.full str) of
	    NONE          => default
	  | SOME(i, rest) => if Substring.isEmpty rest then i else default

    val multiparts = ref ([] : substring list)

    fun decodepart (part : Substring.substring) = 
	let open Char Substring
	    val crlf2 = "\r\n\r\n"
	    val (header, rest) = position crlf2 part
	    val eqnsrc = line "Content-Disposition: form-data;" header
	    val typ = line "Content-Type: " header
	    val equations = List.map (fn f => dropl isSpace (dropr isSpace f))
		                     (fields (is #";") eqnsrc)

	    fun addField (eqn, dict) =
		let val (name, v) = splitl (isn't #"=") eqn
		   (* Drop equals sign and quotes from value *)
		    val value = triml 2 (trimr 1 v)
		in addItem((string name, string value), dict) end

	    val dict : string list Splaymap.map = 
		List.foldr addField Splaymap.empty equations

	    val partname = 
		case part_field dict "name" of
		    NONE   => "[Anonymous]" (* Is this is good idea? *)
		  | SOME n => n
	in 
	    (partname, 
	     { fieldnames = keys dict,
	       tyOpt = if isEmpty typ then NONE else SOME (string typ),
	       dict  = dict, 
	       (* Strip off CRLFCRLF and CRLF *)
	       data  = string (trimr 2 (triml 4 rest))
	     })
	end

    type part = {fieldnames : string list, 
		 tyOpt : string option, 
		 dict : (string list) Splaymap.map,
		 data : string}
	
    val part_dict = ref (Splaymap.empty : (part list) Splaymap.map)
in
    type part = part
    fun cgi_partnames () = keys (!part_dict)
    fun cgi_part  name = part_field  (!part_dict) name
    fun cgi_parts name = part_fields (!part_dict) name

    fun part_fieldnames    (p : part) = #fieldnames p
    fun part_type          (p : part) = #tyOpt p
    fun part_data          (p : part) = #data p
    fun part_field_strings (p : part) name = part_fields (#dict p) name
    fun part_field_string  (p : part) name = part_field  (#dict p) name
    fun part_field_integer (p : part) (name, default) = 
	getint (part_field  (#dict p) name) default

    fun cgi_fieldnames () = keys (!cgi_dict)
    fun cgi_field_strings name = part_fields (!cgi_dict) name
    fun cgi_field_string name  = part_field (!cgi_dict) name
    fun cgi_field_integer (name, default) = 
	getint (cgi_field_string name) default

    fun init () =
	(cgi_server_software := OS.Process.getEnv("SERVER_SOFTWARE");
	 cgi_server_name := OS.Process.getEnv("SERVER_NAME");
	 cgi_gateway_interface := OS.Process.getEnv("GATEWAY_INTERFACE");
	 cgi_server_protocol := OS.Process.getEnv("SERVER_PROTOCOL");
	 cgi_server_port := OS.Process.getEnv("SERVER_PORT");
	 cgi_request_method := OS.Process.getEnv("REQUEST_METHOD");
	 cgi_http_accept := OS.Process.getEnv("HTTP_ACCEPT");
	 cgi_http_user_agent := OS.Process.getEnv("HTTP_USER_AGENT");
	 cgi_http_referer := OS.Process.getEnv("HTTP_REFERER");
	 cgi_path_info := OS.Process.getEnv("PATH_INFO");
	 cgi_path_translated := OS.Process.getEnv("PATH_TRANSLATED");
	 cgi_script_name := OS.Process.getEnv("SCRIPT_NAME");
	 cgi_query_string := OS.Process.getEnv("QUERY_STRING");
	 cgi_remote_host := OS.Process.getEnv("REMOTE_HOST");
	 cgi_remote_addr := OS.Process.getEnv("REMOTE_ADDR");
	 cgi_remote_user := OS.Process.getEnv("REMOTE_USER");
	 cgi_remote_ident := OS.Process.getEnv("REMOTE_IDENT");
	 cgi_auth_type := OS.Process.getEnv("AUTH_TYPE");
	 cgi_content_type := OS.Process.getEnv("CONTENT_TYPE");
	 cgi_content_length := OS.Process.getEnv("CONTENT_LENGTH");
	 cgi_annotation_server := OS.Process.getEnv("ANNOTATION_SERVER");

	 multipart_boundary := 
			     (let open Substring
				  val content_type = full (valOf (!cgi_content_type))
			      in 
				  if isPrefix "multipart/form-data;" content_type then 
				      getboundary content_type
				  else
				      NONE
			      end handle Option => NONE);

	 query_string :=
		       (case !cgi_request_method of
			    SOME ("GET")  => getOpt(!cgi_query_string,"")
			  | SOME ("POST") => inputN(stdIn, getOpt(intOf (!cgi_content_length), 0))
			  | _             => getOpt(!cgi_query_string,""));
	 
	 the_fields :=
		     (case !multipart_boundary of
			  NONE => Substring.tokens (is #"&") (Substring.full (!query_string))
			| _    => []);

	 dict_with_codes := List.map (Substring.fields (is #"=")) (!the_fields);

         cgi_dict := List.foldr addField Splaymap.empty (!dict_with_codes);

	 multiparts := 
		     (let open Substring
			  val boundary = "--" ^ valOf (!multipart_boundary)
			  val skipbnd = dropl (isn't #"\n") 
			  val (_, contents) = position boundary (full (!query_string))
			  fun loop rest =
			      let val (pref, suff) = position boundary rest
			      in 
				  if isEmpty pref orelse isEmpty suff then []
				  else pref :: loop (skipbnd suff)
			      end
		      in loop (skipbnd contents) end
		      handle Option => []);

	 part_dict := List.foldr addItem Splaymap.empty (List.map decodepart (!multiparts)))

    val cgi_server_software = fn () => !cgi_server_software
    val cgi_server_name = fn () => !cgi_server_name
    val cgi_gateway_interface = fn () => !cgi_gateway_interface
    val cgi_server_protocol = fn () => !cgi_server_protocol
    val cgi_server_port = fn () => !cgi_server_port
    val cgi_request_method = fn () => !cgi_request_method
    val cgi_http_accept = fn () => !cgi_http_accept
    val cgi_http_user_agent = fn () => !cgi_http_user_agent
    val cgi_http_referer = fn () => !cgi_http_referer
    val cgi_path_info = fn () => !cgi_path_info
    val cgi_path_translated = fn () => !cgi_path_translated
    val cgi_script_name = fn () => !cgi_script_name
    val cgi_query_string = fn () => !cgi_query_string
    val cgi_remote_host = fn () => !cgi_remote_host
    val cgi_remote_addr = fn () => !cgi_remote_addr
    val cgi_remote_user = fn () => !cgi_remote_user
    val cgi_remote_ident = fn () => !cgi_remote_ident
    val cgi_auth_type = fn () => !cgi_auth_type
    val cgi_content_type = fn () => !cgi_content_type
    val cgi_content_length = fn () => !cgi_content_length
    val cgi_annotation_server = fn () => !cgi_annotation_server
end (* local *)

end (* structure Cgi *)