Commit | Line | Data |
---|---|---|
c0a3b488 AC |
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 = | |
142d9e8c | 152 | case Int.scan StringCvt.DEC Substring.getc (Substring.full str) of |
c0a3b488 AC |
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 | |
142d9e8c | 241 | val content_type = full (valOf (!cgi_content_type)) |
c0a3b488 AC |
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 | |
142d9e8c | 257 | NONE => Substring.tokens (is #"&") (Substring.full (!query_string)) |
c0a3b488 AC |
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") | |
142d9e8c | 268 | val (_, contents) = position boundary (full (!query_string)) |
c0a3b488 AC |
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 *) |