JJ: Description from the destination commit:
load data/assets/terms/.. JJ: Description from source commit: + load
This commit is contained in:
parent
9390ece117
commit
11dcc8f9e9
2 changed files with 158 additions and 43 deletions
|
|
@ -29,35 +29,140 @@ 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
|
||||
|
||||
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
|
||||
list_get_ok l
|
||||
|
||||
module Make
|
||||
(Certificate : Mirage_kv.RO)
|
||||
(Key : Mirage_kv.RO)
|
||||
(Assets_ro : 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
|
||||
let tls key_ro certificate_ro =
|
||||
let open Lwt_result.Infix in
|
||||
Lwt.Infix.(
|
||||
Key.list key_ro Mirage_kv.Key.empty
|
||||
>|= R.reword_error (R.msgf "%a" Key.pp_error))
|
||||
module Assets = struct
|
||||
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 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 =
|
||||
lwt_list_get_ok
|
||||
@@ Lwt_list.map_s
|
||||
(fun lang_dir ->
|
||||
let+? files = get_values ro lang_dir in
|
||||
(lang_dir, files))
|
||||
subdirs
|
||||
in
|
||||
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
|
||||
Lwt_result.return (terms_assoc, privacy_assoc)
|
||||
end
|
||||
|
||||
let tls certificate_ro key_ro =
|
||||
let ( >>= ) = Lwt_result.bind in
|
||||
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
|
||||
Lwt.Infix.(
|
||||
Certificate.list certificate_ro Mirage_kv.Key.empty
|
||||
>|= 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
|
||||
| _ ->
|
||||
let open Lwt_result.Infix in
|
||||
Lwt.Infix.(
|
||||
Certificate.get certificate_ro name
|
||||
>|= 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 ->
|
||||
|
|
@ -68,9 +173,8 @@ struct
|
|||
match Mirage_kv.Key.basename name with
|
||||
| ".gitkeep" -> Lwt.return acc
|
||||
| _ ->
|
||||
let open Lwt_result.Infix in
|
||||
Lwt.Infix.(
|
||||
Key.get key_ro name >|= 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)
|
||||
|
|
@ -138,26 +242,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 key_ro certificate_ro >>= fun tls ->
|
||||
if use_tls () then
|
||||
let tls =
|
||||
let certificates =
|
||||
match tls with
|
||||
| Ok certificates -> certificates
|
||||
| Error (`Msg m) ->
|
||||
Fmt.failwith
|
||||
"A TLS server requires, at least, one certificate and one \
|
||||
private key. Received error %s."
|
||||
m
|
||||
in
|
||||
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 -> tls
|
||||
in
|
||||
run_with_tls ~ctx ~authenticator ~tls http_server (tls_port ()) tcpv4v6
|
||||
else run ~ctx ~authenticator http_server
|
||||
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