httpServerCore.proto

% -*-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 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 = Printf.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 (Printf.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.slice ';' 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 ((Printf.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 }})