src/lib/cgi.sml

   1 (*
   2
   3  Mosmlcgi.sml
   4
   5  (c) Jonas Barklund, Computing Science Dept., Uppsala University, 1996.
   6
   7  Support for form-based file upload via multipart/form-data,
   8  by Peter Sestoft (sestoft@dina.kvl.dk) December 1996.
   9
  10  Anyone is granted the right to copy and/or use this code, provided
  11  that this note is retained, also in modified versions.  The code is
  12  provided as is with no guarantee about any functionality.  I take no
  13  responsibility for its proper function.
  14
  15  --------
  16  Ported to SML/NJ by Dave MacQueen (7 Apr 1998).
  17  Tweaked to work with a saved heap image by Adam Chlipala (2003).
  18
  19 *)
  20
  21 structure Cgi : CGI =
  22 struct
  23
  24 val cgi_server_software = ref (NONE : string option)
  25 val cgi_server_name = ref (NONE : string option)
  26 val cgi_gateway_interface = ref (NONE : string option)
  27 val cgi_server_protocol = ref (NONE : string option)
  28 val cgi_server_port = ref (NONE : string option)
  29 val cgi_request_method = ref (NONE : string option)
  30 val cgi_http_accept = ref (NONE : string option)
  31 val cgi_http_user_agent = ref (NONE : string option)
  32 val cgi_http_referer = ref (NONE : string option)
  33 val cgi_path_info = ref (NONE : string option)
  34 val cgi_path_translated = ref (NONE : string option)
  35 val cgi_script_name = ref (NONE : string option)
  36 val cgi_query_string = ref (NONE : string option)
  37 val cgi_remote_host = ref (NONE : string option)
  38 val cgi_remote_addr = ref (NONE : string option)
  39 val cgi_remote_user = ref (NONE : string option)
  40 val cgi_remote_ident = ref (NONE : string option)
  41 val cgi_auth_type = ref (NONE : string option)
  42 val cgi_content_type = ref (NONE : string option)
  43 val cgi_content_length = ref (NONE : string option)
  44 val cgi_annotation_server = ref (NONE : string option)
  45
  46 structure Splaymap = SplayMapFn(struct type ord_key = string
  47                                        val compare = String.compare
  48                                 end)
  49
  50 local
  51     open Option TextIO
  52
  53     fun intOf NONE     = NONE
  54       | intOf (SOME s) = Int.fromString s
  55
  56     val query_string = ref ""
  57
  58     fun isn't c1 c2 = c1 <> c2
  59     fun is    c1 c2 = c1 = c2
  60
  61     (* For debugging, one may log to the httpd error_log: *)
  62
  63     fun err s = TextIO.output(TextIO.stdErr, s);
  64
  65     (* val _ = err query_string;
  66        val _ = err (Int.toString  (getOpt(intOf cgi_content_length, 0)));
  67      *)
  68
  69     (* Get the line starting with string s *)
  70
  71     fun line s sus =
  72         let open Substring
  73             val (_, fullline) = position s sus
  74             val after = triml (String.size s) fullline
  75         in takel (fn c => c <> #"\r" andalso c <> #"\n") after end
  76
  77     (* Get the value of boundary *)
  78
  79     fun getboundary line =
  80         let open Substring
  81             val (_, bndeqn) = position "boundary=" line
  82         in
  83             if isEmpty bndeqn then NONE
  84             else SOME (string (triml 1 (dropl (isn't #"=") bndeqn)))
  85         end
  86         handle Option => NONE
  87
  88     (* If CGI request type is multipart/form-data, then SOME(boundary):  *)
  89
  90     val multipart_boundary = ref (NONE : string option)
  91
  92     val the_fields = ref ([] : substring list)
  93
  94     val dict_with_codes = ref ([] : substring list list)
  95
  96     (* Decode CGI parameters: *)
  97
  98     fun decode(sus) =
  99         let
 100             val sz = Substring.size(sus);
 101             exception Dehex;
 102             fun dehex(ch) =
 103                 if #"0" <= ch andalso ch <= #"9"
 104                     then Char.ord(ch) - Char.ord(#"0")
 105                 else if #"A" <= ch andalso ch <= #"F"
 106                          then (Char.ord(ch) - Char.ord(#"A")) + 10
 107                      else if #"a" <= ch andalso ch <= #"f"
 108                               then (Char.ord(ch) - Char.ord(#"a")) + 10
 109                           else raise Dehex;
 110             fun decode_one(i) =
 111                 Char.chr(16*dehex(Substring.sub(sus,i+1))+
 112                          dehex(Substring.sub(sus,i+2)));
 113             fun dec(i) =
 114                 if i>=sz then []
 115                 else case Substring.sub(sus,i)
 116                        of #"+" => #" "::dec(i+1)
 117                         | #"%" => decode_one(i)::dec(i+3)
 118                         | ch => ch::dec(i+1);
 119         in
 120             String.implode(dec(0))
 121         end handle exn =>
 122             (err ("decode failed on " ^ Substring.string sus ^ "\n"); "")
 123
 124     fun 'a addItem ((key, value: 'a), dict: 'a list Splaymap.map) =
 125         Splaymap.insert(dict, key, case Splaymap.find(dict, key) of
 126                                         SOME vs => value :: vs
 127                                       | NONE    => [value])
 128
 129     fun addField ([keysrc, valsrc], dict) =
 130         addItem ((decode keysrc, decode valsrc), dict)
 131       | addField (_, dict) = dict
 132
 133     val cgi_dict = ref (Splaymap.empty : string list Splaymap.map)
 134
 135     fun keys dict : string list =
 136         Splaymap.foldri (fn (key,_,res) => key :: res) [] dict
 137
 138     (* Decode multipart messages: *)
 139
 140     fun part_fields dict name =
 141         case Splaymap.find (dict, name) of
 142             NONE      => []
 143           | SOME vals => vals
 144
 145     fun part_field dict name =
 146         case Splaymap.find (dict, name) of
 147             SOME (v :: _) => SOME v
 148           | _             => NONE
 149
 150     fun getint NONE       default = default
 151       | getint (SOME str) default =
 152         case Int.scan StringCvt.DEC Substring.getc (Substring.all str) of
 153             NONE          => default
 154           | SOME(i, rest) => if Substring.isEmpty rest then i else default
 155
 156     val multiparts = ref ([] : substring list)
 157
 158     fun decodepart (part : Substring.substring) =
 159         let open Char Substring
 160             val crlf2 = "\r\n\r\n"
 161             val (header, rest) = position crlf2 part
 162             val eqnsrc = line "Content-Disposition: form-data;" header
 163             val typ = line "Content-Type: " header
 164             val equations = List.map (fn f => dropl isSpace (dropr isSpace f))
 165                                      (fields (is #";") eqnsrc)
 166
 167             fun addField (eqn, dict) =
 168                 let val (name, v) = splitl (isn't #"=") eqn
 169                    (* Drop equals sign and quotes from value *)
 170                     val value = triml 2 (trimr 1 v)
 171                 in addItem((string name, string value), dict) end
 172
 173             val dict : string list Splaymap.map =
 174                 List.foldr addField Splaymap.empty equations
 175
 176             val partname =
 177                 case part_field dict "name" of
 178                     NONE   => "[Anonymous]" (* Is this is good idea? *)
 179                   | SOME n => n
 180         in
 181             (partname,
 182              { fieldnames = keys dict,
 183                tyOpt = if isEmpty typ then NONE else SOME (string typ),
 184                dict  = dict,
 185                (* Strip off CRLFCRLF and CRLF *)
 186                data  = string (trimr 2 (triml 4 rest))
 187              })
 188         end
 189
 190     type part = {fieldnames : string list,
 191                  tyOpt : string option,
 192                  dict : (string list) Splaymap.map,
 193                  data : string}
 194
 195     val part_dict = ref (Splaymap.empty : (part list) Splaymap.map)
 196 in
 197     type part = part
 198     fun cgi_partnames () = keys (!part_dict)
 199     fun cgi_part  name = part_field  (!part_dict) name
 200     fun cgi_parts name = part_fields (!part_dict) name
 201
 202     fun part_fieldnames    (p : part) = #fieldnames p
 203     fun part_type          (p : part) = #tyOpt p
 204     fun part_data          (p : part) = #data p
 205     fun part_field_strings (p : part) name = part_fields (#dict p) name
 206     fun part_field_string  (p : part) name = part_field  (#dict p) name
 207     fun part_field_integer (p : part) (name, default) =
 208         getint (part_field  (#dict p) name) default
 209
 210     fun cgi_fieldnames () = keys (!cgi_dict)
 211     fun cgi_field_strings name = part_fields (!cgi_dict) name
 212     fun cgi_field_string name  = part_field (!cgi_dict) name
 213     fun cgi_field_integer (name, default) =
 214         getint (cgi_field_string name) default
 215
 216     fun init () =
 217         (cgi_server_software := OS.Process.getEnv("SERVER_SOFTWARE");
 218          cgi_server_name := OS.Process.getEnv("SERVER_NAME");
 219          cgi_gateway_interface := OS.Process.getEnv("GATEWAY_INTERFACE");
 220          cgi_server_protocol := OS.Process.getEnv("SERVER_PROTOCOL");
 221          cgi_server_port := OS.Process.getEnv("SERVER_PORT");
 222          cgi_request_method := OS.Process.getEnv("REQUEST_METHOD");
 223          cgi_http_accept := OS.Process.getEnv("HTTP_ACCEPT");
 224          cgi_http_user_agent := OS.Process.getEnv("HTTP_USER_AGENT");
 225          cgi_http_referer := OS.Process.getEnv("HTTP_REFERER");
 226          cgi_path_info := OS.Process.getEnv("PATH_INFO");
 227          cgi_path_translated := OS.Process.getEnv("PATH_TRANSLATED");
 228          cgi_script_name := OS.Process.getEnv("SCRIPT_NAME");
 229          cgi_query_string := OS.Process.getEnv("QUERY_STRING");
 230          cgi_remote_host := OS.Process.getEnv("REMOTE_HOST");
 231          cgi_remote_addr := OS.Process.getEnv("REMOTE_ADDR");
 232          cgi_remote_user := OS.Process.getEnv("REMOTE_USER");
 233          cgi_remote_ident := OS.Process.getEnv("REMOTE_IDENT");
 234          cgi_auth_type := OS.Process.getEnv("AUTH_TYPE");
 235          cgi_content_type := OS.Process.getEnv("CONTENT_TYPE");
 236          cgi_content_length := OS.Process.getEnv("CONTENT_LENGTH");
 237          cgi_annotation_server := OS.Process.getEnv("ANNOTATION_SERVER");
 238
 239          multipart_boundary :=
 240                              (let open Substring
 241                                   val content_type = all (valOf (!cgi_content_type))
 242                               in
 243                                   if isPrefix "multipart/form-data;" content_type then
 244                                       getboundary content_type
 245                                   else
 246                                       NONE
 247                               end handle Option => NONE);
 248
 249          query_string :=
 250                        (case !cgi_request_method of
 251                             SOME ("GET")  => getOpt(!cgi_query_string,"")
 252                           | SOME ("POST") => inputN(stdIn, getOpt(intOf (!cgi_content_length), 0))
 253                           | _             => getOpt(!cgi_query_string,""));
 254
 255          the_fields :=
 256                      (case !multipart_boundary of
 257                           NONE => Substring.tokens (is #"&") (Substring.all (!query_string))
 258                         | _    => []);
 259
 260          dict_with_codes := List.map (Substring.fields (is #"=")) (!the_fields);
 261
 262          cgi_dict := List.foldr addField Splaymap.empty (!dict_with_codes);
 263
 264          multiparts :=
 265                      (let open Substring
 266                           val boundary = "--" ^ valOf (!multipart_boundary)
 267                           val skipbnd = dropl (isn't #"\n")
 268                           val (_, contents) = position boundary (all (!query_string))
 269                           fun loop rest =
 270                               let val (pref, suff) = position boundary rest
 271                               in
 272                                   if isEmpty pref orelse isEmpty suff then []
 273                                   else pref :: loop (skipbnd suff)
 274                               end
 275                       in loop (skipbnd contents) end
 276                       handle Option => []);
 277
 278          part_dict := List.foldr addItem Splaymap.empty (List.map decodepart (!multiparts)))
 279
 280     val cgi_server_software = fn () => !cgi_server_software
 281     val cgi_server_name = fn () => !cgi_server_name
 282     val cgi_gateway_interface = fn () => !cgi_gateway_interface
 283     val cgi_server_protocol = fn () => !cgi_server_protocol
 284     val cgi_server_port = fn () => !cgi_server_port
 285     val cgi_request_method = fn () => !cgi_request_method
 286     val cgi_http_accept = fn () => !cgi_http_accept
 287     val cgi_http_user_agent = fn () => !cgi_http_user_agent
 288     val cgi_http_referer = fn () => !cgi_http_referer
 289     val cgi_path_info = fn () => !cgi_path_info
 290     val cgi_path_translated = fn () => !cgi_path_translated
 291     val cgi_script_name = fn () => !cgi_script_name
 292     val cgi_query_string = fn () => !cgi_query_string
 293     val cgi_remote_host = fn () => !cgi_remote_host
 294     val cgi_remote_addr = fn () => !cgi_remote_addr
 295     val cgi_remote_user = fn () => !cgi_remote_user
 296     val cgi_remote_ident = fn () => !cgi_remote_ident
 297     val cgi_auth_type = fn () => !cgi_auth_type
 298     val cgi_content_type = fn () => !cgi_content_type
 299     val cgi_content_length = fn () => !cgi_content_length
 300     val cgi_annotation_server = fn () => !cgi_annotation_server
 301 end (* local *)
 302
 303 end (* structure Cgi *)