5 (c
) Jonas Barklund
, Computing Science Dept
., Uppsala University
, 1996.
7 Support for form
-based file upload via multipart
/form
-data
,
8 by Peter
Sestoft (sestoft@dina
.kvl
.dk
) December
1996.
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
.
16 Ported to SML
/NJ by Dave
MacQueen (7 Apr
1998).
17 Tweaked to work
with a saved heap image by Adam
Chlipala (2003).
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
)
46 structure Splaymap
= SplayMapFn(struct type ord_key
= string
47 val compare
= String.compare
54 |
intOf (SOME s
) = Int.fromString s
56 val query_string
= ref
""
58 fun isn
't c1 c2
= c1
<> c2
59 fun is c1 c2
= c1
= c2
61 (* For debugging
, one may log to the httpd error_log
: *)
63 fun err s
= TextIO.output(TextIO.stdErr
, s
);
65 (* val _
= err query_string
;
66 val _
= err (Int.toString (getOpt(intOf cgi_content_length
, 0)));
69 (* Get the line starting
with string s
*)
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
77 (* Get the value
of boundary
*)
79 fun getboundary line
=
81 val (_
, bndeqn
) = position
"boundary=" line
83 if isEmpty bndeqn
then NONE
84 else SOME (string (triml
1 (dropl (isn
't #
"=") bndeqn
)))
88 (* If CGI request
type is multipart
/form
-data
, then SOME(boundary
): *)
90 val multipart_boundary
= ref (NONE
: string option
)
92 val the_fields
= ref ([] : substring list
)
94 val dict_with_codes
= ref ([] : substring list list
)
96 (* Decode CGI parameters
: *)
100 val sz
= Substring
.size(sus
);
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
111 Char.chr(16*dehex(Substring
.sub(sus
,i
+1))+
112 dehex(Substring
.sub(sus
,i
+2)));
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);
120 String.implode(dec(0))
122 (err ("decode failed on " ^ Substring
.string sus ^
"\n"); "")
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
129 fun addField ([keysrc
, valsrc
], dict
) =
130 addItem ((decode keysrc
, decode valsrc
), dict
)
131 |
addField (_
, dict
) = dict
133 val cgi_dict
= ref (Splaymap
.empty
: string list Splaymap
.map
)
135 fun keys dict
: string list
=
136 Splaymap
.foldri (fn (key
,_
,res
) => key
:: res
) [] dict
138 (* Decode multipart messages
: *)
140 fun part_fields dict name
=
141 case Splaymap
.find (dict
, name
) of
145 fun part_field dict name
=
146 case Splaymap
.find (dict
, name
) of
147 SOME (v
:: _
) => SOME v
150 fun getint NONE default
= default
151 |
getint (SOME str
) default
=
152 case Int.scan
StringCvt.DEC Substring
.getc (Substring
.all str
) of
154 |
SOME(i
, rest
) => if Substring
.isEmpty rest
then i
else default
156 val multiparts
= ref ([] : substring list
)
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
)
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
173 val dict
: string list Splaymap
.map
=
174 List.foldr addField Splaymap
.empty equations
177 case part_field dict
"name" of
178 NONE
=> "[Anonymous]" (* Is this is good idea?
*)
182 { fieldnames
= keys dict
,
183 tyOpt
= if isEmpty typ
then NONE
else SOME (string typ
),
185 (* Strip off CRLFCRLF
and CRLF
*)
186 data
= string (trimr
2 (triml
4 rest
))
190 type part
= {fieldnames
: string list
,
191 tyOpt
: string option
,
192 dict
: (string list
) Splaymap
.map
,
195 val part_dict
= ref (Splaymap
.empty
: (part list
) Splaymap
.map
)
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
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
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
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");
239 multipart_boundary
:=
241 val content_type
= all (valOf (!cgi_content_type
))
243 if isPrefix
"multipart/form-data;" content_type
then
244 getboundary content_type
247 end handle Option
=> NONE
);
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
,""));
256 (case !multipart_boundary
of
257 NONE
=> Substring
.tokens (is #
"&") (Substring
.all (!query_string
))
260 dict_with_codes
:= List.map (Substring
.fields (is #
"=")) (!the_fields
);
262 cgi_dict
:= List.foldr addField Splaymap
.empty (!dict_with_codes
);
266 val boundary
= "--" ^
valOf (!multipart_boundary
)
267 val skipbnd
= dropl (isn
't #
"\n")
268 val (_
, contents
) = position
boundary (all (!query_string
))
270 let val (pref
, suff
) = position boundary rest
272 if isEmpty pref
orelse isEmpty suff
then []
273 else pref
:: loop (skipbnd suff
)
275 in loop (skipbnd contents
) end
276 handle Option
=> []);
278 part_dict
:= List.foldr addItem Splaymap
.empty (List.map
decodepart (!multiparts
)))
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
303 end (* structure Cgi
*)