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-02 18:28:11 +01:00
parent 9390ece117
commit bcbcdf88db
1 changed files with 27 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

61
unikernel/unikernel.ml
View file

@ -36,16 +36,14 @@ module Make
(Connect : Connect.S) (Connect : Connect.S)
(HTTP_server : Paf_mirage.S) = (HTTP_server : Paf_mirage.S) =
struct struct
let tls key_ro certificate_ro = let tls certificate_ro key_ro =
let open Lwt_result.Infix in let ( >>= ) = Lwt_result.bind in
Lwt.Infix.( Key.list key_ro Mirage_kv.Key.empty
Key.list key_ro Mirage_kv.Key.empty |> Lwt.map (R.reword_error (R.msgf "%a" Key.pp_error))
>|= R.reword_error (R.msgf "%a" Key.pp_error))
>>= fun keys -> >>= fun keys ->
let keys, _ = List.partition (fun (_, t) -> t = `Value) keys in let keys, _ = List.partition (fun (_, t) -> t = `Value) keys in
Lwt.Infix.( Certificate.list certificate_ro Mirage_kv.Key.empty
Certificate.list certificate_ro Mirage_kv.Key.empty |> Lwt.map (R.reword_error (R.msgf "%a" Certificate.pp_error))
>|= R.reword_error (R.msgf "%a" Certificate.pp_error))
>>= fun certificates -> >>= fun certificates ->
let certificates, _ = let certificates, _ =
List.partition (fun (_, t) -> t = `Value) certificates List.partition (fun (_, t) -> t = `Value) certificates
@ -54,10 +52,8 @@ struct
match Mirage_kv.Key.basename name with match Mirage_kv.Key.basename name with
| ".gitkeep" -> Lwt.return acc | ".gitkeep" -> Lwt.return acc
| _ -> | _ ->
let open Lwt_result.Infix in Certificate.get certificate_ro name
Lwt.Infix.( |> Lwt.map (R.reword_error (R.msgf "%a" Certificate.pp_error))
Certificate.get certificate_ro name
>|= R.reword_error (R.msgf "%a" Certificate.pp_error))
>>= (Lwt.return <.> X509.Certificate.decode_pem_multiple) >>= (Lwt.return <.> X509.Certificate.decode_pem_multiple)
>>= fun certificates -> >>= fun certificates ->
Lwt.return acc >>= fun acc -> Lwt.return acc >>= fun acc ->
@ -68,9 +64,8 @@ struct
match Mirage_kv.Key.basename name with match Mirage_kv.Key.basename name with
| ".gitkeep" -> Lwt.return acc | ".gitkeep" -> Lwt.return acc
| _ -> | _ ->
let open Lwt_result.Infix in Key.get key_ro name
Lwt.Infix.( |> Lwt.map (R.reword_error (R.msgf "%a" Key.pp_error))
Key.get key_ro name >|= R.reword_error (R.msgf "%a" Key.pp_error))
>>= (Lwt.return <.> X509.Private_key.decode_pem) >>= (Lwt.return <.> X509.Private_key.decode_pem)
>>= fun key -> >>= fun key ->
Lwt.return acc >>= fun acc -> Lwt.return_ok ((name, key) :: acc) Lwt.return acc >>= fun acc -> Lwt.return_ok ((name, key) :: acc)
@ -141,23 +136,21 @@ struct
let start certificate_ro key_ro tcpv4v6 ctx http_server = let start certificate_ro key_ro tcpv4v6 ctx http_server =
let open Lwt.Infix in let open Lwt.Infix in
let authenticator = Connect.authenticator in let authenticator = Connect.authenticator in
tls key_ro certificate_ro >>= fun tls -> tls certificate_ro key_ro >>= fun tls ->
if use_tls () then match use_tls () with
let tls = | false -> run ~ctx ~authenticator http_server
let certificates = | true -> (
match tls with match tls with
| Ok certificates -> certificates | 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 \ private key. Received error %s."
private key. Received error %s." m
m | Ok certificates -> (
in let alpn_protocols = alpn () in
let alpn_protocols = alpn () in match Tls.Config.server ~certificates ~alpn_protocols () with
match Tls.Config.server ~certificates ~alpn_protocols () with | Error (`Msg m) -> Fmt.failwith "TLS configuration error: %s." m
| Error (`Msg m) -> Fmt.failwith "TLS configuration error: %s." m | Ok tls ->
| Ok tls -> tls run_with_tls ~ctx ~authenticator ~tls http_server (tls_port ())
in tcpv4v6))
run_with_tls ~ctx ~authenticator ~tls http_server (tls_port ()) tcpv4v6
else run ~ctx ~authenticator http_server
end end