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:00:31 +01:00
parent 9390ece117
commit e5d44b2363
1 changed files with 30 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

39
unikernel/unikernel.ml
View file

@ -28,6 +28,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 ( let* ) = Result.bind
let ( let$ ) = Lwt.bind
let ( let*$ ) = Lwt_result.bind
module Make module Make
(Certificate : Mirage_kv.RO) (Certificate : Mirage_kv.RO)
@ -36,25 +39,43 @@ module Make
(Connect : Connect.S) (Connect : Connect.S)
(HTTP_server : Paf_mirage.S) = (HTTP_server : Paf_mirage.S) =
struct struct
let rm_gitkeep l =
List.filter (fun (name, _) -> ".gitkeep" <> Mirage_kv.Key.basename name) l
let tls key_ro certificate_ro = let tls key_ro certificate_ro =
let open Lwt_result.Infix in let open Lwt_result.Infix in
Lwt.Infix.( let*$ keys =
Key.list key_ro Mirage_kv.Key.empty Lwt.Infix.(
>|= R.reword_error (R.msgf "%a" Key.pp_error)) Key.list key_ro Mirage_kv.Key.empty
>>= fun keys -> >|= R.reword_error (R.msgf "%a" Key.pp_error))
in
let keys, _ = List.partition (fun (_, t) -> t = `Value) keys in let keys, _ = List.partition (fun (_, t) -> t = `Value) keys in
Lwt.Infix.( let*$ certificates =
Certificate.list certificate_ro Mirage_kv.Key.empty Lwt.Infix.(
>|= R.reword_error (R.msgf "%a" Certificate.pp_error)) Certificate.list certificate_ro Mirage_kv.Key.empty
>>= fun certificates -> >|= R.reword_error (R.msgf "%a" Certificate.pp_error))
in
let certificates, _ = let certificates, _ =
List.partition (fun (_, t) -> t = `Value) certificates List.partition (fun (_, t) -> t = `Value) certificates
in in
let certificates = rm_gitkeep certificates in
let certificates =
certificates
|> List.map (fun (name, _) ->
let*$ data =
Lwt.Infix.(
Certificate.get certificate_ro name
>|= R.reword_error (R.msgf "%a" Certificate.pp_error))
in
let*$ certificates =
Lwt.return @@ X509.Certificate.decode_pem_multiple data
in
Lwt_result.return (name, 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
| _ -> | _ ->
let open Lwt_result.Infix in
Lwt.Infix.( Lwt.Infix.(
Certificate.get certificate_ro name Certificate.get certificate_ro name
>|= R.reword_error (R.msgf "%a" Certificate.pp_error)) >|= R.reword_error (R.msgf "%a" Certificate.pp_error))