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-04 18:45:30 +01:00
parent 09a76fa8c1
commit 70804cc387
1 changed files with 17 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

33
unikernel/unikernel.ml
View file

@ -56,9 +56,10 @@ module Make
(Connect : Connect.S) (Connect : Connect.S)
(HTTP_server : Paf_mirage.S) = (HTTP_server : Paf_mirage.S) =
struct struct
let ( let*? ) = Lwt_result.bind
let ( let+? ) x f = Lwt_result.map f x
module Assets = struct module Assets = struct
let ( let*? ) = Lwt_result.bind
let ( let+? ) x f = Lwt_result.map f x
let map_err_to_string = map_err_to_string Assets_ro.pp_error let map_err_to_string = map_err_to_string Assets_ro.pp_error
let get_subdirs ro k = let get_subdirs ro k =
@ -147,8 +148,6 @@ struct
end end
let tls certificate_ro key_ro = let tls certificate_ro key_ro =
let ( let*? ) = Lwt_result.bind in
let ( let+? ) x f = Lwt_result.map f x in
let*? keys = let*? keys =
Keys_ro.list key_ro Mirage_kv.Key.empty Keys_ro.list key_ro Mirage_kv.Key.empty
|> map_err_to_string Keys_ro.pp_error |> map_err_to_string Keys_ro.pp_error
@ -229,7 +228,6 @@ struct
} }
let run_with_tls ~ctx ~authenticator ~tls http_server tls_port tcpv4v6 = let run_with_tls ~ctx ~authenticator ~tls http_server tls_port tcpv4v6 =
let open Lwt.Infix in
let alpn_service = let alpn_service =
HTTP_server.alpn_service ~tls (alpn_handler ~ctx ~authenticator) HTTP_server.alpn_service ~tls (alpn_handler ~ctx ~authenticator)
in in
@ -237,10 +235,12 @@ struct
HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler
(http_1_1_request_handler ~ctx ~authenticator) (http_1_1_request_handler ~ctx ~authenticator)
in in
HTTP_server.init ~port:tls_port tcpv4v6 >|= Paf.serve alpn_service let open Lwt.Syntax in
>>= fun (`Initialized th0) -> let* server = HTTP_server.init ~port:tls_port tcpv4v6 in
Paf.serve http_1_1_service http_server |> fun (`Initialized th1) -> let (`Initialized th0) = Paf.serve alpn_service server in
Lwt.both th0 th1 >>= fun ((), ()) -> Lwt.return_unit let (`Initialized th1) = Paf.serve http_1_1_service http_server in
let+ (), () = Lwt.both th0 th1 in
()
let run ~ctx ~authenticator http_server = let run ~ctx ~authenticator http_server =
let http_1_1_service = let http_1_1_service =
@ -250,23 +250,24 @@ struct
Paf.serve http_1_1_service http_server |> fun (`Initialized th) -> th 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 ctx http_server =
let open Lwt.Infix in let open Lwt.Syntax in
let authenticator = Connect.authenticator in let authenticator = Connect.authenticator in
Assets.assets assets_ro >>= fun res -> let* assets_res = Assets.assets assets_ro in
match res with match assets_res with
| Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m | Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
| Ok (terms, _privacy) -> ( | Ok (_terms, _privacy) -> (
(*
let etag, lang_l, ext_l = terms in let etag, lang_l, ext_l = terms in
Fmt.pr "ETAG: %s@\nlanguages: %a@\nextensions: %a@." etag Fmt.pr "ETAG: %s@\nlanguages: %a@\nextensions: %a@." etag
(Fmt.list ~sep:(Fmt.any ", ") Fmt.string) (Fmt.list ~sep:(Fmt.any ", ") Fmt.string)
lang_l lang_l
(Fmt.list ~sep:(Fmt.any ", ") Fmt.string) (Fmt.list ~sep:(Fmt.any ", ") Fmt.string)
ext_l; ext_l; *)
tls certificate_ro key_ro >>= fun tls -> let* tls_res = tls certificate_ro key_ro in
match use_tls () with match use_tls () with
| false -> run ~ctx ~authenticator http_server | false -> run ~ctx ~authenticator http_server
| true -> ( | true -> (
match tls with match tls_res with
| Error (`Msg m) -> | Error (`Msg m) ->
Fmt.failwith Fmt.failwith
"A TLS server requires, at least, one certificate and one \ "A TLS server requires, at least, one certificate and one \