279 lines
11 KiB
OCaml
279 lines
11 KiB
OCaml
|
(*----------------------------------------------------------------------------
|
||
|
|
Copyright (c) 2017 Inhabited Type LLC.
|
||
|
|
|
||
|
|
All rights reserved.
|
||
|
|
|
||
|
|
Redistribution and use in source and binary forms, with or without
|
||
|
|
modification, are permitted provided that the following conditions
|
||
|
|
are met:
|
||
|
|
|
||
|
|
1. Redistributions of source code must retain the above copyright
|
||
|
|
notice, this list of conditions and the following disclaimer.
|
||
|
|
|
||
|
|
2. Redistributions in binary form must reproduce the above copyright
|
||
|
|
notice, this list of conditions and the following disclaimer in the
|
||
|
|
documentation and/or other materials provided with the distribution.
|
||
|
|
|
||
|
|
3. Neither the name of the author nor the names of his contributors
|
||
|
|
may be used to endorse or promote products derived from this software
|
||
|
|
without specific prior written permission.
|
||
|
|
|
||
|
|
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
|
||
|
|
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||
|
|
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||
|
|
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
|
||
|
|
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||
|
|
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||
|
|
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||
|
|
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||
|
|
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||
|
|
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||
|
|
POSSIBILITY OF SUCH DAMAGE.
|
||
|
|
----------------------------------------------------------------------------*)
|
||
|
|
|
||
|
|
type error =
|
||
|
|
[ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ]
|
||
|
|
|
||
|
|
type error_handler =
|
||
|
|
?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
|
||
|
|
|
||
|
|
module Reader = Parse.Reader
|
||
|
|
module Writer = Serialize.Writer
|
||
|
|
|
||
|
|
(* XXX(seliopou): The current design assumes that a new [Reqd.t] will be
|
||
|
|
* allocated for each new request/response on a connection. This is wasteful,
|
||
|
|
* as it creates garbage on persistent connections. A better approach would be
|
||
|
|
* to allocate a single [Reqd.t] per connection and reuse it across
|
||
|
|
* request/responses. This would allow a single [Faraday.t] to be allocated for
|
||
|
|
* the body and reused. The [response_state] type could then be inlined into
|
||
|
|
* the [Reqd.t] record, with dummy values occuping the fields for [response].
|
||
|
|
* Something like this:
|
||
|
|
*
|
||
|
|
* {[
|
||
|
|
* type 'handle t =
|
||
|
|
* { mutable request : Request.t
|
||
|
|
* ; mutable request_body : Response.Body.Reader.t
|
||
|
|
* ; mutable response : Response.t (* Starts off as a dummy value,
|
||
|
|
* * using [(==)] to identify it when
|
||
|
|
* * necessary *)
|
||
|
|
* ; mutable response_body : Response.Body.Writer.t
|
||
|
|
* ; mutable persistent : bool
|
||
|
|
* ; mutable response_state : [ `Waiting | `Started | `Streaming ]
|
||
|
|
* }
|
||
|
|
* ]}
|
||
|
|
*
|
||
|
|
* *)
|
||
|
|
type t =
|
||
|
|
{ request : Request.t
|
||
|
|
; request_body : Body.Reader.t
|
||
|
|
; reader : Reader.request
|
||
|
|
; writer : Writer.t
|
||
|
|
; response_body_buffer : Bigstringaf.t
|
||
|
|
; error_handler : error_handler
|
||
|
|
; mutable persistent : bool
|
||
|
|
; mutable response_state : Response_state.t
|
||
|
|
; mutable error_code : [`Ok | error ]
|
||
|
|
}
|
||
|
|
|
||
|
|
let create error_handler request request_body reader writer response_body_buffer =
|
||
|
|
{ request
|
||
|
|
; request_body
|
||
|
|
; reader
|
||
|
|
; writer
|
||
|
|
; response_body_buffer
|
||
|
|
; error_handler
|
||
|
|
; persistent = Request.persistent_connection request
|
||
|
|
; response_state = Waiting
|
||
|
|
; error_code = `Ok
|
||
|
|
}
|
||
|
|
|
||
|
|
let request { request; _ } = request
|
||
|
|
let request_body { request_body; _ } = request_body
|
||
|
|
|
||
|
|
let response { response_state; _ } =
|
||
|
|
match response_state with
|
||
|
|
| Waiting -> None
|
||
|
|
| Streaming (response, _)
|
||
|
|
| Fixed response
|
||
|
|
| Upgrade (response, _) -> Some response
|
||
|
|
|
||
|
|
let response_exn { response_state; _ } =
|
||
|
|
match response_state with
|
||
|
|
| Waiting -> failwith "httpun.Reqd.response_exn: response has not started"
|
||
|
|
| Streaming(response, _)
|
||
|
|
| Fixed response
|
||
|
|
| Upgrade (response, _) -> response
|
||
|
|
|
||
|
|
let respond_with_string t response str =
|
||
|
|
if t.error_code <> `Ok then
|
||
|
|
failwith "httpun.Reqd.respond_with_string: invalid state, currently handling error";
|
||
|
|
match t.response_state with
|
||
|
|
| Waiting ->
|
||
|
|
(* XXX(seliopou): check response body length *)
|
||
|
|
Writer.write_response t.writer response;
|
||
|
|
Writer.write_string t.writer str;
|
||
|
|
if t.persistent then
|
||
|
|
t.persistent <- Response.persistent_connection response;
|
||
|
|
t.response_state <- Fixed response;
|
||
|
|
Writer.wakeup t.writer;
|
||
|
|
| Streaming _ | Upgrade _ ->
|
||
|
|
failwith "httpun.Reqd.respond_with_string: response already started"
|
||
|
|
| Fixed _ ->
|
||
|
|
failwith "httpun.Reqd.respond_with_string: response already complete"
|
||
|
|
|
||
|
|
let respond_with_bigstring t response (bstr:Bigstringaf.t) =
|
||
|
|
if t.error_code <> `Ok then
|
||
|
|
failwith "httpun.Reqd.respond_with_bigstring: invalid state, currently handling error";
|
||
|
|
match t.response_state with
|
||
|
|
| Waiting ->
|
||
|
|
(* XXX(seliopou): check response body length *)
|
||
|
|
Writer.write_response t.writer response;
|
||
|
|
Writer.schedule_bigstring t.writer bstr;
|
||
|
|
if t.persistent then
|
||
|
|
t.persistent <- Response.persistent_connection response;
|
||
|
|
t.response_state <- Fixed response;
|
||
|
|
Writer.wakeup t.writer;
|
||
|
|
| Streaming _ | Upgrade _ ->
|
||
|
|
failwith "httpun.Reqd.respond_with_bigstring: response already started"
|
||
|
|
| Fixed _ ->
|
||
|
|
failwith "httpun.Reqd.respond_with_bigstring: response already complete"
|
||
|
|
|
||
|
|
let unsafe_respond_with_streaming ~flush_headers_immediately t response =
|
||
|
|
match t.response_state with
|
||
|
|
| Waiting ->
|
||
|
|
let encoding =
|
||
|
|
match Response.body_length ~request_method:t.request.meth response with
|
||
|
|
| `Fixed _ | `Close_delimited | `Chunked as encoding -> encoding
|
||
|
|
| `Error (`Bad_gateway | `Internal_server_error) ->
|
||
|
|
failwith "httpun.Reqd.respond_with_streaming: invalid response body length"
|
||
|
|
in
|
||
|
|
let response_body =
|
||
|
|
Body.Writer.create
|
||
|
|
t.response_body_buffer
|
||
|
|
~encoding
|
||
|
|
~writer:t.writer
|
||
|
|
in
|
||
|
|
Writer.write_response t.writer response;
|
||
|
|
if t.persistent then
|
||
|
|
t.persistent <- Response.persistent_connection response;
|
||
|
|
t.response_state <- Streaming (response, response_body);
|
||
|
|
if flush_headers_immediately
|
||
|
|
then Writer.wakeup t.writer;
|
||
|
|
response_body
|
||
|
|
| Streaming _ | Upgrade _ ->
|
||
|
|
failwith "httpun.Reqd.respond_with_streaming: response already started"
|
||
|
|
| Fixed _ ->
|
||
|
|
failwith "httpun.Reqd.respond_with_streaming: response already complete"
|
||
|
|
|
||
|
|
let respond_with_streaming ?(flush_headers_immediately=false) t response =
|
||
|
|
if t.error_code <> `Ok then
|
||
|
|
failwith "httpun.Reqd.respond_with_streaming: invalid state, currently handling error";
|
||
|
|
unsafe_respond_with_streaming ~flush_headers_immediately t response
|
||
|
|
|
||
|
|
let unsafe_respond_with_upgrade t headers upgrade_handler =
|
||
|
|
match t.response_state with
|
||
|
|
| Waiting ->
|
||
|
|
let response = Response.create ~headers `Switching_protocols in
|
||
|
|
Writer.write_response t.writer response;
|
||
|
|
if t.persistent then
|
||
|
|
t.persistent <- Response.persistent_connection response;
|
||
|
|
t.response_state <- Upgrade (response, upgrade_handler);
|
||
|
|
Writer.flush t.writer (fun _reason ->
|
||
|
|
(* TODO(anmonteiro): probably need to check `Closed here? *)
|
||
|
|
upgrade_handler ());
|
||
|
|
Body.Reader.close t.request_body;
|
||
|
|
Writer.wakeup t.writer
|
||
|
|
| Streaming _ | Upgrade _ ->
|
||
|
|
failwith "httpun.Reqd.unsafe_respond_with_upgrade: response already started"
|
||
|
|
| Fixed _ ->
|
||
|
|
failwith "httpun.Reqd.unsafe_respond_with_upgrade: response already complete"
|
||
|
|
|
||
|
|
let respond_with_upgrade t response upgrade_handler =
|
||
|
|
if t.error_code <> `Ok then
|
||
|
|
failwith "httpun.Reqd.respond_with_streaming: invalid state, currently handling error";
|
||
|
|
unsafe_respond_with_upgrade t response upgrade_handler
|
||
|
|
|
||
|
|
let report_error t error =
|
||
|
|
t.persistent <- false;
|
||
|
|
match t.response_state, t.error_code with
|
||
|
|
| Waiting, `Ok ->
|
||
|
|
t.error_code <- (error :> [`Ok | error]);
|
||
|
|
let status =
|
||
|
|
match (error :> [error | Status.standard]) with
|
||
|
|
| `Exn _ -> `Internal_server_error
|
||
|
|
| #Status.standard as status -> status
|
||
|
|
in
|
||
|
|
t.error_handler ~request:t.request error (fun headers ->
|
||
|
|
let response_body =
|
||
|
|
unsafe_respond_with_streaming
|
||
|
|
t
|
||
|
|
~flush_headers_immediately:true
|
||
|
|
(Response.create ~headers status)
|
||
|
|
in
|
||
|
|
(* NOTE(anmonteiro): When reporting an error that calls the error
|
||
|
|
handler, we can only deliver an EOF to the request body once the error
|
||
|
|
response has started. Otherwise, the request body `on_eof` handler
|
||
|
|
could erroneously send a successful response instead of letting us
|
||
|
|
handle the error. *)
|
||
|
|
Body.Reader.close t.request_body;
|
||
|
|
response_body)
|
||
|
|
| other ->
|
||
|
|
Body.Reader.close t.request_body;
|
||
|
|
match other with
|
||
|
|
| Waiting, `Exn _ ->
|
||
|
|
(* XXX(seliopou): Decide what to do in this unlikely case. There is an
|
||
|
|
* outstanding call to the [error_handler], but an intervening exception
|
||
|
|
* has been reported as well. *)
|
||
|
|
failwith "httpun.Reqd.report_exn: NYI"
|
||
|
|
| Streaming (_response, response_body), `Ok ->
|
||
|
|
Body.Writer.force_close response_body;
|
||
|
|
Reader.wakeup t.reader;
|
||
|
|
| Streaming (_response, response_body), `Exn _ ->
|
||
|
|
Body.Writer.close response_body;
|
||
|
|
Writer.close_and_drain t.writer;
|
||
|
|
Reader.wakeup t.reader;
|
||
|
|
| (Fixed _ | Streaming _ | Upgrade _ | Waiting) , _ ->
|
||
|
|
(* XXX(seliopou): Once additional logging support is added, log the error
|
||
|
|
* in case it is not spurious. *)
|
||
|
|
()
|
||
|
|
|
||
|
|
let report_exn t exn =
|
||
|
|
report_error t (`Exn exn)
|
||
|
|
|
||
|
|
let try_with t f : (unit, exn) result =
|
||
|
|
try f (); Ok () with exn -> report_exn t exn; Error exn
|
||
|
|
|
||
|
|
(* Private API, not exposed to the user through httpun.mli *)
|
||
|
|
|
||
|
|
let close_request_body { request_body; _ } =
|
||
|
|
Body.Reader.close request_body
|
||
|
|
|
||
|
|
let error_code t =
|
||
|
|
match t.error_code with
|
||
|
|
| #error as error -> Some error
|
||
|
|
| `Ok -> None
|
||
|
|
|
||
|
|
let persistent_connection t =
|
||
|
|
t.persistent
|
||
|
|
|
||
|
|
let input_state t : Input_state.t =
|
||
|
|
match t.response_state with
|
||
|
|
| Upgrade _ -> Ready
|
||
|
|
| _ ->
|
||
|
|
if Body.Reader.is_closed t.request_body
|
||
|
|
then Complete
|
||
|
|
else if Body.Reader.is_read_scheduled t.request_body
|
||
|
|
then Ready
|
||
|
|
else Wait
|
||
|
|
|
||
|
|
let output_state { response_state; writer; _ } =
|
||
|
|
Response_state.output_state response_state ~writer
|
||
|
|
|
||
|
|
let flush_request_body t =
|
||
|
|
if Body.Reader.has_pending_output t.request_body
|
||
|
|
then try Body.Reader.execute_read t.request_body
|
||
|
|
with exn -> report_exn t exn
|
||
|
|
|
||
|
|
let flush_response_body t =
|
||
|
|
Response_state.flush_response_body t.response_state
|