+ load
This commit is contained in:
parent
5d322123ac
commit
a3fb058f61
2 changed files with 107 additions and 31 deletions
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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,6 +61,18 @@ struct
|
|||
|> Option.to_result ~none:(`Msg (Fmt.str "missing `%s` directory" name))
|
||||
|> Lwt_result.lift
|
||||
|
||||
let list_get_ok l =
|
||||
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 lwt_list_get_ok l =
|
||||
let open Lwt.Syntax in
|
||||
let+ l = l in
|
||||
|
|
@ -80,19 +91,71 @@ struct
|
|||
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 +253,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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue