diff --git a/unikernel/config.ml b/unikernel/config.ml index f11dfb93..687154f2 100644 --- a/unikernel/config.ml +++ b/unikernel/config.ml @@ -13,7 +13,7 @@ let mte = package "hxd" ~sublibs:[ "core"; "string" ]; package "rresult"; package "h2" ~min:"0.13.0"; package "base64" ~sublibs:[ "rfc2045" ]; ] - (kv_ro @-> kv_ro @-> tcpv4v6 @-> conn @-> http_server @-> job) + (kv_ro @-> kv_ro @-> kv_ro @-> tcpv4v6 @-> conn @-> http_server @-> job) let conn = let connect _ modname = function @@ -29,6 +29,7 @@ let he = generic_happy_eyeballs stackv4v6 let dns = generic_dns_client stackv4v6 he let certificates = crunch "../data/tls/certificates" let keys = crunch "../data/tls/keys" +let assets = crunch "../data/assets" let conn = let happy_eyeballs = mimic_happy_eyeballs stackv4v6 he dns in @@ -38,4 +39,5 @@ let port = Runtime_arg.create ~pos:__POS__ "Unikernel.port" let http_server = paf_server ~port tcpv4v6 let () = - register "mte" [ mte $ certificates $ keys $ tcpv4v6 $ conn $ http_server ] + register "mte" + [ mte $ assets $ certificates $ keys $ tcpv4v6 $ conn $ http_server ] diff --git a/unikernel/unikernel.ml b/unikernel/unikernel.ml index 5a00b37b..1f2694d1 100644 --- a/unikernel/unikernel.ml +++ b/unikernel/unikernel.ml @@ -33,6 +33,7 @@ let map_err_to_string pp_err res = Lwt.map (R.reword_error (R.msgf "%a" pp_err)) res module Make + (Assets_ro : Mirage_kv.RO) (Certificates_ro : Mirage_kv.RO) (Keys_ro : Mirage_kv.RO) (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t) @@ -42,8 +43,6 @@ 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 @@ -62,9 +61,7 @@ struct |> 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 list_get_ok l = let err = ref None in try l @@ -76,23 +73,80 @@ struct |> Result.ok with Exit -> ( match !err with None -> assert false | Some v -> v) + let lwt_list_get_ok l = + let open Lwt.Syntax in + let+ l = l in + list_get_ok l + 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 + let*? l = + lwt_list_get_ok + @@ Lwt_list.map_s + (fun lang_dir -> + let+? files = get_values ro lang_dir in + (lang_dir, files)) + subdirs in - l + Lwt.return + @@ + let open Result.Syntax in + let* l = + list_get_ok + @@ List.map + (fun (lang, l) -> + let lang = Mirage_kv.Key.basename lang in + let* l = + List.map Mirage_kv.Key.basename l + |> List.map (fun s -> + match String.split_on_char '.' s with + | [] -> assert false + | [ etag; ext ] -> Ok (etag, ext) + | _ -> Error (`Msg (Fmt.str "invalid file name: `%s`" s))) + |> list_get_ok + in + let etag_l, ext_l = List.split l in + Ok (lang, etag_l, ext_l)) + l + in + let lang_l = + l |> List.map (fun (v, _, _) -> v) |> List.sort String.compare + in + let* etag = + let etag_l = l |> List.map (fun (_, v, _) -> v) |> List.concat in + match List.sort_uniq String.compare etag_l with + | [ etag ] -> Ok etag + | [] -> + Fmt.error_msg "directory `%s` is empty" + (Mirage_kv.Key.to_string dir) + | l -> + Fmt.error_msg "directory `%s` contains more than one etag: %a" + (Mirage_kv.Key.to_string dir) + (Fmt.list Fmt.string) l + in + let* ext_l = + let ll = + l + |> List.map (fun (_, _, v) -> v) + |> List.map (List.sort String.compare) + in + match List.sort_uniq Stdlib.compare ll with + | [ l ] -> Ok l + | [] -> assert false + | _ll -> + Fmt.error_msg + "directory `%s` does not has the same set of file extensions for \ + each language" + (Mirage_kv.Key.to_string dir) + in + Ok (etag, lang_l, ext_l) let assets ro = let*? terms_assoc = get ro "terms" in - let+? privacy_assoc = get ro "privacy" in - (terms_assoc, privacy_assoc) + let*? privacy_assoc = get ro "privacy" in + Lwt_result.return (terms_assoc, privacy_assoc) end let tls certificate_ro key_ro = @@ -190,24 +244,35 @@ struct in Paf.serve http_1_1_service http_server |> fun (`Initialized th) -> th - let start certificate_ro key_ro tcpv4v6 ctx http_server = + let start assets_ro certificate_ro key_ro tcpv4v6 ctx http_server = let open Lwt.Infix in let authenticator = Connect.authenticator in - tls certificate_ro key_ro >>= fun tls -> - match use_tls () with - | false -> run ~ctx ~authenticator http_server - | true -> ( - match tls with - | Error (`Msg m) -> - Fmt.failwith - "A TLS server requires, at least, one certificate and one \ - private key. Received error %s." - m - | Ok certificates -> ( - let alpn_protocols = alpn () in - match Tls.Config.server ~certificates ~alpn_protocols () with - | Error (`Msg m) -> Fmt.failwith "TLS configuration error: %s." m - | Ok tls -> - run_with_tls ~ctx ~authenticator ~tls http_server (tls_port ()) - tcpv4v6)) + Assets.assets assets_ro >>= fun res -> + match res with + | Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m + | Ok (terms, _privacy) -> ( + let etag, lang_l, ext_l = terms in + Fmt.pr "ETAG: %s@\nlanguages: %a@\nextensions: %a@." etag + (Fmt.list ~sep:(Fmt.any ", ") Fmt.string) + lang_l + (Fmt.list ~sep:(Fmt.any ", ") Fmt.string) + ext_l; + tls certificate_ro key_ro >>= fun tls -> + match use_tls () with + | false -> run ~ctx ~authenticator http_server + | true -> ( + match tls with + | Error (`Msg m) -> + Fmt.failwith + "A TLS server requires, at least, one certificate and one \ + private key. Received error %s." + m + | Ok certificates -> ( + let alpn_protocols = alpn () in + match Tls.Config.server ~certificates ~alpn_protocols () with + | Error (`Msg m) -> + Fmt.failwith "TLS configuration error: %s." m + | Ok tls -> + run_with_tls ~ctx ~authenticator ~tls http_server + (tls_port ()) tcpv4v6))) end