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

try to clean up lwt lwt_result monad

Browse source
This commit is contained in:
swrup 2025-11-02 18:28:11 +01:00
parent 9390ece117
commit 46c9a392c0
1 changed files with 27 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

37
unikernel/unikernel.ml
View file

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