swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

lwt request_handler

Browse source
This commit is contained in:
swrup 2025-11-06 14:30:48 +01:00
parent bd44c46fca
commit 6318be5aad
3 changed files with 36 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/dune
View file

@ -1,4 +1,4 @@
(library (library
(name mte) (name mte)
(wrapped false) (wrapped false)
(libraries logs h2)) (libraries logs h2 lwt))

4
src/mte.ml
View file

@ -39,8 +39,8 @@ let request_handler request =
| [ "" ] -> | [ "" ] ->
let content = home_page_text in let content = home_page_text in
let headers = default_headers ~content `Text_plain in let headers = default_headers ~content `Text_plain in
{ status= `OK; headers; content } Lwt.return { status= `OK; headers; content }
| _ -> | _ ->
let content = "Not found." in let content = "Not found." in
let headers = default_headers ~content `Text_plain in let headers = default_headers ~content `Text_plain in
{ status= `Not_found; headers; content } Lwt.return { status= `Not_found; headers; content }

49
unikernel/server.ml
View file

@ -16,26 +16,43 @@ let http_1_1_request_handler reqd =
let request = H1.Reqd.request reqd in let request = H1.Reqd.request reqd in
Log.debug (fun m -> Log.debug (fun m ->
m "(HTTP/1.1) request-handler: %S" request.H1.Request.target); m "(HTTP/1.1) request-handler: %S" request.H1.Request.target);
let Mte.{ status; headers; content } = Lwt.async @@ fun () ->
Mte.request_handler (request_from_h1 ~scheme:"http" request) Lwt.catch
in (fun () ->
let status = let open Syntax in
match status with let+ Mte.{ status; headers; content } =
| #H1.Status.t as status -> status Mte.request_handler (request_from_h1 ~scheme:"http" request)
| _ -> Fmt.failwith "H2 status response on a H1 request" in
in let status =
let headers = H1.Headers.of_list (Headers.to_list headers) in match status with
let response = H1.Response.create ~headers status in | #H1.Status.t as status -> status
H1.Reqd.respond_with_string reqd response content | _ -> 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;
())
(fun exn ->
(* note: not sure what this does exactly, this is what is done in Dream *)
H1.Reqd.report_exn reqd exn;
Lwt.return_unit)
let http_2_0_request_handler reqd = let http_2_0_request_handler reqd =
let request = H2.Reqd.request reqd in let request = H2.Reqd.request reqd in
Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target); Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target);
let Mte.{ status; headers; content } = Lwt.async @@ fun () ->
Mte.request_handler (request_from_h2 request) Lwt.catch
in (fun () ->
let response = H2.Response.create ~headers status in let open Syntax in
H2.Reqd.respond_with_string reqd response content 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;
())
(fun exn ->
H2.Reqd.report_exn reqd exn;
Lwt.return_unit)
let alpn_request_handler : type reqd headers request response ro wo. let alpn_request_handler : type reqd headers request response ro wo.
reqd -> (reqd, headers, request, response, ro, wo) Alpn.protocol -> unit = reqd -> (reqd, headers, request, response, ro, wo) Alpn.protocol -> unit =