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