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:58:23 +01:00
parent 46c9a392c0
commit c7466866df
1 changed files with 8 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

13
unikernel/unikernel.ml
View file

@ -29,6 +29,9 @@ let alpn =
let ( <.> ) f g x = f (g x) let ( <.> ) f g x = f (g x)
let always x _ = x let always x _ = x
let map_err_to_string pp_err res =
Lwt.map (R.reword_error (R.msgf "%a" pp_err)) res
module Make module Make
(Certificate : Mirage_kv.RO) (Certificate : Mirage_kv.RO)
(Key : Mirage_kv.RO) (Key : Mirage_kv.RO)
@ -36,14 +39,14 @@ module Make
(Connect : Connect.S) (Connect : Connect.S)
(HTTP_server : Paf_mirage.S) = (HTTP_server : Paf_mirage.S) =
struct struct
let tls certificate_ro key_ro = let tls certificate_ro key_ro =
let ( >>= ) = Lwt_result.bind in let ( >>= ) = Lwt_result.bind in
Key.list key_ro Mirage_kv.Key.empty Key.list key_ro Mirage_kv.Key.empty |> map_err_to_string Key.pp_error
|> Lwt.map (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
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)) |> map_err_to_string 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
@ -53,7 +56,7 @@ struct
| ".gitkeep" -> Lwt.return acc | ".gitkeep" -> Lwt.return acc
| _ -> | _ ->
Certificate.get certificate_ro name Certificate.get certificate_ro name
|> Lwt.map (R.reword_error (R.msgf "%a" Certificate.pp_error)) |> map_err_to_string 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 ->
@ -65,7 +68,7 @@ struct
| ".gitkeep" -> Lwt.return acc | ".gitkeep" -> Lwt.return acc
| _ -> | _ ->
Key.get key_ro name Key.get key_ro name
|> Lwt.map (R.reword_error (R.msgf "%a" Key.pp_error)) |> map_err_to_string 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)