From 3f28473f42df00663331b3f43ee4f350e1069e1b Mon Sep 17 00:00:00 2001 From: swrup Date: Sun, 2 Nov 2025 18:58:23 +0100 Subject: [PATCH] JJ: Description from the destination commit: ~ JJ: Description from source commit: load data/assets/terms/.. --- unikernel/unikernel.ml | 85 +++++++++++++++++++++++++++++++++++------- 1 file changed, 71 insertions(+), 14 deletions(-) diff --git a/unikernel/unikernel.ml b/unikernel/unikernel.ml index 6e8ce596..5a00b37b 100644 --- a/unikernel/unikernel.ml +++ b/unikernel/unikernel.ml @@ -29,31 +29,88 @@ let alpn = let ( <.> ) f g x = f (g 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 - (Certificate : Mirage_kv.RO) - (Key : Mirage_kv.RO) + (Certificates_ro : Mirage_kv.RO) + (Keys_ro : Mirage_kv.RO) (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t) (Connect : Connect.S) (HTTP_server : Paf_mirage.S) = struct + (* WIP + read directories *) + module Assets = struct + module Assets_ro = Keys_ro + + let ( let*? ) = Lwt_result.bind + let ( let+? ) x f = Lwt_result.map f x + let map_err_to_string = map_err_to_string Assets_ro.pp_error + + let get_subdirs ro k = + let+? keys = Assets_ro.list ro k |> map_err_to_string in + List.filter (fun (_, t) -> t = `Dictionary) keys |> List.map fst + + let get_values ro k = + let+? keys = Assets_ro.list ro k |> map_err_to_string in + List.filter (fun (_, t) -> t = `Value) keys |> List.map fst + + let find keys name = + keys + |> List.find_opt Mirage_kv.Key.(equal (v name)) + |> Option.to_result ~none:(`Msg (Fmt.str "missing `%s` directory" name)) + |> Lwt_result.lift + + let lwt_list_get_ok l = + let open Lwt.Syntax in + let+ l = l in + let err = ref None in + try + l + |> List.map (function + | Error _e as e -> + err := Some e; + raise Exit + | Ok v -> v) + |> Result.ok + with Exit -> ( match !err with None -> assert false | Some v -> v) + + let get ro s = + let*? base_dir = get_subdirs ro Mirage_kv.Key.empty in + let*? dir = find base_dir s in + let*? subdirs = get_subdirs ro dir in + let+? l = + subdirs + |> Lwt_list.map_s (fun lang_dir -> + let+? files = get_values ro lang_dir in + (lang_dir, files)) + |> lwt_list_get_ok + in + l + + let assets ro = + let*? terms_assoc = get ro "terms" in + let+? privacy_assoc = get ro "privacy" in + (terms_assoc, privacy_assoc) + end + let tls certificate_ro key_ro = let ( >>= ) = Lwt_result.bind in - Key.list key_ro Mirage_kv.Key.empty - |> Lwt.map (R.reword_error (R.msgf "%a" Key.pp_error)) + Keys_ro.list key_ro Mirage_kv.Key.empty + |> map_err_to_string Keys_ro.pp_error >>= fun keys -> - let keys, _ = List.partition (fun (_, t) -> t = `Value) keys in - Certificate.list certificate_ro Mirage_kv.Key.empty - |> Lwt.map (R.reword_error (R.msgf "%a" Certificate.pp_error)) + 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, _ = - List.partition (fun (_, t) -> t = `Value) certificates - 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 | _ -> - Certificate.get certificate_ro name - |> Lwt.map (R.reword_error (R.msgf "%a" Certificate.pp_error)) + 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 -> @@ -64,8 +121,8 @@ struct match Mirage_kv.Key.basename name with | ".gitkeep" -> Lwt.return acc | _ -> - Key.get key_ro name - |> Lwt.map (R.reword_error (R.msgf "%a" Key.pp_error)) + 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)