Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 542 lines (498 sloc) 26.215 kb
fccc685 Initial open-source release
MLstate authored
1 % -*-erlang-*-
2
3 %
4 % Copyright © 2011 MLstate
5 %
6 % This file is part of OPA.
7 %
8 % OPA is free software: you can redistribute it and/or modify it under the
9 % terms of the GNU Affero General Public License, version 3, as published by
10 % the Free Software Foundation.
11 %
12 % OPA is distributed in the hope that it will be useful, but WITHOUT ANY
13 % WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
14 % FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
15 % more details.
16 %
17 % You should have received a copy of the GNU Affero General Public License
18 % along with OPA. If not, see <http://www.gnu.org/licenses/>.
19 %
20 -generate server
21 -debugvar PROTOCOL_DEBUG
22 -protocol HTTP
23
24 -open Base
25 -open Rcontent
26 -open HttpTools
27 -open HttpServerTypes
28
29 % This will have to wait...
30 % ...because we can't put these in the interface.
31 %-modalias HT = HttpTools
32 %-modalias HST = HttpServerTypes
33 %-modalias S = String
34
35 % This will be for the raw parser
36 %-include "libnet/httpMessages.proto"
37
38 -include "libnet/http_messages.proto"
39 -include "libnet/http_rr.proto"
40
41 -define Crlf = "\r\n"
42 -define EndBoundary b = "--" !"\r\n" b "--\r\n"
43 -define Boundary b = "--" b "\r\n"
44 -define Partial str = str "\r\n"
45 -define Body str = str
46
47 -type rt_core =
48 {
49 rt_pre_headers : handle_request -> msg -> header list -> (handle_request * header list);
50 rt_post_headers : handle_request -> msg -> header list -> header list -> (handle_request * header list * bool);
51 rt_server_send_buffer_size : int;
52 rt_server_wait_for_request_timeout : Time.t;
53 rt_server_wait_for_request_initial_timeout : Time.t;
54 rt_maximum_number_of_connections : int;
55 rt_maximum_content_length : int;
56 rt_maximum_number_of_headers : int;
57 rt_log_accesses : bool;
58 rt_time_diff : string;
59 rt_plim : int;
60 }
61
62 -type body_value = string * content * Time.t * string
63
64 -type rt_server =
65 {
66 mutable rt_dialog_content : HttpDialog.t;
67 rt_dialog_name : string;
68 rt_server_name : string;
69 rt_on_run : Scheduler.t -> unit;
70 rt_on_close : Scheduler.t -> unit;
71 rt_favicon_ico : body_value;
72 rt_favicon_gif : body_value;
73 }
74
75 -type payload = string * (header list)
76 -include "libnet/rt_proto.proto"
77
78 -type rt_tmp =
79 {
80 rt_hr : handle_request;
81 rt_conn : int;
82 rt_callback : (payload -> int -> Buffer.t -> bool) option;
83 }
84 %TODO: parse this: rt_callback : (?payload:(header list) -> (int * Buffer.t) -> bool) option;
85
86 -type runtime =
87 {
88 rt_get : Scheduler.t -> runtime -> msg -> handle_request -> get
89 -> Scheduler.connection_info -> (response -> unit) -> unit;
90 rt_post : Scheduler.t -> runtime -> msg -> handle_request -> post
91 -> Scheduler.connection_info -> (response -> unit) -> unit;
92 rt_tmp : rt_tmp;
93 rt_server : rt_server;
94 rt_proto : rt_proto;
95 rt_core : rt_core;
96 }
97
98 -val allowed_hosts : string list ref
99 -val http_version_number : string
100 -val http_version : string
101 -val make_status : int -> string -> msg
102 -val get_response : msg -> msg list -> content -> string
103 -val server_name : string
104 -val request_type_http_version : msg -> string
105 -val request_type_uri : msg -> string
106 -val parse_content_disposition : msg -> (string * string) list
107 -val unallocate_request : request -> unit
108 -val unallocate_response : response -> unit
109 -val null_payload : payload
110
111 {{
112 let allowed_hosts = ref []
113 let http_version_number = "1.1"
114 let http_version = "HTTP/"^http_version_number
115 let make_status code msg = Sl (http_version_number, code, msg)
116 let get_response sl headers content =
117 (string_of_msg sl)^(List.fold_left (fun s h -> s^(string_of_msg h)) "" headers)^crlf^(get_content content)
118 let version = string_of_int BuildInfos.git_version_counter
119 let server_name = sprintf "OPA/%s" version
120 let headerstr headers = List.fold_left (fun s h -> s^(string_of_msg h)) "" headers
121 let request_type_http_version = function
122 | Get (_,v) -> v
123 | Head (_,v) -> v
124 | Post (_,v) -> v
125 | Put (_,v) -> v
126 | Del (_,v) -> v
127 | Trace (_,v) -> v
128 | Conn (_,v) -> v
129 | _ -> "1.0"
130 let request_type_uri = function
131 | Get (uri,_) -> uri
132 | Head (uri,_) -> uri
133 | Post (uri,_) -> uri
134 | Put (uri,_) -> uri
135 | Del (uri,_) -> uri
136 | Trace (uri,_) -> uri
137 | Conn (uri,_) -> uri
138 | msg -> raise (Failure (sprintf "request_type_uri: %s not a request type" (string_of_msg msg)))
139 let parse_content_disposition = function
140 | Content_Disposition (s,l) -> List.map (fun s -> rmldtrsp2 (Base.String.split_char '=' s)) (s::l)
141 | _ -> failwith "Not implemented yet."
142 let unallocate_request req =
143 content_unallocate req.request_message_body;
144 List.iter (fun (_,content) -> content_unallocate content) req.request_post_body
145 let unallocate_response res = content_unallocate res.body
146 let unallocate_mpr mpr = List.iter (fun (_,content) -> content_unallocate content) mpr.request_body
147 let unallocate_post = function
148 | Simple (_,_,body) -> content_unallocate body
149 | Multipart mpr -> unallocate_mpr mpr
150 let buffer_of_response sl headers body =
151 let b = HttpTools.get_buf ~hint:(4096+content_length body) () in
152 (*let b = OBuffer.create (4096+content_length body) in*)
153 Buffer.add_string b (string_of_msg sl);
154 List.iter (fun h -> Buffer.add_string b (string_of_msg h)) headers;
155 Buffer.add_string b "\r\n";
156 Buffer.add_string b (get_content body);
157 b
158 (*let content_of_response sl headers body =
159 let c = content_make ~hint:(4096+content_length body) (get_content_type body) in
160 let c = content_add (string_of_msg sl) c in
161 let c = List.fold_left (fun c h -> content_add (string_of_msg h) c) c headers in
162 let c = content_add "\r\n" c in
163 content_add_content c body*)
164 let conn_no = ref 0
165 let null_payload = ("",[])
166 let http_server_callback runtime (buf,pos_ref) =
167 match runtime.rt_tmp.rt_callback with
168 | Some cb -> cb runtime.rt_proto.rt_payload !pos_ref buf
169 | None -> true
170 let split_cookie str =
171 List.map (fun x -> let a, b = String.split_char '=' x in ((String.trim a), b)) (String.split ((=) ';') str)
172 }}
173
174 % FIXME: parse this...
175 % referer ==> ref (erer) !!!
176 % FIXME: ordering problems with toplevel ocaml !!!
177 [[
178 let access_log runtime request_line response =
179 if runtime.rt_core.rt_log_accesses
180 then
181 let host = runtime.rt_tmp.rt_hr.hr_inet_addr_str in
182 let _method = String.trim (string_of_msg request_line) in
183 let status = match response.sl with | Sl (_,code,_) -> string_of_int code | _ -> "-" in
184 let bytes = content_length response.body in
185 let ua = runtime.rt_tmp.rt_hr.hr_user_agent in
186 let referer = runtime.rt_tmp.rt_hr.hr_referer in
187 (* Combined log format (apparently) *)
188 Logger.log_access "%s - - [%s] \"%s\" %s %d %s %s" host !current_time_string _method status bytes referer ua
189 else ()
190 let get_payload runtime = runtime.rt_proto.rt_payload
191 let set_payload runtime payload = { runtime with rt_proto={ runtime.rt_proto with rt_payload=payload; }; }
192 let set_payload_string runtime str = set_payload runtime ((fun (_,hdrs) -> (str,hdrs)) (get_payload runtime))
193 ]]
194 %TODO: abort log once access log optimizations are official
195
196
197 %%%%%%%%%%%%%%%%%%%%%%%%%
198 %% Handy functions %%
199 %%%%%%%%%%%%%%%%%%%%%%%%%
200
201 close_connection(_fn):
202 debug {{ Logger.debug "close_connection(%d,%s)\n%!" _runtime.rt_tmp.rt_conn _fn }}
203 -!-
204
205 close_connection_req(fn, req_opt):
206 {{ match req_opt with Some req -> unallocate_mpr req | None -> () }}
207 close_connection(fn)
208
209 callback_abort(fn, req_opt):
210 debug {{ Logger.debug "HttpServerCore.%s: Callback abort" fn }}
211 close_connection_req({{fn^"(abort)"}}, req_opt)
212
213 exnerr(fn, req_opt, exn, bt_opt):
214 if {{ exn = CallbackAbort }}
215 then
216 callback_abort(fn, req_opt)
217 else
218 {{ Logger.error "HttpServerCore.%s: exn=%s" fn (Printexc.to_string exn) }}
219 {{ Option.iter (fun bt -> Logger.debug "%s" bt) bt_opt }}
220 close_connection_req(fn, req_opt)
221
222 timeouterr(fn, req_opt):
223 {{ Logger.error "HttpServerCore.%s: Timeout" fn }}
224 close_connection_req(fn, req_opt)
225
226 bad_request(request_type):
227 {{ Logger.error "HttpServerCore.bad_request: %s" (string_of_msg request_type) }}
228 let p = {{ "<html><head><title>Error - Bad Request</title></head><body>Error 400 - Bad Request</body></html>" }}
229 let content_length = {{ Int64.of_int (String.length p) }}
230 let headers = {{ [ (Content_Length content_length); (Connection "close") ] }}
231 let sl = {{ Sl (http_version_number, 400, "Bad Request") }}
232 let body = {{ ContentString p }}
233 let res = {{ { sl=sl; headers=headers; body=body } }}
234 !"access_log"{{ access_log _runtime request_type res }}
235 let buf = {{ buffer_of_response res.sl headers res.body }}
236 send_buf {{ Buffer.contents buf }}
237 {{ HttpTools.free_buf buf }}
238 close_connection({{"bad_request"}})
239
240 send_res(res:response, hr, request_type, headers_in, post_opt):
241 debug 10 {{ Logger.debug "send_res\n%!" }}
242 match !"send_res" {{ _runtime.rt_core.rt_post_headers hr request_type headers_in res.headers }} with
243 | (hr,headers_out,close) ->
244 debug {{ Logger.debug "\n\nResponse:\n%s%s\r\n%s\n\n%!"
245 (string_of_msg res.sl) (headerstr headers_out)
246 (bodystr ~max_body:_runtime.rt_core.rt_plim ~escaped:true res.body) }}
247
248 % FIXME: Temporary and drastic fix for interleaved outgoing messages
249 !"access_log"{{ access_log _runtime request_type res }}
250 let buf = {{ buffer_of_response res.sl headers_out res.body }}
251 send_buf {{ Buffer.contents buf }}
252 {{ HttpTools.free_buf buf }}
253 send_res_cont(hr, close, res, post_opt)
254
255 send_res_cont(hr, close, res, post_opt):
256 debug {{ Logger.debug "Req-Resp time: %f\n%!"
257 (Time.in_seconds (Time.difference _runtime.rt_tmp.rt_hr.hr_timestamp (Time.now()))) }}
258 {{ match post_opt with Some post -> unallocate_post post | None -> () }}
259 {{ unallocate_response res }}
260 if {{ close }}
261 then
262 debug 10 {{ Logger.debug "send_res: closing connection\n%!" }}
263 close_connection({{"close_requested_by_client"}})
264 else
265 debug 10 {{ Logger.debug "send_res: keeping connection\n%!" }}
266 {{ HttpTools.buf_clean _mailbox }}
267 wait_for_request(hr, {{ _runtime.rt_core.rt_server_wait_for_request_timeout }})
268
269 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
270 %%%% General states %%%%
271 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
272
273 +on_connection(hr : handle_request):
274 %release {{ Logger.debug "Release version\n%!" }}
275 {{ incr Cookie2.cookie_connection_count }}
276 {{ incr CookieLong.cookie_connection_count }}
277 let inet_addr_str = {{ Unix.string_of_inet_addr (Scheduler.get_connection_inet_addr conn) }}
278 let hr = {{ { hr with hr_inet_addr_str = inet_addr_str; } }}
279 let _runtime = [[ incr conn_no; { _runtime with rt_tmp = { _runtime.rt_tmp with rt_conn = (!conn_no); rt_hr = hr; } } ]]
280 {{ if _runtime.rt_proto.rt_backtrace then Printexc.record_backtrace true }}
281 debug {{ Logger.debug "on_connection(%d)\n%!" (!number_of_connections) }}
282 let is_secure = {{ NetAddr.get_type (Scheduler.get_connection_addr conn) = NetAddr.SSL }}
283 let hr = {{ { hr with hr_is_secure = is_secure; } }}
284 wait_for_request(hr, {{ _runtime.rt_core.rt_server_wait_for_request_initial_timeout }})
285
286 wait_for_request(hr, timeout):
287 debug 10 {{ Logger.debug "wait_for_request\n%!" }}
288 let _runtime = {{ set_payload _runtime ("WAIT",[]) }}
289 receive
290 | Crlf ->
291 % Blank lines before a request are allowed
292 wait_for_request(hr, timeout)
293 | Head (uri, v) ->
294 wait_for_headers0(uri, {{ [] }}, hr, {{ Head (uri,v) }}, {{ -1 }}, 0, timeout)
295 | Get (uri, v) ->
296 wait_for_headers0(uri, {{ [] }}, hr, {{ Get (uri,v) }}, {{ -1 }}, 0, timeout)
297 | Post (uri, v) ->
298 wait_for_headers0(uri, {{ [] }}, hr, {{ Post (uri,v) }}, {{ -1 }}, 0, timeout)
299 % If we get a secure connection on a non-secure server we get lots of rubbish here
300 % so we only respond with a bad request if it is actually a request.
301 | Put (uri, v) -> bad_request({{ Put (uri,v) }})
302 | Del (uri, v) -> bad_request({{ Del (uri,v) }})
303 | Trace (uri, v) -> bad_request({{ Trace (uri,v) }})
304 | Conn (uri, v) -> bad_request({{ Conn (uri,v) }})
305 | msg ->
306 let amount_of_rubbish = {{ String.length (string_of_msg msg) }}
307 {{ Logger.error "HttpServerCore.wait_for_request: bad request (%d bytes of rubbish)" amount_of_rubbish }}
308 close_connection({{"rubbish_on_request"}})
309 catch
310 | exn ->
311 if {{ exn = Scheduler.Connection_closed }}
312 then
313 close_connection({{"closed_by_client"}})
314 else
315 exnerr ({{"wait_for_request_exception"}}, {{ None }}, exn,
316 {{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
317 after timeout -> close_connection_req ({{"wait_for_request"}}, {{ None }})
318
319 wait_for_headers0(uri, headers, hr, request_type, contlen, hdrcnt, timeout):
320 debug 10 {{ Logger.debug "wait_for_headers: %s\n%!" (string_of_msg request_type) }}
321 let tm = {{ Time.now () }}
322 let hr = {{ { hr with hr_timestamp = tm; hr_timestamp_tm = Time.localtime tm;
323 hr_user_agent = ""; hr_referer = ""; hr_ec = ""; hr_ic = ""; } }}
324 let _runtime = [[ { _runtime with rt_tmp = { _runtime.rt_tmp with rt_hr = hr } } ]]
325 wait_for_headers(uri, headers, hr, request_type, contlen, hdrcnt, timeout)
326
327 wait_for_headers(uri, headers, hr, request_type, contlen, hdrcnt, timeout):
328 if {{ hdrcnt > _runtime.rt_core.rt_maximum_number_of_headers }}
329 then
330 {{ Logger.error "HttpServerCore.wait_for_headers: Maximum number of headers exceeded" }}
331 close_connection({{"max_headers_exceeded"}})
332 else
333 receive
334 | Crlf ->
335 begin
336 match !"wait_for_headers"{{ _runtime.rt_core.rt_pre_headers hr request_type headers }} with
337 | (hr,headers) ->
338 begin
339 debug {{ Logger.debug "\n\nRequest:\n%s%s\r\n%!" (string_of_msg request_type) (headerstr headers) }}
340 match {{ request_type }} with
341 | Head _ -> handle_get(request_type, uri, headers, hr)
342 | Get _ -> handle_get(request_type, uri, headers, hr)
343 | Post _ -> handle_post(request_type, contlen, uri, headers, hr, timeout)
344 | rt -> bad_request(rt)
345 ;
346 end
347 end
348 | Content_Length l ->
349 let contlen = {{ Int64.to_int l }}
350 if {{ contlen > _runtime.rt_core.rt_maximum_content_length }}
351 then
352 {{ Logger.error "Content length exceeds maximum (%d,%d)\n%!" contlen _runtime.rt_core.rt_maximum_content_length }}
353 close_connection({{"content_length_exceeded"}})
354 else
355 debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg (Content_Length l)) }}
356 wait_for_headers(uri, {{ (Content_Length l)::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
357 | User_Agent ua ->
358 debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg (User_Agent ua)) }}
359 let hr = {{ { hr with hr_user_agent = ua; } }}
360 let _runtime = [[ { _runtime with rt_tmp = { _runtime.rt_tmp with rt_hr = hr } } ]]
361 wait_for_headers(uri, {{ (User_Agent ua)::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
362 | Referer rf ->
363 debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg (Referer rf)) }}
364 let hr = {{ { hr with hr_referer = rf; } }}
365 let _runtime = [[ { _runtime with rt_tmp = { _runtime.rt_tmp with rt_hr = hr } } ]]
366 wait_for_headers(uri, {{ (Referer rf)::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
367 | Cookie str ->
368 debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg (Cookie str)) }}
369 let hr = {{ List.fold_left (fun hr -> function
370 | ("ec",str) -> { hr with hr_ec = str }
371 | ("ic",str) -> { hr with hr_ic = str }
372 | _ -> hr) hr (Cookie2.split_cookie str) }}
373 let _runtime = [[ { _runtime with rt_tmp = { _runtime.rt_tmp with rt_hr = hr } } ]]
374 wait_for_headers(uri, {{ (Cookie str)::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
375 | header ->
376 debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg header) }}
377 wait_for_headers(uri, {{ header::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
378 catch | exn -> exnerr ({{"wait_for_headers"}}, {{ None }}, exn,
379 {{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
380 after timeout -> timeouterr ({{"wait_for_headers"}}, {{ None }})
381
382 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
383 %%%% Handling GET and HEAD requests %%%%
384 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
385 handle_get(request_type, uri, headers, hr):
386 let _runtime = {{ set_payload _runtime ("GET",headers) }}
387 if {{ http_server_callback _runtime _mailbox }}
388 then
389 debug {{ Logger.debug "handle_get: uri=%s\n%!" uri }}
390 let res = !"handle_get"<< _runtime.rt_get sched _runtime request_type hr (uri, headers) conn >>
391 send_res(res, hr, request_type, headers, None)
392 else callback_abort({{"handle_get"}}, {{None}})
393
394 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
395 %%%% Handling POST requests %%%%
396 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
397 handle_post(request_type, contlen, uri, headers, hr, timeout):
398 debug 10 {{ Logger.debug "handle_post: uri=%s contlen=%d\n%!" uri contlen }}
399 let _runtime = {{ set_payload _runtime ("POST",headers) }}
400 if {{ http_server_callback _runtime _mailbox }}
401 then
402 let is_ct = {{ function Content_Type _ -> true | _ -> false }}
403 if {{ not (List.exists is_ct headers) }} then
404 handle_simple_post0(request_type, uri, headers, hr, {{ content_make CT_BUFFER ~hint:contlen }}, {{ 0 }}, contlen, timeout)
405 else
406 let fields = {{ (function Content_Type (s,lst) -> s::lst | _ -> assert false) (List.find is_ct headers) }}
407 debug {{ Logger.debug "handle_post: fields=%s\n%!" (String.sconcat ~left:"[" ~right:"]" "," fields) }}
408 if {{ not (List.mem "multipart/form-data" fields) }} then
409 handle_simple_post0(request_type, uri, headers, hr, {{ content_make CT_BUFFER ~hint:contlen }},
410 {{ 0 }}, contlen, timeout)
411 else
412 let b = !"handle_post(missing boundary)"{{ List.find (fun s -> String.is_substring " boundary=" s 0) fields }}
413 let boundary = !"handle_post(bad boundary)"{{ String.sub b 10 (String.length b - 10) }}
414 debug {{ Logger.debug "handle_post: boundary='%s'\n%!" boundary }}
415 handle_multipart(request_type, uri, headers, hr, boundary, contlen, timeout)
416 else callback_abort({{"handle_post"}}, {{None}})
417
418 handle_simple_post0(request_type, uri, headers, hr, body, len, contlen, timeout):
419 if {{ contlen = 0 }}
420 then
421 debug {{ Logger.debug "HttpServerCore.handle_simple_post0: contlen=0" }}
422 let post = {{ Simple (uri, headers, ContentNone) }}
423 let res = !"handle_simple_post0"<< _runtime.rt_post sched _runtime request_type hr post conn >>
424 debug 2 {{ Logger.debug "handle_simple_post0: back from rt_post\n%!" }}
425 send_res(res, hr, request_type, headers, {{ Some post }})
426 else
427 handle_simple_post(request_type, uri, headers, hr, body, len, contlen, timeout)
428
429 handle_simple_post_cont(request_type, uri, headers, hr, body, len, contlen, timeout, str):
430 let body = {{ content_add str body }}
431 let len = {{ len + (String.length str) }}
432 debug {{ Logger.debug "handle_simple_post_cont: len=%d str=%s\n%!" (content_length body) str }}
433 if {{ contlen > 0 && len >= contlen }}
434 then
435 debug {{ Logger.debug "handle_simple_post_cont: bodylen=%d contlen=%d\n%s\n\n%!"
436 (content_length body) contlen (bodystr ~max_body:_runtime.rt_core.rt_plim ~escaped:true body) }}
437 {{ if len <> contlen then Logger.warning "Warning: content length and post body length mismatch" else () }}
438 let post = {{ Simple (uri, headers, body) }}
439 let res = !"handle_simple_post_cont"<< _runtime.rt_post sched _runtime request_type hr post conn >>
440 debug 2 {{ Logger.debug "handle_simple_post_cont: back from rt_post\n%!" }}
441 send_res(res, hr, request_type, headers, {{ Some post }})
442 else
443 handle_simple_post(request_type, uri, headers, hr, body, len, contlen, timeout)
444
445 %% Handling ( x-www-form-urlencoded )
446 handle_simple_post(request_type, uri, headers, hr, body, len, contlen, timeout):
447 debug 10 {{ Logger.debug "handle_simple_post: uri=%s contlen=%d\n%!" uri contlen }}
448 let _runtime = {{ set_payload _runtime ((sprintf "FIXED:%d" contlen),headers) }}
449 fixed {{ contlen }}
450 | data ->
451 debug {{ Logger.debug "handle_simple_post: data='%s'\n%!" (String.escaped data) }}
452 handle_simple_post_cont(request_type, uri, headers, hr, body, len, contlen, timeout, {{ data }})
453 catch | exn -> exnerr ({{"handle_simple_post"}}, {{ None }}, exn,
454 {{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
455 after timeout -> timeouterr ({{"handle_simple_post"}}, {{ None }})
456
457
458 %% Handling ( multipart/form-data )
459 handle_multipart(request_type, uri, headers, hr, boundary, contlen, timeout):
460 debug 10 {{ Logger.debug "handle_multipart: uri=%s\n%!" uri }}
461 let req = {{ { uri = uri ; request_headers = headers ; request_body = [] ; tmpfiles = [] } }}
462 receive
463 | Boundary bound when {{ bound = boundary }} ->
464 read_mime(request_type, req, hr, bound, {{ [] }}, contlen, timeout)
465 | e ->
466 {{ Logger.error "HttpServerCore.handle_multipart: bad boundary %s" (string_of_msg e) }}
467 close_connection_req({{"bad_boundary"}},{{Some req}})
468 catch | exn -> exnerr ({{"handle_multipart"}}, {{ Some req }}, exn,
469 {{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
470 after timeout -> timeouterr ({{"handle_multipart"}}, {{ Some req }})
471
472
473 read_mime(request_type, req, hr, bound, mime_list, contlen, timeout):
474 debug 10 {{ Logger.debug "read_mime: req.uri=%s\n%!" req.uri }}
475 receive
476 | Crlf ->
477 debug {{ Logger.debug "read_mime: Crlf\n%!" }}
478 begin
479 match {{ List.find_opt (function Content_Disposition _ -> true | _ -> false) mime_list }} with
480 | Some content_disposition ->
481 let content = {{ parse_content_disposition content_disposition }}
482 debug {{ Logger.debug "read_mime: content=%s\n%!"
483 (String.sconcat ~left:"[" ~right:"]" "; " (List.map (fun (a,b) -> a^"->"^b) content)) }}
484 if {{ List.mem_assoc "filename" content }}
485 then read_multipart_body(request_type, req, hr, bound, mime_list, {{ content_make CT_FILE ~hint:contlen }},
486 0, contlen, timeout)
487 else read_multipart_body(request_type, req, hr, bound, mime_list, {{ content_make CT_STRING ~hint:contlen }},
488 0, contlen, timeout)
489 | None ->
490 debug {{ Logger.debug "read_mime: No content disposition.\n%!" }}
491 read_multipart_body(request_type, req, hr, bound, mime_list, {{ content_make CT_STRING ~hint:contlen }},
492 0, contlen, timeout)
493 ;
494 end
495 | mime ->
496 debug {{ Logger.debug "read_mime: mime=%s\n%!" (String.escaped (string_of_msg mime)) }}
497 read_mime(request_type, req, hr, bound, {{ mime :: mime_list }}, contlen, timeout)
498 catch | exn -> exnerr ({{"read_mime"}}, {{ Some req }}, exn,
499 {{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
500 after timeout -> timeouterr ({{"read_mime"}}, {{ Some req }})
501
502
503 read_multipart_body(request_type, req, hr, bound, mime_list, acc, _len, contlen, timeout):
504 debug 10 {{ Logger.debug "read_multipart_body: req.uri=%s\n%!" req.uri }}
505 let _runtime = {{ set_payload_string _runtime ("UPTO:--"^bound) }}
506 upto {{ "\r\n--"^bound }}
507 | data ->
508 debug {{ Logger.debug "read_multipart_body: data='%s'\n%!" (String.limit 100 (String.escaped data)) }}
509 read_multipart_body2(request_type, req, hr, bound, mime_list, acc, _len, contlen, timeout, data)
510 catch | exn -> exnerr ({{"read_multipart_body"}}, {{ Some req }}, exn,
511 {{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
512 after timeout -> timeouterr ({{"read_multipart_body"}}, {{ Some req }})
513
514 read_multipart_body2(request_type, req, hr, bound, mime_list, acc, _len, contlen, timeout, data):
515 let _runtime = {{ set_payload_string _runtime "FIXED:4" }}
516 fixed {{ 4 }}
517 | mm ->
518 debug {{ Logger.debug "read_multipart_body: mm='%s'\n%!" (String.escaped mm) }}
519 if {{ mm = "--\r\n" }}
520 then
521 let content = {{ content_add data acc }}
522 debug {{ Logger.debug "read_multipart_body: EndBoundary(hdrs:%d,len:%d) '%s'\n%!"
523 (List.length mime_list) (content_length content) bound }}
524 let new_req = {{ { req with request_body = (mime_list, content) :: req.request_body } }}
525 let post = {{ Multipart new_req }}
526 let res = !"read_multipart_body2"<< _runtime.rt_post sched _runtime request_type hr post conn >>
527 send_res(res, hr, request_type, {{ req.request_headers }}, {{ Some post }})
528 else
529 !"read_multipart_body2"[[
530 if mm.[0] = '\r' && mm.[1] = '\n'
531 then HttpTools.putback2 (String.sub mm 2 2) _mailbox
532 else HttpTools.putback2 mm _mailbox
533 ]]
534 let content = {{ content_add data acc }}
535 debug {{ Logger.debug "read_multipart_body: Boundary(hdrs:%d,len:%d) '%s'\n%!"
536 (List.length mime_list) (content_length content) bound }}
537 let new_req = {{ { req with request_body = (mime_list, content) :: req.request_body } }}
538 read_mime(request_type, new_req, hr, bound, {{ [] }}, contlen, timeout)
539 catch | exn -> exnerr ({{"read_multipart_body2"}}, {{ Some req }}, exn,
540 {{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
541 after timeout -> timeouterr ({{"read_multipart_body2"}}, {{ Some req }})
Something went wrong with that request. Please try again.