~ syntax stuff

This commit is contained in:
swrup 2025-11-04 18:36:32 +01:00
parent c1389c3906
commit 09a76fa8c1

View file

@ -1,5 +1,4 @@
open Rresult
open Lwt.Infix
open Cmdliner
let port =
@ -148,38 +147,45 @@ struct
end
let tls certificate_ro key_ro =
let ( >>= ) = Lwt_result.bind in
Keys_ro.list key_ro Mirage_kv.Key.empty
|> map_err_to_string Keys_ro.pp_error
>>= fun keys ->
let ( let*? ) = Lwt_result.bind in
let ( let+? ) x f = Lwt_result.map f x in
let*? keys =
Keys_ro.list key_ro Mirage_kv.Key.empty
|> map_err_to_string Keys_ro.pp_error
in
let keys = List.filter (fun (_, t) -> t = `Value) keys in
Certificates_ro.list certificate_ro Mirage_kv.Key.empty
|> map_err_to_string Certificates_ro.pp_error
>>= fun certificates ->
let*? certificates =
Certificates_ro.list certificate_ro Mirage_kv.Key.empty
|> map_err_to_string Certificates_ro.pp_error
in
let certificates = List.filter (fun (_, t) -> t = `Value) certificates in
let fold acc (name, _) =
match Mirage_kv.Key.basename name with
| ".gitkeep" -> Lwt.return acc
| _ ->
Certificates_ro.get certificate_ro name
|> map_err_to_string Certificates_ro.pp_error
>>= (Lwt.return <.> X509.Certificate.decode_pem_multiple)
>>= fun certificates ->
Lwt.return acc >>= fun acc ->
Lwt.return_ok ((name, certificates) :: acc)
let*? data =
Certificates_ro.get certificate_ro name
|> map_err_to_string Certificates_ro.pp_error
in
let*? certificates =
Lwt.return (X509.Certificate.decode_pem_multiple data)
in
let+? acc = Lwt.return acc in
(name, certificates) :: acc
in
Lwt_list.fold_left_s fold (Ok []) certificates >>= fun certificates ->
let*? certificates = Lwt_list.fold_left_s fold (Ok []) certificates in
let fold acc (name, _) =
match Mirage_kv.Key.basename name with
| ".gitkeep" -> Lwt.return acc
| _ ->
Keys_ro.get key_ro name
|> map_err_to_string Keys_ro.pp_error
>>= (Lwt.return <.> X509.Private_key.decode_pem)
>>= fun key ->
Lwt.return acc >>= fun acc -> Lwt.return_ok ((name, key) :: acc)
let*? data =
Keys_ro.get key_ro name |> map_err_to_string Keys_ro.pp_error
in
let*? key = Lwt.return (X509.Private_key.decode_pem data) in
let+? acc = Lwt.return acc in
(name, key) :: acc
in
Lwt_list.fold_left_s fold (Ok []) keys >>= fun keys ->
let+? keys = Lwt_list.fold_left_s fold (Ok []) keys in
let tbl = Hashtbl.create 0x10 in
List.iter
(fun (name, certificates) ->
@ -188,9 +194,9 @@ struct
| None -> ())
certificates;
match Hashtbl.fold (fun _ certchain acc -> certchain :: acc) tbl [] with
| [] -> Lwt.return_ok `None
| [ certchain ] -> Lwt.return_ok (`Single certchain)
| certchains -> Lwt.return_ok (`Multiple certchains)
| [] -> `None
| [ certchain ] -> `Single certchain
| certchains -> `Multiple certchains
let http_1_1_request_handler ~ctx ~authenticator flow _edn =
let module R = (val Mimic.repr HTTP_server.tcp_protocol) in
@ -223,6 +229,7 @@ struct
}
let run_with_tls ~ctx ~authenticator ~tls http_server tls_port tcpv4v6 =
let open Lwt.Infix in
let alpn_service =
HTTP_server.alpn_service ~tls (alpn_handler ~ctx ~authenticator)
in