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

JJ: Description from the destination commit:

Browse source 
~ syntax stuff

JJ: Description from source commit:
~~
This commit is contained in:
swrup 2025-11-04 18:36:32 +01:00
parent 774d55ebb1
commit 1a65fa9b8c
4 changed files with 131 additions and 102 deletions
Download patch file Download diff file Expand all files Collapse all files

39
unikernel/server.ml
View file

@ -1,3 +1,5 @@
open Syntax
let src = Logs.Src.create "server"
module Log = (val Logs.src_log src : Logs.LOG)
@ -200,16 +202,18 @@ let hash_of_seed : type response request.
let transmit_over_http : to_close:_ -> Mimic.flow -> Mimic.flow -> unit Lwt.t =
fun ~to_close src dst ->
let open Lwt.Infix in
let closed = Lwt_mvar.create_empty () in
let rec loop ~src ~dst () =
Lwt.pick
[
Lwt_result.Infix.(
Mimic.read src >|= fun v -> (v :> [ `Closed | _ Mirage_flow.or_eof ]));
(Lwt_mvar.take closed >|= fun v -> Ok v);
]
>>= function
let* res =
Lwt.pick
[
(let+? v = Mimic.read src in
(v :> [ `Closed | _ Mirage_flow.or_eof ]));
(let+ v = Lwt_mvar.take closed in
Ok v);
]
in
match res with
| Error err ->
Log.err (fun m ->
m "Got an error while we reading the source (CONNECT): %a."
@ -224,8 +228,11 @@ let transmit_over_http : to_close:_ -> Mimic.flow -> Mimic.flow -> unit Lwt.t =
Log.debug (fun m -> m "Transfer over HTTP:");
Log.debug (fun m ->
m "@[<hov>%a@]." (Hxd_string.pp Hxd.default) (Cstruct.to_string cs));
Mimic.write dst cs >>= function
| Ok () -> Lwt.pause () >>= loop ~src ~dst
let* res = Mimic.write dst cs in
match res with
| Ok () ->
let* () = Lwt.pause () in
loop ~src ~dst ()
| Error err ->
Log.err (fun m ->
m
@ -235,9 +242,9 @@ let transmit_over_http : to_close:_ -> Mimic.flow -> Mimic.flow -> unit Lwt.t =
if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed
else Lwt.return_unit)
in
Lwt.join [ loop ~src ~dst (); loop ~src:dst ~dst:src () ] >>= fun () ->
let* () = Lwt.join [ loop ~src ~dst (); loop ~src:dst ~dst:src () ] in
to_close src;
Lwt.join [ Mimic.close src; Mimic.close dst ] >>= fun () ->
let* () = Lwt.join [ Mimic.close src; Mimic.close dst ] in
Log.debug (fun m -> m "Connection closed properly on both side.");
Lwt.return_unit
@ -278,9 +285,9 @@ let connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd =
match H1.Headers.get request.H1.Request.headers "host" with
| Some uri ->
let uri = "http://" ^ uri in
let open Lwt.Infix in
Lwt.async (fun () ->
Connect.create_connection ~ctx ~authenticator uri >>= function
let* res = Connect.create_connection ~ctx ~authenticator uri in
match res with
| Ok dst ->
let headers = H1.Headers.of_list [ ("connection", "close") ] in
let response =
@ -449,9 +456,9 @@ let connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd =
match H2.Headers.get request.H2.Request.headers "host" with
| Some uri ->
let uri = "http://" ^ uri in
let open Lwt.Infix in
Lwt.async (fun () ->
Connect.create_connection ~ctx ~authenticator uri >>= function
let* res = Connect.create_connection ~ctx ~authenticator uri in
match res with
| Ok dst ->
let response = H2.Response.create `OK in
H2.Reqd.respond_with_string reqd response "";