Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

542 lines (498 sloc) 26.215 kB
% -*-erlang-*-
%
% Copyright © 2011 MLstate
%
% This file is part of OPA.
%
% OPA is free software: you can redistribute it and/or modify it under the
% terms of the GNU Affero General Public License, version 3, as published by
% the Free Software Foundation.
%
% OPA is distributed in the hope that it will be useful, but WITHOUT ANY
% WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
% FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
% more details.
%
% You should have received a copy of the GNU Affero General Public License
% along with OPA. If not, see <http://www.gnu.org/licenses/>.
%
-generate server
-debugvar PROTOCOL_DEBUG
-protocol HTTP
-open Base
-open Rcontent
-open HttpTools
-open HttpServerTypes
% This will have to wait...
% ...because we can't put these in the interface.
%-modalias HT = HttpTools
%-modalias HST = HttpServerTypes
%-modalias S = String
% This will be for the raw parser
%-include "libnet/httpMessages.proto"
-include "libnet/http_messages.proto"
-include "libnet/http_rr.proto"
-define Crlf = "\r\n"
-define EndBoundary b = "--" !"\r\n" b "--\r\n"
-define Boundary b = "--" b "\r\n"
-define Partial str = str "\r\n"
-define Body str = str
-type rt_core =
{
rt_pre_headers : handle_request -> msg -> header list -> (handle_request * header list);
rt_post_headers : handle_request -> msg -> header list -> header list -> (handle_request * header list * bool);
rt_server_send_buffer_size : int;
rt_server_wait_for_request_timeout : Time.t;
rt_server_wait_for_request_initial_timeout : Time.t;
rt_maximum_number_of_connections : int;
rt_maximum_content_length : int;
rt_maximum_number_of_headers : int;
rt_log_accesses : bool;
rt_time_diff : string;
rt_plim : int;
}
-type body_value = string * content * Time.t * string
-type rt_server =
{
mutable rt_dialog_content : HttpDialog.t;
rt_dialog_name : string;
rt_server_name : string;
rt_on_run : Scheduler.t -> unit;
rt_on_close : Scheduler.t -> unit;
rt_favicon_ico : body_value;
rt_favicon_gif : body_value;
}
-type payload = string * (header list)
-include "libnet/rt_proto.proto"
-type rt_tmp =
{
rt_hr : handle_request;
rt_conn : int;
rt_callback : (payload -> int -> Buffer.t -> bool) option;
}
%TODO: parse this: rt_callback : (?payload:(header list) -> (int * Buffer.t) -> bool) option;
-type runtime =
{
rt_get : Scheduler.t -> runtime -> msg -> handle_request -> get
-> Scheduler.connection_info -> (response -> unit) -> unit;
rt_post : Scheduler.t -> runtime -> msg -> handle_request -> post
-> Scheduler.connection_info -> (response -> unit) -> unit;
rt_tmp : rt_tmp;
rt_server : rt_server;
rt_proto : rt_proto;
rt_core : rt_core;
}
-val allowed_hosts : string list ref
-val http_version_number : string
-val http_version : string
-val make_status : int -> string -> msg
-val get_response : msg -> msg list -> content -> string
-val server_name : string
-val request_type_http_version : msg -> string
-val request_type_uri : msg -> string
-val parse_content_disposition : msg -> (string * string) list
-val unallocate_request : request -> unit
-val unallocate_response : response -> unit
-val null_payload : payload
{{
let allowed_hosts = ref []
let http_version_number = "1.1"
let http_version = "HTTP/"^http_version_number
let make_status code msg = Sl (http_version_number, code, msg)
let get_response sl headers content =
(string_of_msg sl)^(List.fold_left (fun s h -> s^(string_of_msg h)) "" headers)^crlf^(get_content content)
let version = string_of_int BuildInfos.git_version_counter
let server_name = sprintf "OPA/%s" version
let headerstr headers = List.fold_left (fun s h -> s^(string_of_msg h)) "" headers
let request_type_http_version = function
| Get (_,v) -> v
| Head (_,v) -> v
| Post (_,v) -> v
| Put (_,v) -> v
| Del (_,v) -> v
| Trace (_,v) -> v
| Conn (_,v) -> v
| _ -> "1.0"
let request_type_uri = function
| Get (uri,_) -> uri
| Head (uri,_) -> uri
| Post (uri,_) -> uri
| Put (uri,_) -> uri
| Del (uri,_) -> uri
| Trace (uri,_) -> uri
| Conn (uri,_) -> uri
| msg -> raise (Failure (sprintf "request_type_uri: %s not a request type" (string_of_msg msg)))
let parse_content_disposition = function
| Content_Disposition (s,l) -> List.map (fun s -> rmldtrsp2 (Base.String.split_char '=' s)) (s::l)
| _ -> failwith "Not implemented yet."
let unallocate_request req =
content_unallocate req.request_message_body;
List.iter (fun (_,content) -> content_unallocate content) req.request_post_body
let unallocate_response res = content_unallocate res.body
let unallocate_mpr mpr = List.iter (fun (_,content) -> content_unallocate content) mpr.request_body
let unallocate_post = function
| Simple (_,_,body) -> content_unallocate body
| Multipart mpr -> unallocate_mpr mpr
let buffer_of_response sl headers body =
let b = HttpTools.get_buf ~hint:(4096+content_length body) () in
(*let b = OBuffer.create (4096+content_length body) in*)
Buffer.add_string b (string_of_msg sl);
List.iter (fun h -> Buffer.add_string b (string_of_msg h)) headers;
Buffer.add_string b "\r\n";
Buffer.add_string b (get_content body);
b
(*let content_of_response sl headers body =
let c = content_make ~hint:(4096+content_length body) (get_content_type body) in
let c = content_add (string_of_msg sl) c in
let c = List.fold_left (fun c h -> content_add (string_of_msg h) c) c headers in
let c = content_add "\r\n" c in
content_add_content c body*)
let conn_no = ref 0
let null_payload = ("",[])
let http_server_callback runtime (buf,pos_ref) =
match runtime.rt_tmp.rt_callback with
| Some cb -> cb runtime.rt_proto.rt_payload !pos_ref buf
| None -> true
let split_cookie str =
List.map (fun x -> let a, b = String.split_char '=' x in ((String.trim a), b)) (String.split ((=) ';') str)
}}
% FIXME: parse this...
% referer ==> ref (erer) !!!
% FIXME: ordering problems with toplevel ocaml !!!
[[
let access_log runtime request_line response =
if runtime.rt_core.rt_log_accesses
then
let host = runtime.rt_tmp.rt_hr.hr_inet_addr_str in
let _method = String.trim (string_of_msg request_line) in
let status = match response.sl with | Sl (_,code,_) -> string_of_int code | _ -> "-" in
let bytes = content_length response.body in
let ua = runtime.rt_tmp.rt_hr.hr_user_agent in
let referer = runtime.rt_tmp.rt_hr.hr_referer in
(* Combined log format (apparently) *)
Logger.log_access "%s - - [%s] \"%s\" %s %d %s %s" host !current_time_string _method status bytes referer ua
else ()
let get_payload runtime = runtime.rt_proto.rt_payload
let set_payload runtime payload = { runtime with rt_proto={ runtime.rt_proto with rt_payload=payload; }; }
let set_payload_string runtime str = set_payload runtime ((fun (_,hdrs) -> (str,hdrs)) (get_payload runtime))
]]
%TODO: abort log once access log optimizations are official
%%%%%%%%%%%%%%%%%%%%%%%%%
%% Handy functions %%
%%%%%%%%%%%%%%%%%%%%%%%%%
close_connection(_fn):
debug {{ Logger.debug "close_connection(%d,%s)\n%!" _runtime.rt_tmp.rt_conn _fn }}
-!-
close_connection_req(fn, req_opt):
{{ match req_opt with Some req -> unallocate_mpr req | None -> () }}
close_connection(fn)
callback_abort(fn, req_opt):
debug {{ Logger.debug "HttpServerCore.%s: Callback abort" fn }}
close_connection_req({{fn^"(abort)"}}, req_opt)
exnerr(fn, req_opt, exn, bt_opt):
if {{ exn = CallbackAbort }}
then
callback_abort(fn, req_opt)
else
{{ Logger.error "HttpServerCore.%s: exn=%s" fn (Printexc.to_string exn) }}
{{ Option.iter (fun bt -> Logger.debug "%s" bt) bt_opt }}
close_connection_req(fn, req_opt)
timeouterr(fn, req_opt):
{{ Logger.error "HttpServerCore.%s: Timeout" fn }}
close_connection_req(fn, req_opt)
bad_request(request_type):
{{ Logger.error "HttpServerCore.bad_request: %s" (string_of_msg request_type) }}
let p = {{ "<html><head><title>Error - Bad Request</title></head><body>Error 400 - Bad Request</body></html>" }}
let content_length = {{ Int64.of_int (String.length p) }}
let headers = {{ [ (Content_Length content_length); (Connection "close") ] }}
let sl = {{ Sl (http_version_number, 400, "Bad Request") }}
let body = {{ ContentString p }}
let res = {{ { sl=sl; headers=headers; body=body } }}
!"access_log"{{ access_log _runtime request_type res }}
let buf = {{ buffer_of_response res.sl headers res.body }}
send_buf {{ Buffer.contents buf }}
{{ HttpTools.free_buf buf }}
close_connection({{"bad_request"}})
send_res(res:response, hr, request_type, headers_in, post_opt):
debug 10 {{ Logger.debug "send_res\n%!" }}
match !"send_res" {{ _runtime.rt_core.rt_post_headers hr request_type headers_in res.headers }} with
| (hr,headers_out,close) ->
debug {{ Logger.debug "\n\nResponse:\n%s%s\r\n%s\n\n%!"
(string_of_msg res.sl) (headerstr headers_out)
(bodystr ~max_body:_runtime.rt_core.rt_plim ~escaped:true res.body) }}
% FIXME: Temporary and drastic fix for interleaved outgoing messages
!"access_log"{{ access_log _runtime request_type res }}
let buf = {{ buffer_of_response res.sl headers_out res.body }}
send_buf {{ Buffer.contents buf }}
{{ HttpTools.free_buf buf }}
send_res_cont(hr, close, res, post_opt)
send_res_cont(hr, close, res, post_opt):
debug {{ Logger.debug "Req-Resp time: %f\n%!"
(Time.in_seconds (Time.difference _runtime.rt_tmp.rt_hr.hr_timestamp (Time.now()))) }}
{{ match post_opt with Some post -> unallocate_post post | None -> () }}
{{ unallocate_response res }}
if {{ close }}
then
debug 10 {{ Logger.debug "send_res: closing connection\n%!" }}
close_connection({{"close_requested_by_client"}})
else
debug 10 {{ Logger.debug "send_res: keeping connection\n%!" }}
{{ HttpTools.buf_clean _mailbox }}
wait_for_request(hr, {{ _runtime.rt_core.rt_server_wait_for_request_timeout }})
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%% General states %%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+on_connection(hr : handle_request):
%release {{ Logger.debug "Release version\n%!" }}
{{ incr Cookie2.cookie_connection_count }}
{{ incr CookieLong.cookie_connection_count }}
let inet_addr_str = {{ Unix.string_of_inet_addr (Scheduler.get_connection_inet_addr conn) }}
let hr = {{ { hr with hr_inet_addr_str = inet_addr_str; } }}
let _runtime = [[ incr conn_no; { _runtime with rt_tmp = { _runtime.rt_tmp with rt_conn = (!conn_no); rt_hr = hr; } } ]]
{{ if _runtime.rt_proto.rt_backtrace then Printexc.record_backtrace true }}
debug {{ Logger.debug "on_connection(%d)\n%!" (!number_of_connections) }}
let is_secure = {{ NetAddr.get_type (Scheduler.get_connection_addr conn) = NetAddr.SSL }}
let hr = {{ { hr with hr_is_secure = is_secure; } }}
wait_for_request(hr, {{ _runtime.rt_core.rt_server_wait_for_request_initial_timeout }})
wait_for_request(hr, timeout):
debug 10 {{ Logger.debug "wait_for_request\n%!" }}
let _runtime = {{ set_payload _runtime ("WAIT",[]) }}
receive
| Crlf ->
% Blank lines before a request are allowed
wait_for_request(hr, timeout)
| Head (uri, v) ->
wait_for_headers0(uri, {{ [] }}, hr, {{ Head (uri,v) }}, {{ -1 }}, 0, timeout)
| Get (uri, v) ->
wait_for_headers0(uri, {{ [] }}, hr, {{ Get (uri,v) }}, {{ -1 }}, 0, timeout)
| Post (uri, v) ->
wait_for_headers0(uri, {{ [] }}, hr, {{ Post (uri,v) }}, {{ -1 }}, 0, timeout)
% If we get a secure connection on a non-secure server we get lots of rubbish here
% so we only respond with a bad request if it is actually a request.
| Put (uri, v) -> bad_request({{ Put (uri,v) }})
| Del (uri, v) -> bad_request({{ Del (uri,v) }})
| Trace (uri, v) -> bad_request({{ Trace (uri,v) }})
| Conn (uri, v) -> bad_request({{ Conn (uri,v) }})
| msg ->
let amount_of_rubbish = {{ String.length (string_of_msg msg) }}
{{ Logger.error "HttpServerCore.wait_for_request: bad request (%d bytes of rubbish)" amount_of_rubbish }}
close_connection({{"rubbish_on_request"}})
catch
| exn ->
if {{ exn = Scheduler.Connection_closed }}
then
close_connection({{"closed_by_client"}})
else
exnerr ({{"wait_for_request_exception"}}, {{ None }}, exn,
{{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
after timeout -> close_connection_req ({{"wait_for_request"}}, {{ None }})
wait_for_headers0(uri, headers, hr, request_type, contlen, hdrcnt, timeout):
debug 10 {{ Logger.debug "wait_for_headers: %s\n%!" (string_of_msg request_type) }}
let tm = {{ Time.now () }}
let hr = {{ { hr with hr_timestamp = tm; hr_timestamp_tm = Time.localtime tm;
hr_user_agent = ""; hr_referer = ""; hr_ec = ""; hr_ic = ""; } }}
let _runtime = [[ { _runtime with rt_tmp = { _runtime.rt_tmp with rt_hr = hr } } ]]
wait_for_headers(uri, headers, hr, request_type, contlen, hdrcnt, timeout)
wait_for_headers(uri, headers, hr, request_type, contlen, hdrcnt, timeout):
if {{ hdrcnt > _runtime.rt_core.rt_maximum_number_of_headers }}
then
{{ Logger.error "HttpServerCore.wait_for_headers: Maximum number of headers exceeded" }}
close_connection({{"max_headers_exceeded"}})
else
receive
| Crlf ->
begin
match !"wait_for_headers"{{ _runtime.rt_core.rt_pre_headers hr request_type headers }} with
| (hr,headers) ->
begin
debug {{ Logger.debug "\n\nRequest:\n%s%s\r\n%!" (string_of_msg request_type) (headerstr headers) }}
match {{ request_type }} with
| Head _ -> handle_get(request_type, uri, headers, hr)
| Get _ -> handle_get(request_type, uri, headers, hr)
| Post _ -> handle_post(request_type, contlen, uri, headers, hr, timeout)
| rt -> bad_request(rt)
;
end
end
| Content_Length l ->
let contlen = {{ Int64.to_int l }}
if {{ contlen > _runtime.rt_core.rt_maximum_content_length }}
then
{{ Logger.error "Content length exceeds maximum (%d,%d)\n%!" contlen _runtime.rt_core.rt_maximum_content_length }}
close_connection({{"content_length_exceeded"}})
else
debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg (Content_Length l)) }}
wait_for_headers(uri, {{ (Content_Length l)::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
| User_Agent ua ->
debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg (User_Agent ua)) }}
let hr = {{ { hr with hr_user_agent = ua; } }}
let _runtime = [[ { _runtime with rt_tmp = { _runtime.rt_tmp with rt_hr = hr } } ]]
wait_for_headers(uri, {{ (User_Agent ua)::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
| Referer rf ->
debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg (Referer rf)) }}
let hr = {{ { hr with hr_referer = rf; } }}
let _runtime = [[ { _runtime with rt_tmp = { _runtime.rt_tmp with rt_hr = hr } } ]]
wait_for_headers(uri, {{ (Referer rf)::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
| Cookie str ->
debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg (Cookie str)) }}
let hr = {{ List.fold_left (fun hr -> function
| ("ec",str) -> { hr with hr_ec = str }
| ("ic",str) -> { hr with hr_ic = str }
| _ -> hr) hr (Cookie2.split_cookie str) }}
let _runtime = [[ { _runtime with rt_tmp = { _runtime.rt_tmp with rt_hr = hr } } ]]
wait_for_headers(uri, {{ (Cookie str)::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
| header ->
debug {{ Logger.debug "wait_for_headers: msg=%s\n%!" (string_of_msg header) }}
wait_for_headers(uri, {{ header::headers }}, hr, request_type, contlen, {{hdrcnt+1}}, timeout)
catch | exn -> exnerr ({{"wait_for_headers"}}, {{ None }}, exn,
{{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
after timeout -> timeouterr ({{"wait_for_headers"}}, {{ None }})
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%% Handling GET and HEAD requests %%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
handle_get(request_type, uri, headers, hr):
let _runtime = {{ set_payload _runtime ("GET",headers) }}
if {{ http_server_callback _runtime _mailbox }}
then
debug {{ Logger.debug "handle_get: uri=%s\n%!" uri }}
let res = !"handle_get"<< _runtime.rt_get sched _runtime request_type hr (uri, headers) conn >>
send_res(res, hr, request_type, headers, None)
else callback_abort({{"handle_get"}}, {{None}})
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%% Handling POST requests %%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
handle_post(request_type, contlen, uri, headers, hr, timeout):
debug 10 {{ Logger.debug "handle_post: uri=%s contlen=%d\n%!" uri contlen }}
let _runtime = {{ set_payload _runtime ("POST",headers) }}
if {{ http_server_callback _runtime _mailbox }}
then
let is_ct = {{ function Content_Type _ -> true | _ -> false }}
if {{ not (List.exists is_ct headers) }} then
handle_simple_post0(request_type, uri, headers, hr, {{ content_make CT_BUFFER ~hint:contlen }}, {{ 0 }}, contlen, timeout)
else
let fields = {{ (function Content_Type (s,lst) -> s::lst | _ -> assert false) (List.find is_ct headers) }}
debug {{ Logger.debug "handle_post: fields=%s\n%!" (String.sconcat ~left:"[" ~right:"]" "," fields) }}
if {{ not (List.mem "multipart/form-data" fields) }} then
handle_simple_post0(request_type, uri, headers, hr, {{ content_make CT_BUFFER ~hint:contlen }},
{{ 0 }}, contlen, timeout)
else
let b = !"handle_post(missing boundary)"{{ List.find (fun s -> String.is_substring " boundary=" s 0) fields }}
let boundary = !"handle_post(bad boundary)"{{ String.sub b 10 (String.length b - 10) }}
debug {{ Logger.debug "handle_post: boundary='%s'\n%!" boundary }}
handle_multipart(request_type, uri, headers, hr, boundary, contlen, timeout)
else callback_abort({{"handle_post"}}, {{None}})
handle_simple_post0(request_type, uri, headers, hr, body, len, contlen, timeout):
if {{ contlen = 0 }}
then
debug {{ Logger.debug "HttpServerCore.handle_simple_post0: contlen=0" }}
let post = {{ Simple (uri, headers, ContentNone) }}
let res = !"handle_simple_post0"<< _runtime.rt_post sched _runtime request_type hr post conn >>
debug 2 {{ Logger.debug "handle_simple_post0: back from rt_post\n%!" }}
send_res(res, hr, request_type, headers, {{ Some post }})
else
handle_simple_post(request_type, uri, headers, hr, body, len, contlen, timeout)
handle_simple_post_cont(request_type, uri, headers, hr, body, len, contlen, timeout, str):
let body = {{ content_add str body }}
let len = {{ len + (String.length str) }}
debug {{ Logger.debug "handle_simple_post_cont: len=%d str=%s\n%!" (content_length body) str }}
if {{ contlen > 0 && len >= contlen }}
then
debug {{ Logger.debug "handle_simple_post_cont: bodylen=%d contlen=%d\n%s\n\n%!"
(content_length body) contlen (bodystr ~max_body:_runtime.rt_core.rt_plim ~escaped:true body) }}
{{ if len <> contlen then Logger.warning "Warning: content length and post body length mismatch" else () }}
let post = {{ Simple (uri, headers, body) }}
let res = !"handle_simple_post_cont"<< _runtime.rt_post sched _runtime request_type hr post conn >>
debug 2 {{ Logger.debug "handle_simple_post_cont: back from rt_post\n%!" }}
send_res(res, hr, request_type, headers, {{ Some post }})
else
handle_simple_post(request_type, uri, headers, hr, body, len, contlen, timeout)
%% Handling ( x-www-form-urlencoded )
handle_simple_post(request_type, uri, headers, hr, body, len, contlen, timeout):
debug 10 {{ Logger.debug "handle_simple_post: uri=%s contlen=%d\n%!" uri contlen }}
let _runtime = {{ set_payload _runtime ((sprintf "FIXED:%d" contlen),headers) }}
fixed {{ contlen }}
| data ->
debug {{ Logger.debug "handle_simple_post: data='%s'\n%!" (String.escaped data) }}
handle_simple_post_cont(request_type, uri, headers, hr, body, len, contlen, timeout, {{ data }})
catch | exn -> exnerr ({{"handle_simple_post"}}, {{ None }}, exn,
{{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
after timeout -> timeouterr ({{"handle_simple_post"}}, {{ None }})
%% Handling ( multipart/form-data )
handle_multipart(request_type, uri, headers, hr, boundary, contlen, timeout):
debug 10 {{ Logger.debug "handle_multipart: uri=%s\n%!" uri }}
let req = {{ { uri = uri ; request_headers = headers ; request_body = [] ; tmpfiles = [] } }}
receive
| Boundary bound when {{ bound = boundary }} ->
read_mime(request_type, req, hr, bound, {{ [] }}, contlen, timeout)
| e ->
{{ Logger.error "HttpServerCore.handle_multipart: bad boundary %s" (string_of_msg e) }}
close_connection_req({{"bad_boundary"}},{{Some req}})
catch | exn -> exnerr ({{"handle_multipart"}}, {{ Some req }}, exn,
{{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
after timeout -> timeouterr ({{"handle_multipart"}}, {{ Some req }})
read_mime(request_type, req, hr, bound, mime_list, contlen, timeout):
debug 10 {{ Logger.debug "read_mime: req.uri=%s\n%!" req.uri }}
receive
| Crlf ->
debug {{ Logger.debug "read_mime: Crlf\n%!" }}
begin
match {{ List.find_opt (function Content_Disposition _ -> true | _ -> false) mime_list }} with
| Some content_disposition ->
let content = {{ parse_content_disposition content_disposition }}
debug {{ Logger.debug "read_mime: content=%s\n%!"
(String.sconcat ~left:"[" ~right:"]" "; " (List.map (fun (a,b) -> a^"->"^b) content)) }}
if {{ List.mem_assoc "filename" content }}
then read_multipart_body(request_type, req, hr, bound, mime_list, {{ content_make CT_FILE ~hint:contlen }},
0, contlen, timeout)
else read_multipart_body(request_type, req, hr, bound, mime_list, {{ content_make CT_STRING ~hint:contlen }},
0, contlen, timeout)
| None ->
debug {{ Logger.debug "read_mime: No content disposition.\n%!" }}
read_multipart_body(request_type, req, hr, bound, mime_list, {{ content_make CT_STRING ~hint:contlen }},
0, contlen, timeout)
;
end
| mime ->
debug {{ Logger.debug "read_mime: mime=%s\n%!" (String.escaped (string_of_msg mime)) }}
read_mime(request_type, req, hr, bound, {{ mime :: mime_list }}, contlen, timeout)
catch | exn -> exnerr ({{"read_mime"}}, {{ Some req }}, exn,
{{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
after timeout -> timeouterr ({{"read_mime"}}, {{ Some req }})
read_multipart_body(request_type, req, hr, bound, mime_list, acc, _len, contlen, timeout):
debug 10 {{ Logger.debug "read_multipart_body: req.uri=%s\n%!" req.uri }}
let _runtime = {{ set_payload_string _runtime ("UPTO:--"^bound) }}
upto {{ "\r\n--"^bound }}
| data ->
debug {{ Logger.debug "read_multipart_body: data='%s'\n%!" (String.limit 100 (String.escaped data)) }}
read_multipart_body2(request_type, req, hr, bound, mime_list, acc, _len, contlen, timeout, data)
catch | exn -> exnerr ({{"read_multipart_body"}}, {{ Some req }}, exn,
{{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
after timeout -> timeouterr ({{"read_multipart_body"}}, {{ Some req }})
read_multipart_body2(request_type, req, hr, bound, mime_list, acc, _len, contlen, timeout, data):
let _runtime = {{ set_payload_string _runtime "FIXED:4" }}
fixed {{ 4 }}
| mm ->
debug {{ Logger.debug "read_multipart_body: mm='%s'\n%!" (String.escaped mm) }}
if {{ mm = "--\r\n" }}
then
let content = {{ content_add data acc }}
debug {{ Logger.debug "read_multipart_body: EndBoundary(hdrs:%d,len:%d) '%s'\n%!"
(List.length mime_list) (content_length content) bound }}
let new_req = {{ { req with request_body = (mime_list, content) :: req.request_body } }}
let post = {{ Multipart new_req }}
let res = !"read_multipart_body2"<< _runtime.rt_post sched _runtime request_type hr post conn >>
send_res(res, hr, request_type, {{ req.request_headers }}, {{ Some post }})
else
!"read_multipart_body2"[[
if mm.[0] = '\r' && mm.[1] = '\n'
then HttpTools.putback2 (String.sub mm 2 2) _mailbox
else HttpTools.putback2 mm _mailbox
]]
let content = {{ content_add data acc }}
debug {{ Logger.debug "read_multipart_body: Boundary(hdrs:%d,len:%d) '%s'\n%!"
(List.length mime_list) (content_length content) bound }}
let new_req = {{ { req with request_body = (mime_list, content) :: req.request_body } }}
read_mime(request_type, new_req, hr, bound, {{ [] }}, contlen, timeout)
catch | exn -> exnerr ({{"read_multipart_body2"}}, {{ Some req }}, exn,
{{ if _runtime.rt_proto.rt_backtrace then (Some (Printexc.get_backtrace())) else None }})
after timeout -> timeouterr ({{"read_multipart_body2"}}, {{ Some req }})
Jump to Line
Something went wrong with that request. Please try again.