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

Browse source
This commit is contained in:
swrup 2025-11-05 19:51:17 +01:00
parent 5970e01626
commit 9b6e29bb4f
6 changed files with 87 additions and 500 deletions
Download patch file Download diff file Expand all files Collapse all files

52
unikernel/unikernel.ml
View file

@ -34,7 +34,6 @@ module Make
(Certificates_ro : Mirage_kv.RO)
(Keys_ro : Mirage_kv.RO)
(Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t)
(Connect : Connect.S)
(HTTP_server : Paf_mirage.S) =
struct
module Assets = struct
@ -200,43 +199,22 @@ struct
let always x _ = x
let http_1_1_request_handler ~ctx ~authenticator flow _edn =
let module R = (val Mimic.repr HTTP_server.tcp_protocol) in
fun reqd ->
match (H1.Reqd.request reqd).H1.Request.meth with
| `CONNECT ->
HTTP_server.TCP.no_close flow;
let to_close = function
| R.T flow -> HTTP_server.TCP.to_close flow
| _ -> ()
in
Server.http_1_1_request_handler ~ctx ~authenticator ~to_close
(R.T flow) reqd
| _ ->
Server.http_1_1_request_handler ~ctx ~authenticator
~to_close:(always ()) (R.T flow) reqd
let http_1_1_request_handler _flow _edn reqd =
Server.http_1_1_request_handler reqd
let alpn_handler ~ctx ~authenticator =
let module R = (val Mimic.repr HTTP_server.tls_protocol) in
let to_close = function
| R.T flow -> HTTP_server.TLS.to_close flow
| _ -> ()
in
let alpn_handler =
{
Alpn.error= Server.alpn_error_handler;
Alpn.request=
(fun flow edn reqd protocol ->
Server.alpn_request_handler ~ctx ~authenticator ~to_close (R.T flow)
edn reqd protocol);
(fun _flow _edn reqd protocol ->
Server.alpn_request_handler reqd protocol);
}
let run_with_tls ~ctx ~authenticator ~tls http_server tls_port tcpv4v6 =
let alpn_service =
HTTP_server.alpn_service ~tls (alpn_handler ~ctx ~authenticator)
in
let run_with_tls ~tls http_server tls_port tcpv4v6 =
let alpn_service = HTTP_server.alpn_service ~tls alpn_handler in
let http_1_1_service =
HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler
(http_1_1_request_handler ~ctx ~authenticator)
http_1_1_request_handler
in
let open Lwt.Syntax in
let* server = HTTP_server.init ~port:tls_port tcpv4v6 in
@ -245,23 +223,22 @@ struct
let+ (), () = Lwt.both th0 th1 in
()
let run ~ctx ~authenticator http_server =
let run http_server =
let http_1_1_service =
HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler
(http_1_1_request_handler ~ctx ~authenticator)
http_1_1_request_handler
in
Paf.serve http_1_1_service http_server |> fun (`Initialized th) -> th
let start assets_ro certificate_ro key_ro tcpv4v6 ctx http_server =
let start assets_ro certificate_ro key_ro tcpv4v6 http_server =
let open Lwt.Syntax in
let authenticator = Connect.authenticator in
let* assets_res = Assets.assets assets_ro in
match assets_res with
| Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
| Ok (_terms_etag, _privacy_etag, _lang_l, _ext_l) -> (
let* tls_res = tls certificate_ro key_ro in
match use_tls () with
| false -> run ~ctx ~authenticator http_server
| false -> run http_server
| true -> (
match tls_res with
| Error (`Msg m) ->
@ -274,7 +251,6 @@ struct
match Tls.Config.server ~certificates ~alpn_protocols () with
| Error (`Msg m) ->
Fmt.failwith "TLS configuration error: %s." m
| Ok tls ->
run_with_tls ~ctx ~authenticator ~tls http_server
(tls_port ()) tcpv4v6)))
| Ok tls -> run_with_tls ~tls http_server (tls_port ()) tcpv4v6)
))
end