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 19:09:47 +01:00
parent 6e6c213cb5
commit 7212475e76
1 changed files with 13 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

25
unikernel/unikernel.ml
View file

@ -33,27 +33,28 @@ let map_err_to_string pp_err res =
Lwt.map (R.reword_error (R.msgf "%a" pp_err)) res Lwt.map (R.reword_error (R.msgf "%a" pp_err)) res
module Make module Make
(Certificate : Mirage_kv.RO) (Certificates_ro : Mirage_kv.RO)
(Key : Mirage_kv.RO) (Keys_ro : Mirage_kv.RO)
(Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t) (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t)
(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 |> map_err_to_string Key.pp_error Keys_ro.list key_ro Mirage_kv.Key.empty
|> map_err_to_string Keys_ro.pp_error
>>= fun keys -> >>= fun keys ->
let keys = List.filter (fun (_, t) -> t = `Value) keys in let keys = List.filter (fun (_, t) -> t = `Value) keys in
Certificate.list certificate_ro Mirage_kv.Key.empty Certificates_ro.list certificate_ro Mirage_kv.Key.empty
|> map_err_to_string Certificate.pp_error |> map_err_to_string Certificates_ro.pp_error
>>= fun certificates -> >>= fun certificates ->
let certificates = List.filter (fun (_, t) -> t = `Value) certificates in let certificates = List.filter (fun (_, t) -> t = `Value) certificates in
let fold acc (name, _) = let fold acc (name, _) =
match Mirage_kv.Key.basename name with match Mirage_kv.Key.basename name with
| ".gitkeep" -> Lwt.return acc | ".gitkeep" -> Lwt.return acc
| _ -> | _ ->
Certificate.get certificate_ro name Certificates_ro.get certificate_ro name
|> map_err_to_string Certificate.pp_error |> map_err_to_string Certificates_ro.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 ->
@ -64,8 +65,8 @@ struct
match Mirage_kv.Key.basename name with match Mirage_kv.Key.basename name with
| ".gitkeep" -> Lwt.return acc | ".gitkeep" -> Lwt.return acc
| _ -> | _ ->
Key.get key_ro name Keys_ro.get key_ro name
|> map_err_to_string Key.pp_error |> map_err_to_string Keys_ro.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)
@ -74,9 +75,9 @@ struct
let tbl = Hashtbl.create 0x10 in let tbl = Hashtbl.create 0x10 in
List.iter List.iter
(fun (name, certificates) -> (fun (name, certificates) ->
match List.assoc_opt name keys with Option.iter
| Some key -> Hashtbl.add tbl name (certificates, key) (fun key -> Hashtbl.add tbl name (certificates, key))
| None -> ()) (List.assoc_opt name keys))
certificates; certificates;
match Hashtbl.fold (fun _ certchain acc -> certchain :: acc) tbl [] with match Hashtbl.fold (fun _ certchain acc -> certchain :: acc) tbl [] with
| [] -> Lwt.return_ok `None | [] -> Lwt.return_ok `None