103 lines
3.5 KiB
OCaml
103 lines
3.5 KiB
OCaml
let src = Logs.Src.create "server"
|
|
|
|
module Log = (val Logs.src_log src : Logs.LOG)
|
|
module Method = Mte.Method
|
|
module Headers = Mte.Headers
|
|
module Status = Mte.Status
|
|
|
|
let request_from_h1 ~scheme { H1.Request.meth; target; headers; _ } =
|
|
let headers = Mte.Headers.of_list (H1.Headers.to_list headers) in
|
|
Mte.{ meth; target; scheme; headers }
|
|
|
|
let request_from_h2 { H2.Request.meth; target; scheme; headers } =
|
|
Mte.{ meth; target; scheme; headers }
|
|
|
|
let http_1_1_request_handler reqd =
|
|
let request = H1.Reqd.request reqd in
|
|
Log.debug (fun m ->
|
|
m "(HTTP/1.1) request-handler: %S" request.H1.Request.target);
|
|
let Mte.{ status; headers; content } =
|
|
Mte.request_handler (request_from_h1 ~scheme:"http" request)
|
|
in
|
|
let status =
|
|
match status with
|
|
| #H1.Status.t as status -> status
|
|
| _ -> Fmt.failwith "H2 status response on a H1 request"
|
|
in
|
|
let headers = H1.Headers.of_list (Headers.to_list headers) in
|
|
let response = H1.Response.create ~headers status in
|
|
H1.Reqd.respond_with_string reqd response content
|
|
|
|
let http_2_0_request_handler reqd =
|
|
let request = H2.Reqd.request reqd in
|
|
Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target);
|
|
let Mte.{ status; headers; content } =
|
|
Mte.request_handler (request_from_h2 request)
|
|
in
|
|
let response = H2.Response.create ~headers status in
|
|
H2.Reqd.respond_with_string reqd response content
|
|
|
|
let alpn_request_handler : type reqd headers request response ro wo.
|
|
reqd -> (reqd, headers, request, response, ro, wo) Alpn.protocol -> unit =
|
|
fun reqd -> function
|
|
| Alpn.HTTP_1_1 _ -> http_1_1_request_handler reqd
|
|
| Alpn.H2 _ -> http_2_0_request_handler reqd
|
|
|
|
let headers_of_list : type reqd headers request response ro wo.
|
|
(reqd, headers, request, response, ro, wo) Alpn.protocol ->
|
|
(string * string) list ->
|
|
headers =
|
|
fun protocol lst ->
|
|
match protocol with
|
|
| Alpn.HTTP_1_1 _ -> H1.Headers.of_list lst
|
|
| Alpn.H2 _ -> H2.Headers.of_list lst
|
|
|
|
let respond_with_string : type reqd headers request response ro wo.
|
|
(reqd, headers, request, response, ro, wo) Alpn.protocol ->
|
|
headers:headers ->
|
|
respond:(headers -> wo) ->
|
|
string ->
|
|
unit =
|
|
fun protocol ~headers ~respond str ->
|
|
let body = respond headers in
|
|
match protocol with
|
|
| Alpn.HTTP_1_1 _ ->
|
|
H1.Body.Writer.write_string body str;
|
|
H1.Body.Writer.close body
|
|
| Alpn.H2 _ ->
|
|
H2.Body.Writer.write_string body str;
|
|
H2.Body.Writer.close body
|
|
|
|
let alpn_error_handler : type reqd headers request response ro wo.
|
|
_ ->
|
|
(reqd, headers, request, response, ro, wo) Alpn.protocol ->
|
|
?request:_ ->
|
|
_ ->
|
|
(headers -> wo) ->
|
|
unit =
|
|
fun _edn protocol ?request:_ error respond ->
|
|
let contents =
|
|
match error with
|
|
| `Bad_gateway -> {|Bad gateway.|}
|
|
| `Bad_request -> {|Bad request.|}
|
|
| `Exn (Paf.Flow err) | `Exn (Paf.Flow_write err) ->
|
|
Fmt.str {|I/O error: %s.|} err
|
|
| `Exn exn -> Fmt.str {|Unknown error: %S.|} (Printexc.to_string exn)
|
|
| `Internal_server_error -> {|Internal server error.|}
|
|
in
|
|
let headers =
|
|
headers_of_list protocol
|
|
[
|
|
("content-type", "text/plain");
|
|
("content-length", string_of_int (String.length contents));
|
|
]
|
|
in
|
|
respond_with_string protocol ~respond ~headers contents
|
|
|
|
let http_1_1_error_handler edn ?request error respond =
|
|
alpn_error_handler edn ?request Alpn.http_1_1
|
|
(error :> Alpn.server_error)
|
|
respond
|
|
|
|
let http_2_0_error_handler edn ?request error respond =
|
|
alpn_error_handler edn ?request Alpn.h2 (error :> Alpn.server_error) respond
|